Produced by Araxis Merge on 8/4/2017 8:56:54 AM Eastern Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.
| # | Location | File | Last Modified |
|---|---|---|---|
| 1 | IB_2.0_577.zip | TAS+eBill+SDD+US11+v1.02.docx | Tue Aug 1 17:53:50 2017 UTC |
| 2 | IB_2.0_577.zip | TAS+eBill+SDD+US11+v1.02.docx | Wed Aug 2 19:26:17 2017 UTC |
| Description | Between Files 1 and 2 |
|
|---|---|---|
| Text Blocks | Lines | |
| Unchanged | 1 | 1108 |
| Changed | 0 | 0 |
| Inserted | 0 | 0 |
| Removed | 0 | 0 |
| Whitespace | |
|---|---|
| Character case | Differences in character case are significant |
| Line endings | Differences in line endings (CR and LF characters) are ignored |
| CR/LF characters | Not shown in the comparison detail |
No regular expressions were active.
| 1 | TAS eBill SDD US11 | |
| 2 | System Des ign Docume nt | |
| 3 | IB*2.0*577 | |
| 4 | ||
| 5 | ||
| 6 | ||
| 7 | ||
| 8 | Department of Vetera ns Affairs | |
| 9 | May 2017 | |
| 10 | Version 1. 02 | |
| 11 | User Story Number: U SEB-15 | |
| 12 | User Story Name: Uni t or Basis for Measu rements Co des for Dr ugs (Backl og #142) | |
| 13 | Rally ID: US-11 | |
| 14 | ||
| 15 | Resolution : | |
| 16 | To satisfy the enhan cement req uest descr ibed by th e aforemen tioned Use r Story, t he followi ng needs t o occur: | |
| 17 | CREATE the new UNITS /BASIS OF MEASUREMEN T field [# 399.0304, 52]. This field is r equired if there is an NDC num ber. | |
| 18 | MODIFY a l ine of cod e in the r outine ^IB CU7 to pro mpt for th e NDC fiel d [#399.03 04, 53], t hen prompt for the n ew UNITS/B ASIS OF ME ASUREMENT field [#39 9.0304, 52 ] and then prompt fo r the UNIT S field [ #399.0304, 54]. | |
| 19 | ADD two ne w triggers to the ND C field [# 399.0304, 53] that r equire the UNITS/BAS IS OF MEAS UREMENT fi eld [#399. 0304, 52] and the UN ITS field [#399.0304 , 54] to b e populate d if there is an NDC number pr esent. | |
| 20 | ADD a new validation code to c heck claim lines and confirm t hat if the NDC field is popula ted, then the UNITS and UNITS/ BASIS OF M EASUREMENT fields ar e populate d as well. | |
| 21 | MODIFY [#3 64.7, 941] to proper ly include the UNITS /BASIS OF MEASUREMEN T in the “ PRF” (Prof essional) Segment of the 837, piece 25. | |
| 22 | MODIFY [#3 64.7, 1950 ] to prope rly includ e the UNIT S/BASIS OF MEASUREME NT in the “INS” (Ins titutional ) Segment of the 837 , piece 17 . | |
| 23 | ADD a new error code to the Er ror Code f ile [#350. 8] for the line leve l check on NDC numbe r and the UNITS/BASI S OF MEASU REMENT and the UNITS fields. | |
| 24 | ADD the #3 64.7 file to the bui ld for all of the up dated OUTP UT FORMATT ER entries . | |
| 25 | MODIFY the ^IBCEF11 and ^IBCF2 3A routine s to updat e the 837 and printe d CMS 1500 for the n ew UNITS/B ASIS OF ME ASUREMENT field. | |
| 26 | MODIFY the ^IBCEF22 routines t o update t he printed UB-04 for the new U NITS/BASIS OF MEASUR EMENT fiel d. | |
| 27 | MODIFY the acceptabl e format o f the UNIT S field (# 399.0304, 54) so tha t it’s for mat can be “99999999 999.999”. | |
| 28 | The FORMAT CODE of I NS-16 and PRF-23 for the 837 T ransmissio n (in the IB FORM FI ELD CONTEN T file [#3 64.7], ent ries 939 a nd 1949) n eeds to be changed r emove the decimal po int “.” fr om the out put format ter. | |
| 29 | CREATE the New ^IBY5 77PR Pre-I nstall Rou tine | |
| 30 | ||
| 31 | ||
| 32 | Data Desig n: | |
| 33 | CREATE the new UNITS /BASIS OF MEASUREMEN T field [# 399.0304, 52]. This field is r equired if there is an NDC num ber. | |
| 34 | 399.0304,5 2 UNITS/ BASIS OF M EASUREMENT 2;1 SE T | |
| 35 | ||
| 36 | Units /Basis of Measuremen t | |
| 37 | 'F2' FOR Internati onal Unit; | |
| 38 | 'GR' FOR Gram; | |
| 39 | 'ME' FOR Milligram ; | |
| 40 | 'ML' FOR Millilite r; | |
| 41 | 'UN' FOR Unit; | |
| 42 | LAST E DITED: MAY 3, 2 017 | |
| 43 | HELP-P ROMPT: Enter th e units or basis for measureme nt | |
| 44 | ass ociated wi th the Med ication. | |
| 45 | DESCRI PTION: This fie ld is used to associ ate the co rrect | |
| 46 | unit or measur ement with Medicatio n is being | |
| 47 | spec ified. | |
| 48 | ||
| 49 | MODIFY a l ine of cod e in the r outine ^IB CU7 to pro mpt for th e NDC fiel d [#399.03 04, 53], t hen prompt for the n ew UNITS/B ASIS OF ME ASUREMENT field [#39 9.0304, 52 ] and then prompt fo r the UNIT S field [ #399.0304, 54]. | |
| 50 | The displa y should b e as below : | |
| 51 | NDC NUMBER : | |
| 52 | UNITS/BASI S OF MEASU REMENT: | |
| 53 | QUANTITY: | |
| 54 | Routines | |
| 55 | Activities | |
| 56 | Routine Na me | |
| 57 | IBCU7 | |
| 58 | Enhancemen t Category | |
| 59 | New | |
| 60 | Modify | |
| 61 | Delete | |
| 62 | No Change | |
| 63 | RTM | |
| 64 | ||
| 65 | Related Op tions | |
| 66 | None | |
| 67 | Related Ro utines | |
| 68 | Routines “ Called By” | |
| 69 | Routines “ Called” | |
| 70 | ||
| 71 | ||
| 72 | ||
| 73 | ||
| 74 | Data Dicti onary (DD) Reference s | |
| 75 | None | |
| 76 | Related Pr otocols | |
| 77 | None | |
| 78 | Related In tegration Control Re gistration s (ICRs) | |
| 79 | None | |
| 80 | Data Passi ng | |
| 81 | Input | |
| 82 | Output Re ference | |
| 83 | Both | |
| 84 | Global Re ference | |
| 85 | Local | |
| 86 | Input Attr ibute Name and Defin ition | |
| 87 | Name: | |
| 88 | Definition : | |
| 89 | Output Att ribute Nam e and Defi nition | |
| 90 | Name: | |
| 91 | Definition : | |
| 92 | Current Lo gic | |
| 93 | IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT OF PROCEDU RE CODES ; 29-OCT-91 ;;2.0;INTE GRATED BIL LING;**62, 52,106,125 ,51,137,21 0,245,228, 260,348,37 1,432,447, 488,461,51 6,522**;21 -MAR-94;Bu ild 11 ;;P er VA Dire ctive 6402 , this rou tine shoul d not be m odified. ; ;MAP TO D GCRU7 ;CHK X ; -inter ception of input x f rom Additi onal Proce dure input G:X=" " C HKXQ I $$I NPAT^IBCEF (DA(1)),'$ P($G(^IBE( 350.9,1,1) ),"^",15), X'?1A1.2N D G CHKXQ . K X . D EN^DDIOL( "Site para m does not allow ent ry of non- PTF proced ures") ;Fi leman erro r here wil l be: The previous e rror occur red when p erforming an action specified in a Pre-l ookup tran sform (7.5 node). G: '$D(^UTILI TY($J,"IB" )) CHKXQ ; S M=($A($E (X,1))-64) ,S=+$E(X,2 ) Q:'$G(^U TILITY($J, "IB",M,S)) S X="`"_+ ^(S) S M=0 I X?1A1.2 N S N=$G(^ UTILITY($J ,"IB","B", X)) S M=+N ,S=+$P(N,U ,2),P=X S S=$G(^UTIL ITY($J,"IB ",M,S)) I +S S X="`" _+S I $P(N ,U,3)="N" S X=""""_X _"""" S $P (^UTILITY( $J,"IB","B ",P),U,3)= "Y" I +M,$ D(DGPROCDT ),DGPROCDT '=$P($G(^U TILITY($J, "IB",M,1)) ,"^",2) S DGPROCDT=$ P(^(1),"^" ,2) W !!," Procedure Date: " S Y=DGPROCDT X ^DD("DD ") W Y,!CH KXQ Q ;COD MUL ;Date oriented e ntry of pr ocedureDEL ASK I $D(I BZ20),IBZ2 0,IBZ20'=$ P(^DGCR(39 9,IBIFN,0) ,U,9) S %= 2 W !,"SIN CE THE PRO CEDURE COD ING METHOD HAS BEEN CHANGED, D O YOU WANT TO DELETE ALL",!,"P ROCEDURE C ODES IN TH IS BILL" I D YN^DIC N Q:%=-1 D :%=1 DELAD D I %Y?1." ?" W !!,"I f you answ er 'Yes', all proced ure codes will be DE LETED from this bill .",! G DEL ASK K %,%Y ,DA,IBZ20, DIK ;W !," Procedure Entry:" ;C ODDT I $D( IBIFN),$D( ^DGCR(399, IBIFN,0)), $P(^(0),U, 9) S DIC(" V")=$S($P( ^(0),U,9)= 9:"I +Y(0) =80.1",$P( ^(0),U,9)= 4!($P(^(0) ,U,9)=5):" I +Y(0)=81 ",1:"") I $P($G(^DGC R(399,IBIF N,0)),"^", 5)<3 S IBZ TYPE=1 I $ P($G(^UTIL ITY($J,"IB ",1,1)),"^ ",2) S DGP ROCDT=$P(^ (1),"^",2) D ASKCOD S X=$$PRCD IV^IBCU71( IBIFN) I + X W !!,$P( X,U,2),! N Z,Z0 S Z= $G(^DGCR(3 99,IBIFN," U")),Z0=$$ FMTE^XLFDT ($P(Z,U)," 2D")_"-"_$ $FMTE^XLFD T($P(Z,U,2 ),"2D") W !,"Select PROCEDURE DATE"_$S($ TR(Z0,"-") '="":" ("_ Z0_")",1:" ")_": " R X:DTIME G: '$T!("^"[X ) CODQ D:X ["?" CODHL P S IBEX=0 D ; Get procedure date . I X =" ",$D(DG PROCDT),DG PROCDT?7N S Y=DGPROC DT D D^DIQ W " (",Y, ")" Q . I X=" ",+$P( $G(^DGCR(3 99,IBIFN," OP",0)),"^ ",4) S (DG PROCDT,Y)= $O(^DGCR(3 99,IBIFN," OP",0)) D D^DIQ W " (",Y,")" Q . S %DT=" EXP",%DT(0 )=-DT D ^% DT K %DT I Y<1 S IBE X=1 Q . I '$$OPV2^IB CU41(Y,IBI FN,1) S IB EX=1 Q . S :'$G(IBZTY PE) X=$$OP V^IBCU41(Y ,IBIFN) S DGPROCDT=Y I 'IBEX D ASKCOD,AD DCPT^IBCU7 1:$D(DGCPT ) K IBEX G CODDT ;AS KCOD N Z,Z 0,DA,IBACT ,IBQUIT,IB LNPRV ;WC J;2.0*432 N IBPOPOUT S IBPOPO UT=0 ; IB* 2.0*447 BI K DGCPT S DGCPT=0,D GCPTUP=$P( $G(^IBE(35 0.9,1,1)), "^",19),DG ADDVST=0,I BFT=$P($G( ^DGCR(399, IBIFN,0)), "^",19) I '$D(^DGCR( 399,IBIFN, "CP",0)) S ^DGCR(399 ,IBIFN,"CP ",0)=U_$$G ETSPEC^IBE FUNC(399,3 04) ; F S IBQUIT=0 D Q:IBQUI T . S IBPO POUT=0 . D DICV ; re strict cod e type to PCM . S DI C("A")=" S elect PROC EDURE: " . S DIC="^D GCR(399,"_ IBIFN_","" CP""," . S DIC(0)="A EQMNL" . S DIC("S")= "I '$D(DIV (""S""))&( $P(^(0),U, 2)=DGPROCD T)" . S DI C("DR")="1 ///^S X=DG PROCDT" . S DA(1)=IB IFN,DLAYGO =399 . W ! D ^DIC I Y<1 S IBQU IT=1 Q . S IBPROCP=+ Y . ; If w e just add ed inactiv e code - i t must be deleted. . S IBACT=0 ; Active flag . I Y ["ICD0" S IBACT=$$IC D0ACT^IBAC SV(+$P(Y,U ,2),$$BDAT E^IBACSV(I BIFN)) . I Y["ICPT" S IBACT=$$ CPTACT^IBA CSV(+$P(Y, U,2),DGPRO CDT) . S D GCPTNEW=$P (Y,"^",3) ;Was the p rocedure j ust added? . I DGCPT NEW,'IBACT D DELPROC Q . I 'IB ACT W !,*7 ,"Warning: Procedure code is i nactive on this date ",! . I DG CPTNEW,$D( ^UTILITY($ J,"IB")),$ $INPAT^IBC EF(IBIFN), Y["ICPT(" D DATA^IBC U74(Y,.IBL NPRV) . S DGADDVST=$ S(DGCPTNEW :1,$D(DGAD DVST):DGAD DVST,1:0) . N IBPRV, IBPRVO,IBP RVN . ; . ; Line lev el provide r function by form t ype. . ; C MS-1500 (F ORM TYPE=2 ) . ; REND ERING PROV IDER, REFE RRING PROV IDER, . ; and SUPERV ISING PROV IDER. . ; UB-04 (FOR M TYPE=3) . ; RENDER ING PROVID ER, REFERR ING PROVID ER, . ; OP ERATING PR OVIDER, an d OTHER OP ERATING . ; PROVIDER . . ; . ; Removed: C all to $$M AINPRV^IBC EU(IBIFN) is for cla im . ; lev el provide r defaults . . ; 1. F or new lin e level pr oviders we don't nee d . ; or w ant defaul t claim le vel provid er . ; (re quirement) . . ; 2. W e don't wa nt to defa ult claim level to . ; line le vel provid er (requir ement). . ; . K DIC( "V") ; DEM ;432 - KIL L DIC("V") because t his was fo r previous variable pointer us e. . ; . N IBPROCSV ; DEM;432 - Variabl e IBPROCSV is variab le to pres erve value of 'Y', w hich is pr ocedure co de info re turned by call to ^D IC. . S IB PROCSV=Y ; DEM;432 - Preserve value of Y for afte r calls to FileMan ( Y = proced ure code i nfo return ed by call to ^DIC). . K DR ;WCJ;IB*2. 0*432 . ; . I IBPROC SV["ICD0" S DR=".01" ,DIE=DIC,( IBPROCP,DA )=+Y D ^DI E Q:'$D(DA )!($D(Y)) K DR ; IB* 2.0*461 . I IBPROCSV ["ICPT" S DR=".01;16 ",DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($D(Y)) K DR ; IB *2.0*447 B I . ; . S DR="" . ; . ; MRD;IB *2.0*516 - Added lin e level PR OCEDURE DE SCRIPTION field, . ; asked onl y if the p rocedure i s an "NOC" . . I IBPR OCSV["ICPT ",$$NOCPRO C(IBPROCSV ) D . . S DA=$P(IBPR OCSV,"^") ; The line # on the b ill/claim. . . S DR= 51 ; Field # for PROC EDURE DESC RIPTION . . D ^DIE . . Q . ; . D EN^IBCU 7B ; DEM;4 32 - Call to line le vel provid er user in put. . S Y =IBPROCSV ; DEM;432 - Restore value of Y after ca lls to Fil eMan . K I BPROCSV . K DR ;WC J;IB*2.0*4 32 . I IBP OPOUT Q ; IB*2.0*4 47 BI . S DR="" I Y[ "ICPT" S D R="6;5//"_ $$DEFDIV(I BIFN)_";" . S DR=DR_ $S(IBFT=2: "8;9;17//N O;",1:"")_ 3,DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($E($G( Y))=U) . K DR ;WCJ ;IB*2.0*43 2 . ; . ; MRD;IB*2.0 *516 - All ow user to add an ND C and Unit s. Ask onl y if . ; c oding syst em is not ICD and th is is not a prescrip tion claim . If . ; a n NDC is e ntered, pr ompt for U nits. . I $P($G(^DGC R(399,IBIF N,0)),U,9) '=9,'$$RXL INK^IBCSC5 C(IBIFN,IB PROCP) D . . K DA . . S DA=IBP ROCP,DA(1) =IBIFN,DIE ="^DGCR(39 9,"_IBIFN_ ",""CP""," . . S DR= "53NDC NUM BER;I X="" "" S Y=""" ";54//1" . . D ^DIE . . Q . ; . I IBFT=3 D:'$$INPA T^IBCEF(IB IFN) ATTAC H ; DEM;4 32 - Promp t for Atta chment Con trol Numbe r. . ; DEM ;432 - Add Additiona l OB Minut es to DR s tring for call to DI E. . S DR= $$SPCUNIT( IBIFN,IBPR OCP) S:DR[ "15;" DR=D R_"74Addit ional OB M inutes" D ^DIE ; mil es/minutes /hours . ; . I IBFT= 2 D .. D D X^IBCU72(I BIFN,IBPRO CP) .. S X =$$ADDTNL( IBIFN,.DA) . Q:$$INP AT^IBCEF(I BIFN) ;onl y outpatie nt bills . ;add proc edures to array for download t o PCE: dgc pt(assoc c linic,cpt, 'provider^ first dx^m odifiers', cnt)="" . S DGPROC=$ G(^DGCR(39 9,IBIFN,"C P",+DA,0)) . S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15) . I 'DGCPTN EW,$P(DGPR OC,"^",7)= "" S DGCPT NEW=2 . I DGCPTUP,DG CPTNEW S D GCPT=DGCPT +1 I $P(DG PROC,"^",7 ) S DGCPT( $P(DGPROC, "^",7),+DG PROC,X,DGC PT)="" . ; add visit date to b ill . I DG ADDVST S ( X,DINUM)=D GPROCDT D VFILE1^IBC OPV1 K DIN UM,X,DGNOA DD,DGADDVS T ; Delete modifiers with only a sequenc e #, no co de S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=0 F S Z0=$O(^D GCR(399,IB IFN,"CP",Z ,"MOD",Z0) ) Q:'Z0 I $P($G(^(Z 0,0)),U,2) ="" S DA(2 )=IBIFN,DA (1)=Z,DA=Z 0,DIK="^DG CR(399,"_D A(2)_",""C P"","_DA(1 )_",""MOD" "," D ^DIK QCODQ K % DT,DGPROC, DIC,DIE,DR ,DGPROCDT, IBPROCP,DL AYGO K IBF T,DGNOADD, DGADDVST,D GCPT,DGCPT UP,IBZTYPE ,DGCPTNEW Q ;DELPROC ; Remove the select ed procedu re, becaus e of inact ive status (cancel s election) W !!,*7,"T he Procedu re code is inactive on ",$$DAT 1^IBOUTL(D GPROCDT)," ." W !,"Pl ease selec t another Procedure. " S DA(1)= IBIFN,DA=+ Y,DIK="^DG CR(399,"_I BIFN_",""C P""," D ^D IK Q ;DELA DD N Z,Z0, DA,DIK,X,Y S DA(1)=I BIFN ;Dele te referen ces to pro c on rev c odes S Z=0 F S Z=$O (^DGCR(399 ,IBIFN,"RC ",Z)) Q:'Z S Z0=$G( ^(Z,0)) I Z0'="",$P( Z0,U,15)!$ S($P(Z0,U, 10)=3:$P(Z 0,U,11),1: 0) S DIE=" ^DGCR(399, "_DA(1)_", ""RC"",",D A=Z,DR=".1 1///@;.15/ //@"_$S($P (Z0,U,8):" ",1:";.08/ ///1") D ^ DIE S DIK= "^DGCR(399 ,"_DA(1)_" ,""CP""," F DA=0:0 S DA=$O(^DG CR(399,DA( 1),"CP",DA )) Q:'DA D ^DIK S D GRVRCAL=1 Q ;DTMES ; Message if procedure date not in date ra nge Q:'$D( IBIFN) Q:' $D(^DGCR(3 99,IBIFN," U")) S DGN ODUU=^("U" ) G:X'<$P( DGNODUU,"^ ")&(X'>$P( DGNODUU,"^ ",2)) DTME SQ W *7,!! ?3,"Date m ust be wit hin STATEM ENT COVERS FROM and STATEMENT COVERS TO period." S Y=$P(DGNO DUU,"^") X ^DD("DD") W !?3,"En ter a date between " ,Y," and " S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,! K X,YDTME SQ K DGNOD UU Q ;CODH LP ;Displa y Addition al Procedu re codes N I,J,Y,IBM OD I '$O(^ DGCR(399,I BIFN,"CP", 0)) W !!?5 ,"No Codes Entered!" ,! Q W ! F I=0:0 S I =$O(^DGCR( 399,IBIFN, "CP",I)) Q :'I S Y=$ G(^(I,0)) S Z=$$PRCN M^IBCSCH1( $P(Y,"^",1 ),$P(Y,"^" ,2)) W !?5 ,$E($P(Z," ^",2),1,33 ),?40,"- " ,$P(Z,"^") D . N IBY . S IBY=$ P(Y,U,2) . S IBMOD=$ $GETMOD^IB EFUNC(IBIF N,I,1) . I IBMOD'="" S IBMOD=" /"_IBMOD W IBMOD . W ?60,"Date : " S Y=IB Y D DT^DIQ W ! ; K Z Q ;DICV I $D(IBIFN) ,$D(^DGCR( 399,IBIFN, 0)),$P(^(0 ),U,9) S D IC("V")=$S ($P(^(0),U ,9)=9:"I + Y(0)=80.1" ,$P(^(0),U ,9)=4!($P( ^(0),U,9)= 5):"I +Y(0 )=81",1:"" ) Q ;DEFDI V(IBIFN) ; Find defa ult divisi on for bil l IBIFN Q $P($G(^DG( 40.8,+$P($ G(^DGCR(39 9,IBIFN,0) ),U,22),0) ),U) ;ADDT NL(IBIFN,D A) ; N DR, IBOK,X,Y,D IR S IBOK= 1 S DR="19 T;50.09T;5 0.08T" D ^ DIE ; WCJ; IB*2.0*488 Added Ts ;I '($$FT^ IBCEF(IBIF N)'=3&($$I NPAT^IBCEF (IBIFN))) D ATTACH ; DEM;432 - Prompt fo r Attachme nt Control Number. I '($$FT^IB CEF(IBIFN) =3&($$INPA T^IBCEF(IB IFN))) D A TTACH ; D EM;432 - P rompt for Attachment Control N umber. I $ D(Y) S IBO K=0 G ADDT NLQ ;/Begi nning of I B*2.0*488 (vd) ;S DI R("B")="NO ",DIR("A") ="EDIT CMS -1500 SPEC IAL PROGRA M FIELDS a nd BOX 19? : ",DIR("A ",1)=" ",D IR(0)="YA" ;S DIR("? ",1)="Resp ond YES on ly if you need to ad d/edit dat a for chir opractic v isits," ;S DIR("?")= "EPSDT car e, or if b illing for HOSPICE a nd attendi ng is not a hospice employee." ;D ^DIR K DIR ;I Y' =1 S IBOK= 0 G ADDTNL Q ;S DR="W !,"" <<EP SDT>>"";50 .07;W !!," " <<HOSPIC E>>"";50.0 3" S DR="5 0.07T;50.0 3T" ;WCJ ;IB*2.0*48 8 added Ts ;/End of IB*2.0*488 (vd) D ^D IE W !ADDT NLQ Q IBOK ;XTRA1(Y) ; K Y Q ; SPCUNIT(IB IFN,DA) ; return fie lds for sp ecial unit s if appli cable, in DR form N IB0,IBCPT, IBDR,IBCT, IBFT,DFN S IBDR="" S IB0=$G(^D GCR(399,+$ G(IBIFN),0 )),IBCT=$P (IB0,U,27) ,IBFT=$P(I B0,U,19),D FN=$P(IB0, U,2) S IBC PT=$G(^DGC R(399,+$G( IBIFN),"CP ",+$G(DA), 0)) I IBCP T'["ICPT" G SPCUNTQ I +$$ITMUN IT^IBCRU4( +IBCPT,5,I BCT) S IBD R="15;" D SROMIN^IBC U74(IBIFN, DA) G SPCU NTQ ; minu tes I +$$I TMUNIT^IBC RU4(+IBCPT ,4,IBCT) S IBDR="21; " G SPCUNT Q ; miles I +$$ITMUN IT^IBCRU4( +IBCPT,6,I BCT) S IBD R="22//"_$ $OBSHOUR^I BCU74(DFN, $P(IBCPT,U ,2))_";" G SPCUNTQ ; hours I + IBFT=2,$P( $G(^IBE(35 3.2,+$P(IB CPT,U,10), 0)),U,2)=" ANESTHESIA " S IBDR=" 15;" ; min utesSPCUNT Q Q IBDR ; ATTACH ; D EM;432 - A ttachment control nu mber. ; As k if user wants to e nter Attac hment Cont rol Number . N DIR,X, Y,DA,DIE,D R S DIR("A ")="Enter Attachment Control N umber" S D IR(0)="Y", DIR("B")=" NO" D ^DIR Q:'Y ; Us er chose t o enter At tachment C ontrol Num ber. ; Use r enters A ttachment Control fi elds. S DA (1)=IBIFN, DA=IBPROCP S DIE="^D GCR(399,"_ DA(1)_","" CP""," S D R="71Repor t Type;72R eport Tran smission M ethod;70At tachment C ontrol Num ber" D ^DI E Q ;NOCPR OC(IBPROCS V) ; MRD;I B*2.0*516 - Function to determ ine if pro cedure is an ; "NOC" . Returns '1' if "NO C" procedu re, otherw ise '0'. ; N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX S IBNOC=0 I $G(IBPRO CSV)="" G NOCPROCQ S IBPROCIN= $P($P(IBPR OCSV,U,2), ";") I IBP ROCIN="" G NOCPROCQ ; ; If pro cedure cod e ends in '99', quit with a '1 '. ; S IBP ROCEX=$P($ G(^ICPT(IB PROCIN,0)) ,U,1) I $E (IBPROCEX, $L(IBPROCE X)-1,$L(IB PROCEX))=9 9 S IBNOC= 1 G NOCPRO CQ ; ; Pul l procedur e name, th en check t o see if i t contains one of th e ; specif ied string s. ; S IBP ROCNM=$P($ G(^ICPT(IB PROCIN,0)) ,U,2) I IB PROCNM'="" ,$$NOC(IBP ROCNM) S I BNOC=1 G N OCPROCQ ; S IBX=0 F S IBX=$O( ^ICPT(IBPR OCIN,"D",I BX)) Q:'IB X D I IB NOC=1 Q . S IBTEXT=$ G(^ICPT(IB PROCIN,"D" ,IBX,0)) . I $G(^ICP T(IBPROCIN ,"D",IBX+1 ,0))'="" S IBTEXT=IB TEXT_" "_$ G(^ICPT(IB PROCIN,"D" ,IBX+1,0)) . S IBNOC =$$NOC(IBT EXT) . Q ; NOCPROCQ ; Quit out. Q IBNOC ; NOC(IBTEXT ) ; Quit w ith '1' if IBTEXT co ntains one of the sp ecified st rings. ; S IBTEXT=$T R(IBTEXT," abcdefghij klmnopqrst uvwxyz","A BCDEFGHIJK LMNOPQRSTU VWXYZ") ; I IBTEXT[" NOT OTHERW ISE" Q 1 I IBTEXT["N OT ELSEWHE RE" Q 1 I IBTEXT["NO T LISTED" Q 1 I IBTE XT["UNLIST ED" Q 1 I IBTEXT["UN SPECIFIED" Q 1 I IBT EXT["UNCLA SSIFIED" Q 1 I IBTEX T["NON-SPE CIFIED" Q 1 I IBTEXT ["NOS " Q 1 I IBTEXT ["NOS;" Q 1 I IBTEXT ["NOS." Q 1 I IBTEXT ["NOS," Q 1 I IBTEXT ["NOS/" Q 1 I IBTEXT ["(NOS)" Q 1 I IBTEX T["NOC " Q 1 I IBTEX T["NOC;" Q 1 I IBTEX T["NOC." Q 1 I IBTEX T["NOC," Q 1 I IBTEX T["NOC/" Q 1 I IBTEX T["(NOC)" Q 1 ; ; Ch eck if las t three ch arcters ar e 'NOC' or 'NOS'. ; S IBTEXT=$ E(IBTEXT,$ L(IBTEXT)- 2,$L(IBTEX T)) I IBTE XT="NOC" Q 1 I IBTEX T="NOS" Q 1 ; Q 0 ; | |
| 94 | Modified L ogic (Chan ges are in bold) | |
| 95 | IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT OF PROCEDU RE CODES ; 29-OCT-91 ;;2.0;INTE GRATED BIL LING;**62, 52,106,125 ,51,137,21 0,245,228, 260,348,37 1,432,447, 488,461,51 6,522,577* *;21-MAR-9 4;Build 16 ;;Per VA Directive 6402, this routine s hould not be modifie d. ; ;MAP TO DGCRU7 ;CHKX ; -i nterceptio n of input x from Ad ditional P rocedure i nput G:X=" " CHKXQ I $$INPAT^I BCEF(DA(1) ),'$P($G(^ IBE(350.9, 1,1)),"^", 15),X'?1A1 .2N D G C HKXQ . K X . D EN^DD IOL("Site param does not allow entry of non-PTF pr ocedures") ;Fileman error here will be: The previo us error o ccurred wh en perform ing an act ion specif ied in a P re-lookup transform (7.5 node) . G:'$D(^U TILITY($J, "IB")) CHK XQ ;S M=($ A($E(X,1)) -64),S=+$E (X,2) Q:'$ G(^UTILITY ($J,"IB",M ,S)) S X=" `"_+^(S) S M=0 I X?1 A1.2N S N= $G(^UTILIT Y($J,"IB", "B",X)) S M=+N,S=+$P (N,U,2),P= X S S=$G(^ UTILITY($J ,"IB",M,S) ) I +S S X ="`"_+S I $P(N,U,3)= "N" S X="" ""_X_"""" S $P(^UTIL ITY($J,"IB ","B",P),U ,3)="Y" I +M,$D(DGPR OCDT),DGPR OCDT'=$P($ G(^UTILITY ($J,"IB",M ,1)),"^",2 ) S DGPROC DT=$P(^(1) ,"^",2) W !!,"Proced ure Date: " S Y=DGPR OCDT X ^DD ("DD") W Y ,!CHKXQ Q ;CODMUL ;D ate orient ed entry o f procedur eDELASK I $D(IBZ20), IBZ20,IBZ2 0'=$P(^DGC R(399,IBIF N,0),U,9) S %=2 W !, "SINCE THE PROCEDURE CODING ME THOD HAS B EEN CHANGE D, DO YOU WANT TO DE LETE ALL", !,"PROCEDU RE CODES I N THIS BIL L" I D YN ^DICN Q:%= -1 D:%=1 D ELADD I %Y ?1."?" W ! !,"If you answer 'Ye s', all pr ocedure co des will b e DELETED from this bill.",! G DELASK K %,%Y,DA,IB Z20,DIK ;W !,"Proced ure Entry: " ;CODDT I $D(IBIFN) ,$D(^DGCR( 399,IBIFN, 0)),$P(^(0 ),U,9) S D IC("V")=$S ($P(^(0),U ,9)=9:"I + Y(0)=80.1" ,$P(^(0),U ,9)=4!($P( ^(0),U,9)= 5):"I +Y(0 )=81",1:"" ) I $P($G( ^DGCR(399, IBIFN,0)), "^",5)<3 S IBZTYPE=1 I $P($G(^ UTILITY($J ,"IB",1,1) ),"^",2) S DGPROCDT= $P(^(1),"^ ",2) D ASK COD S X=$$ PRCDIV^IBC U71(IBIFN) I +X W !! ,$P(X,U,2) ,! N Z,Z0 S Z=$G(^DG CR(399,IBI FN,"U")),Z 0=$$FMTE^X LFDT($P(Z, U),"2D")_" -"_$$FMTE^ XLFDT($P(Z ,U,2),"2D" ) W !,"Sel ect PROCED URE DATE"_ $S($TR(Z0, "-")'="":" ("_Z0_")" ,1:"")_": " R X:DTIM E G:'$T!(" ^"[X) CODQ D:X["?" C ODHLP S IB EX=0 D ; Get proced ure date . I X=" ",$ D(DGPROCDT ),DGPROCDT ?7N S Y=DG PROCDT D D ^DIQ W " ( ",Y,")" Q . I X=" ", +$P($G(^DG CR(399,IBI FN,"OP",0) ),"^",4) S (DGPROCDT ,Y)=$O(^DG CR(399,IBI FN,"OP",0) ) D D^DIQ W " (",Y," )" Q . S % DT="EXP",% DT(0)=-DT D ^%DT K % DT I Y<1 S IBEX=1 Q . I '$$OPV 2^IBCU41(Y ,IBIFN,1) S IBEX=1 Q . S:'$G(I BZTYPE) X= $$OPV^IBCU 41(Y,IBIFN ) S DGPROC DT=Y I 'IB EX D ASKCO D,ADDCPT^I BCU71:$D(D GCPT) K IB EX G CODDT ;ASKCOD N Z,Z0,DA,I BACT,IBQUI T,IBLNPRV ;WCJ;2.0* 432 N IBPO POUT S IB POPOUT=0 ; IB*2.0*44 7 BI K DGC PT S DGCPT =0,DGCPTUP =$P($G(^IB E(350.9,1, 1)),"^",19 ),DGADDVST =0,IBFT=$P ($G(^DGCR( 399,IBIFN, 0)),"^",19 ) I '$D(^D GCR(399,IB IFN,"CP",0 )) S ^DGCR (399,IBIFN ,"CP",0)=U _$$GETSPEC ^IBEFUNC(3 99,304) ; F S IBQUI T=0 D Q:I BQUIT . S IBPOPOUT=0 . D DICV ; restrict code type to PCM . S DIC("A") =" Select PROCEDURE: " . S DIC ="^DGCR(39 9,"_IBIFN_ ",""CP""," . S DIC(0 )="AEQMNL" . S DIC(" S")="I '$D (DIV(""S"" ))&($P(^(0 ),U,2)=DGP ROCDT)" . S DIC("DR" )="1///^S X=DGPROCDT " . S DA(1 )=IBIFN,DL AYGO=399 . W ! D ^DI C I Y<1 S IBQUIT=1 Q . S IBPRO CP=+Y . ; If we just added ina ctive code - it must be delete d. . S IBA CT=0 ; Act ive flag . I Y["ICD0 " S IBACT= $$ICD0ACT^ IBACSV(+$P (Y,U,2),$$ BDATE^IBAC SV(IBIFN)) . I Y["IC PT" S IBAC T=$$CPTACT ^IBACSV(+$ P(Y,U,2),D GPROCDT) . S DGCPTNE W=$P(Y,"^" ,3) ;Was t he procedu re just ad ded? . I D GCPTNEW,'I BACT D DEL PROC Q . I 'IBACT W !,*7,"Warn ing: Proce dure code is inactiv e on this date",! . I DGCPTNEW ,$D(^UTILI TY($J,"IB" )),$$INPAT ^IBCEF(IBI FN),Y["ICP T(" D DATA ^IBCU74(Y, .IBLNPRV) . S DGADDV ST=$S(DGCP TNEW:1,$D( DGADDVST): DGADDVST,1 :0) . N IB PRV,IBPRVO ,IBPRVN . ; . ; Line level pro vider func tion by fo rm type. . ; CMS-150 0 (FORM TY PE=2) . ; RENDERING PROVIDER, REFERRING PROVIDER, . ; and SU PERVISING PROVIDER. . ; UB-04 (FORM TYPE =3) . ; RE NDERING PR OVIDER, RE FERRING PR OVIDER, . ; OPERATIN G PROVIDER , and OTHE R OPERATIN G . ; PROV IDER. . ; . ; Remove d: Call to $$MAINPRV ^IBCEU(IBI FN) is for claim . ; level pro vider defa ults. . ; 1. For new line leve l provider s we don't need . ; or want de fault clai m level pr ovider . ; (requirem ent). . ; 2. We don' t want to default cl aim level to . ; lin e level pr ovider (re quirement) . . ; . K DIC("V") ; DEM;432 - KILL DIC( "V") becau se this wa s for prev ious varia ble pointe r use. . ; . N IBPRO CSV ; DEM ;432 - Var iable IBPR OCSV is va riable to preserve v alue of 'Y ', which i s procedur e code inf o returned by call t o ^DIC. . S IBPROCSV =Y ; DEM; 432 - Pres erve value of Y for after call s to FileM an (Y = pr ocedure co de info re turned by call to ^D IC). . K D R ;WCJ;I B*2.0*432 . ; . I IB PROCSV["IC D0" S DR=" .01",DIE=D IC,(IBPROC P,DA)=+Y D ^DIE Q:'$ D(DA)!($D( Y)) K DR ; IB*2.0*46 1 . I IBPR OCSV["ICPT " S DR=".0 1;16",DIE= DIC,(IBPRO CP,DA)=+Y D ^DIE Q:' $D(DA)!($D (Y)) K DR ; IB*2.0*4 47 BI . ; . S DR="" . ; . ; MR D;IB*2.0*5 16 - Added line leve l PROCEDUR E DESCRIPT ION field, . ; asked only if t he procedu re is an " NOC". . I IBPROCSV[" ICPT",$$NO CPROC(IBPR OCSV) D . . S DA=$P( IBPROCSV," ^") ; The line# on t he bill/cl aim. . . S DR=51 ; F ield# for PROCEDURE DESCRIPTIO N . . D ^D IE . . Q . ; . D EN^ IBCU7B ; D EM;432 - C all to lin e level pr ovider use r input. . S Y=IBPRO CSV ; DEM ;432 - Res tore value of Y afte r calls to FileMan . K IBPROCS V . K DR ;WCJ;IB*2 .0*432 . I IBPOPOUT Q ; IB*2 .0*447 BI . S DR="" I Y["ICPT" S DR="6;5 //"_$$DEFD IV(IBIFN)_ ";" . S DR =DR_$S(IBF T=2:"8;9;1 7//NO;",1: "")_3,DIE= DIC,(IBPRO CP,DA)=+Y D ^DIE Q:' $D(DA)!($E ($G(Y))=U) . K DR ;WCJ;IB*2. 0*432 . ; . ; MRD;IB *2.0*516 - Allow use r to add a n NDC and Units. Ask only if . ; coding system is not ICD an d this is not a pres cription c laim. If . ; an NDC is entered , prompt f or Units. . I $P($G( ^DGCR(399, IBIFN,0)), U,9)'=9,'$ $RXLINK^IB CSC5C(IBIF N,IBPROCP) D . . K D A . . S DA =IBPROCP,D A(1)=IBIFN ,DIE="^DGC R(399,"_IB IFN_",""CP ""," . . ; vd/Beginn ing IB*2*5 77 - Added the promp t for Unit /Basis of Measuremen t. . . ; S DR="53NDC NUMBER;I X="""" S Y ="""";54// 1" . . S D R="53NDC N UMBER;I X= """" S Y=" """;52//UN ;54QUANTIT Y//1" ;Pr ompt for N DC, UN & a mt. . . ; vd/Ending IB*2*577 . . D ^DIE . . Q . ; . I IBFT=3 D:'$$INPA T^IBCEF(IB IFN) ATTAC H ; DEM;4 32 - Promp t for Atta chment Con trol Numbe r. . ; DEM ;432 - Add Additiona l OB Minut es to DR s tring for call to DI E. . S DR= $$SPCUNIT( IBIFN,IBPR OCP) S:DR[ "15;" DR=D R_"74Addit ional OB M inutes" D ^DIE ; mil es/minutes /hours . ; . I IBFT= 2 D .. D D X^IBCU72(I BIFN,IBPRO CP) .. S X =$$ADDTNL( IBIFN,.DA) . Q:$$INP AT^IBCEF(I BIFN) ;onl y outpatie nt bills . ;add proc edures to array for download t o PCE: dgc pt(assoc c linic,cpt, 'provider^ first dx^m odifiers', cnt)="" . S DGPROC=$ G(^DGCR(39 9,IBIFN,"C P",+DA,0)) . S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15) . I 'DGCPTN EW,$P(DGPR OC,"^",7)= "" S DGCPT NEW=2 . I DGCPTUP,DG CPTNEW S D GCPT=DGCPT +1 I $P(DG PROC,"^",7 ) S DGCPT( $P(DGPROC, "^",7),+DG PROC,X,DGC PT)="" . ; add visit date to b ill . I DG ADDVST S ( X,DINUM)=D GPROCDT D VFILE1^IBC OPV1 K DIN UM,X,DGNOA DD,DGADDVS T ; Delete modifiers with only a sequenc e #, no co de S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=0 F S Z0=$O(^D GCR(399,IB IFN,"CP",Z ,"MOD",Z0) ) Q:'Z0 I $P($G(^(Z 0,0)),U,2) ="" S DA(2 )=IBIFN,DA (1)=Z,DA=Z 0,DIK="^DG CR(399,"_D A(2)_",""C P"","_DA(1 )_",""MOD" "," D ^DIK QCODQ K % DT,DGPROC, DIC,DIE,DR ,DGPROCDT, IBPROCP,DL AYGO K IBF T,DGNOADD, DGADDVST,D GCPT,DGCPT UP,IBZTYPE ,DGCPTNEW Q ;DELPROC ; Remove the select ed procedu re, becaus e of inact ive status (cancel s election) W !!,*7,"T he Procedu re code is inactive on ",$$DAT 1^IBOUTL(D GPROCDT)," ." W !,"Pl ease selec t another Procedure. " S DA(1)= IBIFN,DA=+ Y,DIK="^DG CR(399,"_I BIFN_",""C P""," D ^D IK Q ;DELA DD N Z,Z0, DA,DIK,X,Y S DA(1)=I BIFN ;Dele te referen ces to pro c on rev c odes S Z=0 F S Z=$O (^DGCR(399 ,IBIFN,"RC ",Z)) Q:'Z S Z0=$G( ^(Z,0)) I Z0'="",$P( Z0,U,15)!$ S($P(Z0,U, 10)=3:$P(Z 0,U,11),1: 0) S DIE=" ^DGCR(399, "_DA(1)_", ""RC"",",D A=Z,DR=".1 1///@;.15/ //@"_$S($P (Z0,U,8):" ",1:";.08/ ///1") D ^ DIE S DIK= "^DGCR(399 ,"_DA(1)_" ,""CP""," F DA=0:0 S DA=$O(^DG CR(399,DA( 1),"CP",DA )) Q:'DA D ^DIK S D GRVRCAL=1 Q ;DTMES ; Message if procedure date not in date ra nge Q:'$D( IBIFN) Q:' $D(^DGCR(3 99,IBIFN," U")) S DGN ODUU=^("U" ) G:X'<$P( DGNODUU,"^ ")&(X'>$P( DGNODUU,"^ ",2)) DTME SQ W *7,!! ?3,"Date m ust be wit hin STATEM ENT COVERS FROM and STATEMENT COVERS TO period." S Y=$P(DGNO DUU,"^") X ^DD("DD") W !?3,"En ter a date between " ,Y," and " S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,! K X,YDTME SQ K DGNOD UU Q ;CODH LP ;Displa y Addition al Procedu re codes N I,J,Y,IBM OD I '$O(^ DGCR(399,I BIFN,"CP", 0)) W !!?5 ,"No Codes Entered!" ,! Q W ! F I=0:0 S I =$O(^DGCR( 399,IBIFN, "CP",I)) Q :'I S Y=$ G(^(I,0)) S Z=$$PRCN M^IBCSCH1( $P(Y,"^",1 ),$P(Y,"^" ,2)) W !?5 ,$E($P(Z," ^",2),1,33 ),?40,"- " ,$P(Z,"^") D . N IBY . S IBY=$ P(Y,U,2) . S IBMOD=$ $GETMOD^IB EFUNC(IBIF N,I,1) . I IBMOD'="" S IBMOD=" /"_IBMOD W IBMOD . W ?60,"Date : " S Y=IB Y D DT^DIQ W ! ; K Z Q ;DICV I $D(IBIFN) ,$D(^DGCR( 399,IBIFN, 0)),$P(^(0 ),U,9) S D IC("V")=$S ($P(^(0),U ,9)=9:"I + Y(0)=80.1" ,$P(^(0),U ,9)=4!($P( ^(0),U,9)= 5):"I +Y(0 )=81",1:"" ) Q ;DEFDI V(IBIFN) ; Find defa ult divisi on for bil l IBIFN Q $P($G(^DG( 40.8,+$P($ G(^DGCR(39 9,IBIFN,0) ),U,22),0) ),U) ;ADDT NL(IBIFN,D A) ; N DR, IBOK,X,Y,D IR S IBOK= 1 S DR="19 T;50.09T;5 0.08T" D ^ DIE ; WCJ; IB*2.0*488 Added Ts ;I '($$FT^ IBCEF(IBIF N)'=3&($$I NPAT^IBCEF (IBIFN))) D ATTACH ; DEM;432 - Prompt fo r Attachme nt Control Number. I '($$FT^IB CEF(IBIFN) =3&($$INPA T^IBCEF(IB IFN))) D A TTACH ; D EM;432 - P rompt for Attachment Control N umber. I $ D(Y) S IBO K=0 G ADDT NLQ ;/Begi nning of I B*2.0*488 (vd) ;S DI R("B")="NO ",DIR("A") ="EDIT CMS -1500 SPEC IAL PROGRA M FIELDS a nd BOX 19? : ",DIR("A ",1)=" ",D IR(0)="YA" ;S DIR("? ",1)="Resp ond YES on ly if you need to ad d/edit dat a for chir opractic v isits," ;S DIR("?")= "EPSDT car e, or if b illing for HOSPICE a nd attendi ng is not a hospice employee." ;D ^DIR K DIR ;I Y' =1 S IBOK= 0 G ADDTNL Q ;S DR="W !,"" <<EP SDT>>"";50 .07;W !!," " <<HOSPIC E>>"";50.0 3" S DR="5 0.07T;50.0 3T" ;WCJ ;IB*2.0*48 8 added Ts ;/End of IB*2.0*488 (vd) D ^D IE W !ADDT NLQ Q IBOK ;XTRA1(Y) ; K Y Q ; SPCUNIT(IB IFN,DA) ; return fie lds for sp ecial unit s if appli cable, in DR form N IB0,IBCPT, IBDR,IBCT, IBFT,DFN S IBDR="" S IB0=$G(^D GCR(399,+$ G(IBIFN),0 )),IBCT=$P (IB0,U,27) ,IBFT=$P(I B0,U,19),D FN=$P(IB0, U,2) S IBC PT=$G(^DGC R(399,+$G( IBIFN),"CP ",+$G(DA), 0)) I IBCP T'["ICPT" G SPCUNTQ I +$$ITMUN IT^IBCRU4( +IBCPT,5,I BCT) S IBD R="15;" D SROMIN^IBC U74(IBIFN, DA) G SPCU NTQ ; minu tes I +$$I TMUNIT^IBC RU4(+IBCPT ,4,IBCT) S IBDR="21; " G SPCUNT Q ; miles I +$$ITMUN IT^IBCRU4( +IBCPT,6,I BCT) S IBD R="22//"_$ $OBSHOUR^I BCU74(DFN, $P(IBCPT,U ,2))_";" G SPCUNTQ ; hours I + IBFT=2,$P( $G(^IBE(35 3.2,+$P(IB CPT,U,10), 0)),U,2)=" ANESTHESIA " S IBDR=" 15;" ; min utesSPCUNT Q Q IBDR ; ATTACH ; D EM;432 - A ttachment control nu mber. ; As k if user wants to e nter Attac hment Cont rol Number . N DIR,X, Y,DA,DIE,D R S DIR("A ")="Enter Attachment Control N umber" S D IR(0)="Y", DIR("B")=" NO" D ^DIR Q:'Y ; Us er chose t o enter At tachment C ontrol Num ber. ; Use r enters A ttachment Control fi elds. S DA (1)=IBIFN, DA=IBPROCP S DIE="^D GCR(399,"_ DA(1)_","" CP""," S D R="71Repor t Type;72R eport Tran smission M ethod;70At tachment C ontrol Num ber" D ^DI E Q ;NOCPR OC(IBPROCS V) ; MRD;I B*2.0*516 - Function to determ ine if pro cedure is an ; "NOC" . Returns '1' if "NO C" procedu re, otherw ise '0'. ; N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX S IBNOC=0 I $G(IBPRO CSV)="" G NOCPROCQ S IBPROCIN= $P($P(IBPR OCSV,U,2), ";") I IBP ROCIN="" G NOCPROCQ ; ; If pro cedure cod e ends in '99', quit with a '1 '. ; S IBP ROCEX=$P($ G(^ICPT(IB PROCIN,0)) ,U,1) I $E (IBPROCEX, $L(IBPROCE X)-1,$L(IB PROCEX))=9 9 S IBNOC= 1 G NOCPRO CQ ; ; Pul l procedur e name, th en check t o see if i t contains one of th e ; specif ied string s. ; S IBP ROCNM=$P($ G(^ICPT(IB PROCIN,0)) ,U,2) I IB PROCNM'="" ,$$NOC(IBP ROCNM) S I BNOC=1 G N OCPROCQ ; S IBX=0 F S IBX=$O( ^ICPT(IBPR OCIN,"D",I BX)) Q:'IB X D I IB NOC=1 Q . S IBTEXT=$ G(^ICPT(IB PROCIN,"D" ,IBX,0)) . I $G(^ICP T(IBPROCIN ,"D",IBX+1 ,0))'="" S IBTEXT=IB TEXT_" "_$ G(^ICPT(IB PROCIN,"D" ,IBX+1,0)) . S IBNOC =$$NOC(IBT EXT) . Q ; NOCPROCQ ; Quit out. Q IBNOC ; NOC(IBTEXT ) ; Quit w ith '1' if IBTEXT co ntains one of the sp ecified st rings. ; S IBTEXT=$T R(IBTEXT," abcdefghij klmnopqrst uvwxyz","A BCDEFGHIJK LMNOPQRSTU VWXYZ") ; I IBTEXT[" NOT OTHERW ISE" Q 1 I IBTEXT["N OT ELSEWHE RE" Q 1 I IBTEXT["NO T LISTED" Q 1 I IBTE XT["UNLIST ED" Q 1 I IBTEXT["UN SPECIFIED" Q 1 I IBT EXT["UNCLA SSIFIED" Q 1 I IBTEX T["NON-SPE CIFIED" Q 1 I IBTEXT ["NOS " Q 1 I IBTEXT ["NOS;" Q 1 I IBTEXT ["NOS." Q 1 I IBTEXT ["NOS," Q 1 I IBTEXT ["NOS/" Q 1 I IBTEXT ["(NOS)" Q 1 I IBTEX T["NOC " Q 1 I IBTEX T["NOC;" Q 1 I IBTEX T["NOC." Q 1 I IBTEX T["NOC," Q 1 I IBTEX T["NOC/" Q 1 I IBTEX T["(NOC)" Q 1 ; ; Ch eck if las t three ch arcters ar e 'NOC' or 'NOS'. ; S IBTEXT=$ E(IBTEXT,$ L(IBTEXT)- 2,$L(IBTEX T)) I IBTE XT="NOC" Q 1 I IBTEX T="NOS" Q 1 ; Q 0 | |
| 96 | ||
| 97 | ADD two ne w triggers to the ND C field [# 399.0304, 53] that r equire the UNITS/BAS IS OF MEAS UREMENT fi eld [#399. 0304, 52] and the UN ITS field [#399.0304 , 54] to b e populate d if there is an NDC number pr esent. | |
| 98 | ||
| 99 | 399.0304,5 3 NDC 1;7 FREE TEXT | |
| 100 | ||
| 101 | INPUT TRANSFORM: K:$L(X)> 13!($L(X)< 13)!'(X?5N 1"-"4N1"-" 2N) X | |
| 102 | LAST E DITED: APR 13, 2017 | |
| 103 | HELP-P ROMPT: Enter a National D rug Code i n a 5-4-2 format | |
| 104 | (nnnnn-n nnn-nn) if required on a | |
| 105 | non-pres cription c laim. | |
| 106 | DESCRI PTION: Enter a National D rug Code i n a 5-4-2 format | |
| 107 | (nnnnn-n nnn-nn) if required on a | |
| 108 | non-pres cription c laim. | |
| 109 | ||
| 110 | TECHNI CAL DESCR: Enter a National D rug Code i n a 5-4-2 format | |
| 111 | (nnnnn-n nnn-nn) if required on a | |
| 112 | non-pres cription c laim. | |
| 113 | ||
| 114 | CROSS- REFERENCE: ^^TRIGGE R^399.0304 ^52 | |
| 115 | 1)= Q | |
| 116 | 2)= X ^D D(399.0304 ,53,1,1,2. 3) I X S X =DIV S Y( | |
| 117 | 1)=$S($D (^DGCR(399 ,D0,"CP",D 1,1)):^(1) ,1:""),Y( | |
| 118 | 1)=$S($D (^DGCR(399 ,D0,"CP",D 1,2)):^(2) ,1:"") S | |
| 119 | X=$P(Y(1 ),U,1),X=X S DIU=X K Y S X="" X ^DD(399 | |
| 120 | .0304,53 ,1,1,2.4) | |
| 121 | ||
| 122 | 2.3)= K DIV S DIV= X,D0=DA(1) ,DIV(0)=D0 ,D1=DA,DI | |
| 123 | V(1)=D1 S Y(0)=X S Y(1)=$S($ D(^DGCR(39 9,D0,"CP" | |
| 124 | ,D1,1)): ^(1),1:"") S X=$P(Y( 1),U,7)="" | |
| 125 | ||
| 126 | 2.4)= S DIH=$G(^DG CR(399,DIV (0),"CP",D IV(1),2)) | |
| 127 | ,DIV=X S $P(^(2),U ,1)=DIV,DI H=399.0304 ,DIG=52 D | |
| 128 | ^DICR | |
| 129 | ||
| 130 | CREATE V ALUE)= NO EFFECT | |
| 131 | DELETE C ONDITION)= NDC="" | |
| 132 | DELETE V ALUE)= @ | |
| 133 | FIELD)= UNITS/BASI S OF MEASU REMENT | |
| 134 | When the NDC Code is removed , the UNIT S/BASIS | |
| 135 | OF MEASU REMENT fie ld should be removed as well. | |
| 136 | ||
| 137 | ||
| 138 | ||
| 139 | CROSS- REFERENCE: ^^TRIGGE R^399.0304 ^54 | |
| 140 | 1)= Q | |
| 141 | 2)= X ^D D(399.0304 ,53,1,2,2. 3) I X S X =DIV S Y( | |
| 142 | 1)=$S($D (^DGCR(399 ,D0,"CP",D 1,1)):^(1) ,1:"") S | |
| 143 | X=$P(Y(1 ),U,8),X=X S DIU=X K Y S X="" S DIH=$G( | |
| 144 | ^DGCR(39 9,DIV(0)," CP",DIV(1) ,1)),DIV=X S $P(^(1 | |
| 145 | ),U,8)=D IV,DIH=399 .0304,DIG= 54 D ^DICR | |
| 146 | ||
| 147 | 2.3)= K DIV S DIV= X,D0=DA(1) ,DIV(0)=D0 ,D1=DA,DI | |
| 148 | V(1)=D1 S Y(0)=X S Y(1)=$S($ D(^DGCR(39 9,D0,"CP" | |
| 149 | ,D1,1)): ^(1),1:"") S X=$P(Y( 1),U,7)="" | |
| 150 | ||
| 151 | CREATE V ALUE)= NO EFFECT | |
| 152 | DELETE C ONDITION)= NDC="" | |
| 153 | DELETE V ALUE)= @ | |
| 154 | FIELD)= UNITS | |
| 155 | When the NDC Code is removed , the UNIT S field | |
| 156 | should b e removed as well. | |
| 157 | ||
| 158 | ADD a new validation code to c heck claim lines and confirm t hat if the NDC field is popula ted, then the UNITS and UNITS/ BASIS OF M EASUREMENT fields ar e populate d as well. | |
| 159 | Routines | |
| 160 | Activities | |
| 161 | Routine Na me | |
| 162 | IBCBB1 | |
| 163 | Enhancemen t Category | |
| 164 | New | |
| 165 | Modify | |
| 166 | Delete | |
| 167 | No Change | |
| 168 | RTM | |
| 169 | ||
| 170 | Related Op tions | |
| 171 | None | |
| 172 | Related Ro utines | |
| 173 | Routines “ Called By” | |
| 174 | Routines “ Called” | |
| 175 | ||
| 176 | ||
| 177 | ||
| 178 | ||
| 179 | Data Dicti onary (DD) Reference s | |
| 180 | None | |
| 181 | Related Pr otocols | |
| 182 | None | |
| 183 | Related In tegration Control Re gistration s (ICRs) | |
| 184 | None | |
| 185 | Data Passi ng | |
| 186 | Input | |
| 187 | Output Re ference | |
| 188 | Both | |
| 189 | Global Re ference | |
| 190 | Local | |
| 191 | Input Attr ibute Name and Defin ition | |
| 192 | Name: | |
| 193 | Definition : | |
| 194 | Output Att ribute Nam e and Defi nition | |
| 195 | Name: | |
| 196 | Definition : | |
| 197 | Current Lo gic | |
| 198 | IBCBB1 ;AL B/AAS - CO NTINUATION OF EDIT C HECK ROUTI NE ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 27,52,80,9 3,106,51,1 51,148,153 ,137,232,2 80,155,320 ,343,349,3 63,371,395 ,384,432,4 47,488,554 **;21-MAR- 94;Build 1 6 ;Per VA Directive 6402, this routine s hould not be modifie d. ; ; *** Begin IB* 2.0*488 VD (Issue 46 RBN) N I S I="" S X =+$G(^DGCR (399,IBIFN ,"MP")) I 'X,$$MCRWN R^IBEFUNC( +$$CURR^IB CEF2(IBIFN )) S X=+$$ CURR^IBCEF 2(IBIFN) I X,+$G(^DI C(36,X,3)) S I=$P(^( 3),U,$S($$ FT^IBCEF(I BIFN)=2:2, 1:4)) S I= $$UP^XLFST R(I) I (I' =""&(I["PR NT")&($G(I BER)'["IB4 88")) D . S IBER=$G (IBER)_"IB 488;" ; ; Cause an e rror if FO RCED TO PR INT TO CLE ARINGHOUSE I $P($G(^ DGCR(399,I BIFN,"TX") ),U,8)=2 D . S IBER= $G(IBER)_" IB489;" ; ; Cause a fatal erro r if the c laim has n o procedur es & is NO T a UB-04 Inpatient claim. I + $O(^DGCR(3 99,IBIFN," CP",0))=0 D .I $$INP AT^IBCEF(I BIFN,1),$$ INSPRF^IBC EF(IBIFN) Q ; inpa tient UB-0 4 check .I '$$INPAT^ IBCEF(IBIF N,1),$$INS PRF^IBCEF( IBIFN) D Q ; O utpatient Institutio nal Claim. ..I IBER[ "IB352" Q ..S IBER=I BER_"IB352 ;" .; .; P rofessiona l claim .I IBER["IB3 53" Q .S I BER=IBER_" IB353;" .Q ; *** End IB*2.0*48 8 -- VD ; ;MAP TO DG CRBB1 ;% ; Bill Statu s N Z,Z0,Z 1,IBFT I $ S(+IBST=0: 1,1:"^1^2^ 3^4^7^"'[( U_IBST_U)) S IBER=IB ER_"IB045; " ; ;State ment Cover s From I I BFDT="" S IBER=IBER_ "IB061;" I IBFDT]"", IBFDT'?7N& (IBFDT'?7N 1".".N) S IBER=IBER_ "IB061;" I IBFDT>IBT DT S IBER= IBER_"IB06 1;" ; from must be o n or befor e the to d ate S IBF FY=$$FY^IB OUTL(IBFDT ) ; if inp at - from date must not be pri or to admi t date. I $$INPAT^IB CEF(IBIFN, 1),(IBFDT< ($P($G(^DG PT(+$P(IBN D0,U,8),0) ),U,2)\1)) S IBER=IB ER_"IB061; " ; ;State ment Cover s To I IBT DT="" S IB ER=IBER_"I B062;" I I BTDT]"",IB TDT'?7N&(I BTDT'?7N1" .".N) S IB ER=IBER_"I B062;" I I BTDT>DT!(I BTDT<IBFDT ) S IBER=I BER_"IB062 ;" ; to d ate must n ot be >tha n today's date S IBT FY=$$FY^IB OUTL(IBTDT ) ; ;Total Charges ; IB*2.0*44 7/TAZ Remo ved this e rror so th at zero do llar reven ue codes c an process on the 83 7 ;I +IBTC '>0!(+IBTC '=IBTC) S IBER=IBER_ "IB064;" ; ;Billable charges f or seconda ry claim I $$MCRONBI L^IBEFUNC( IBIFN)&(($ P(IBNDU1,U ,1)-$P(IBN DU1,U,2))' >0) S IBER =IBER_"IB0 94;" ;Fisc al Year 1 S IBFFY=$$ FY^IBOUTL( IBFDT) ; ; Check prov ider link for curren t user, en terer, rev iewer and Authorizor I '$D(^VA (200,DUZ,0 )) S IBER= IBER_"IB04 8;" I IBEU ]"",'$D(^V A(200,IBEU ,0)) S IBE R=IBER_"IB 048;" I IB RU]"",'$D( ^VA(200,IB RU,0)) S I BER=IBER_" IB060;" I IBAU]"",'$ D(^VA(200, IBAU,0)) S IBER=IBER _"IB041;" ; I IBER=" ",+$$STA^P RCAFN(IBIF N)=104 S I BER=IBER_" IB040;" ; If ins bil l, must ha ve valid C OB sequenc e I $P(IBN D0,U,11)=" i",$S($P(I BND0,U,21) ="":1,1:"P ST"'[$P(IB ND0,U,21)) S IBER=IB ER_"IB324; " ; ; Chec k for vali d sec prov ider id fo r current ins S Z=0 F S Z=$O( ^DGCR(399, IBIFN,"PRV ",Z)) Q:'Z S Z0=$G( ^(Z,0)),Z1 =+$$COBN^I BCEF(IBIFN ) I $P(Z0, U,4+Z1)'=" ",$P(Z0,U, 11+Z1)'="" D . I '$$ SECIDCK^IB CEF74(IBIF N,Z1,$P(Z0 ,U,11+Z1), Z) D WARN^ IBCBB11("P rov second ary id typ e for the "_$P("PRIM ARY^SECOND ARY^TERTIA RY",U,Z1)_ " "_$$EXTE RNAL^DILFD (399.0222, .01,,+Z0)_ " is inval id/won't t ransmit") ; Check NP Is D NPICH K^IBCBB11 ; ; Check multiple r x NPIs D R XNPI^IBCBB 11(IBIFN) ; ; Check taxonomies D TAXCHK^ IBCBB11 ; ; Check fo r Physicia n Name K I BXDATA D F ^IBCEF("N- ATT/REND P HYSICIAN N AME",,,IBI FN) ; IB*2 .0*432 - C MS1500 no longer nee ds a claim level ren dering S I BFT=$$FT^I BCEF(IBIFN ) I IBFT'= 2,$P($G(IB XDATA),U)= "" S IBER= IBER_"IB30 3;" ; N FU NCTION,IBI NS ; IB*2. 0*432 - CM S1500 no l onger need s a claim level rend ering ;S F UNCTION=$S ($$FT^IBCE F(IBIFN)=3 :4,1:3) S FUNCTION=$ S(IBFT=3:4 ,1:3) I IB FT'=2,IBER '["IB303;" D . F IBI NS=1:1:3 D .. S Z=$$ GETTYP^IBC EP2A(IBIFN ,IBINS) .. I Z,$P(Z, U,2) D ; Rendering/ attending prov secon dary id re quired ... N IBID,IB OK,Q0 ... D PROVINF^ IBCEF74(IB IFN,IBINS, .IBID,1,"C ") ; check all as th ough they were curre nt ... S I BOK=0 ... S Q0=0 F S Q0=$O(IB ID(1,FUNCT ION,Q0)) Q :'Q0 I $P (IBID(1,FU NCTION,Q0) ,U,9)=+Z S IBOK=1 Q ... I 'IBO K S IBER=I BER_$S(IBI NS=1:"IB23 6;",IBINS= 2:"IB237;" ,IBINS=3:" IB238;",1: "") ; ; Pa tch 432 en h5:The IB system sha ll no long er prevent users fro m authoriz ing(fatal error mess age)a clai m because the system cannot fi nd the pro vidersSSNo rEIN ; D P RIIDCHK^IB CBB11 ; N IBM,IBM1 S IBM=$G(^D GCR(399,IB IFN,"M")) S IBM1=$G( ^DGCR(399, IBIFN,"M1" )) I $P(IB M,U),$P($G (^DIC(36,$ P(IBM,U),4 )),U,6),$P (IBM1,U,2) ="" S IBER =IBER_"IB2 44;" I $P( IBM,U,2),$ P($G(^DIC( 36,$P(IBM, U,2),4)),U ,6),$P(IBM 1,U,3)="" S IBER=IBE R_"IB245;" I $P(IBM, U,3),$P($G (^DIC(36,$ P(IBM,U,3) ,4)),U,6), $P(IBM1,U, 4)="" S IB ER=IBER_"I B246;" ; ; If outsid e facility , check fo r ID and q ualifier i n 355.93 ; 5/15/06 - esg - har d error IB 243 turned into warn ing messag e instead S Z=$P($G( ^DGCR(399, IBIFN,"U2" )),U,10) I Z D . I $ P($G(^IBA( 355.93,Z,0 )),U,9)="" !($P($G(^I BA(355.93, Z,0)),U,13 )="") D .. N Z1,Z2 . . S Z1="Mi ssing Lab or Facilit y Primary ID for non -VA facili ty, " .. S Z2=$$EXTE RNAL^DILFD (399,232,, Z) .. I $L (Z2)'>19 D WARN^IBCB B11(Z1_Z2) Q .. D WA RN^IBCBB11 (Z1),WARN^ IBCBB11(" "_Z2) .. Q . Q ; ; M ust be one and only one divisi on on bill S IBZ=$$M ULTDIV^IBC BB11(IBIFN ,IBND0) ; I IBZ S IB ER=IBER_$S (IBZ=1:"IB 095;",IBZ= 2:"IB104;" ,1:"IB105; ") ; Allow multi-div isional fo r OP instu tional cla ims I IBZ, $$INPAT^IB CEF(IBIFN) !'($$INSPR F^IBCEF(IB IFN)) S IB ER=IBER_$S (IBZ=1:"IB 095;",IBZ= 2:"IB104;" ,1:"IB105; ") ; Still need erro r msg on O P Institut ional if N o Default division I IBZ=3,'$$ INPAT^IBCE F(IBIFN),$ $INSPRF^IB CEF(IBIFN) S IBER=IB ER_"IB105; " ; Divisi on address must be d efined in institutio n file I $ P(IBND0,U, 22) D . N Z,Z0,Z1 . S Z0=$G(^D IC(4,+$P($ G(^DG(40.8 ,+$P(IBND0 ,U,22),0)) ,U,7),0)) . S Z1=$G( ^DIC(4,+$P ($G(^DG(40 .8,+$P(IBN D0,U,22),0 )),U,7),1) ) . I $P(Z 0,U,2)="" S IBER=IBE R_"IB097;" Q . F Z=1 ,3,4 I $P( Z1,U,Z)="" S IBER=IB ER_"IB097; " Q ; ; IB *2.0*432 C heck ambul ance addre sses, COB Non-covere d amt. & A ttachment Control I $$AMBCK^IB CBB11(IBIF N)=1 S IBE R=IBER_"IB 329;" I $$ COBAMT^IBC BB11(IBIFN )=1 S IBER =IBER_"IB3 30;" I $$T MCK^IBCBB1 1(IBIFN)=1 S IBER=IB ER_"IB331; " I $$ACCK ^IBCBB11(I BIFN)=1 S IBER=IBER_ "IB332;" I $$COBMRA^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB342;" I $$COBSEC^I BCBB11(IBI FN)=1 S IB ER=IBER_"I B343;" ; ; CHAMPVA Ra te Type an d Primary Insurance Carriers T ype of Cov erage must match S ( IBRTCHV,IB PICHV)=0 I $P($G(^DG CR(399.3,+ IBAT,0)),U ,1)="CHAMP VA" S IBRT CHV=1 I $P ($G(^IBE(3 55.2,+$P($ G(^DIC(36, +IBNDMP,0) ),U,13),0) ),U,1)="CH AMPVA" S I BPICHV=1 I (+IBRTCHV !+IBPICHV) &('IBRTCHV !'IBPICHV) S IBER=IB ER_"IB085; " ; ;Non-V A bill mus t use FEE REIMB INS rate type; FEE REIMB INS rate type can o nly be use d for Non- VA bill ;I B*2.0*554/ DRF 10/9/2 015 ;N IBN VART,IBNVA ST ;S (IBN VART,IBNVA ST)=0 ;I $ P($G(^DGCR (399.3,+IB AT,0)),U,1 )="FEE REI MB INS" S IBNVART=1 ;S IBNVAST =$$NONVAFL G(IBIFN) ; I IBNVART, 'IBNVAST S IBER=IBER _"IB360;" ;Non-VA ra te type us ed for bil l that is not Non-VA ;I 'IBNVA RT,IBNVAST S IBER=IB ER_"IB361; " ;Non-VA rate type not used f or bill th at is Non- VA ; N IBZ PRC,IBZPRC UB D F^IBC EF("N-ALL PROCEDURES ","IBZPRC" ,,IBIFN) ; Procedure Clinic is required for Surgic al Procedu res Outpt Facility C harges I + $P(IBND0,U ,27)'=2,$$ BILLRATE^I BCRU3(IBAT ,IBCL,IBEV DT,"RC OUT PATIENT") D . N Z,Z0 ,Z1,ZE S ( ZE,Z)=0 F S Z=$O(^D GCR(399,IB IFN,"CP",Z )) Q:'Z D I +ZE S IBER=IBER_ "IB320;" Q .. S Z0=$ G(^DGCR(39 9,IBIFN,"C P",Z,0)),Z 1=+Z0 I Z0 '[";ICPT(" Q .. I '( (Z1'<10000 )&(Z1'>699 99))&'((Z1 '<93501)&( Z1'>93533) ) Q .. I ' $P(Z0,U,7) S ZE=1 ; ; Extract procedures for UB-04 D F^IBCEF ("N-UB-04 PROCEDURES ","IBZPRCU B",,IBIFN) ; Does th is bill ha ve ANY pre scriptions associate d with it? ; Must bi ll prescri ptions sep arately fr om other c harges ; ; DEM;432 - Call line level pro vider edit checks. D LNPROV^IB CBB12(IBIF N) ; DEM;4 32 - If th ere are li ne provide r edits, t hen routin e LNPROV^I BCBB12(IBI FN) update s IBER str ing. ; DEM ;432 - Cal l to Other Operating /Operating Provider edit check s. I $$OPP ROVCK^IBCB B12(IBIFN) =1 S IBER= IBER_"IB33 7;" ; DEM ;432 ; DEM ;432 - Lin e level At tachment C ontrol edi ts. I $$LN TMCK^IBCBB 11(IBIFN)= 1 S IBER=I BER_"IB331 ;" ; DEM; 432 I $$LN ACCK^IBCBB 11(IBIFN)= 1 S IBER=I BER_"IB332 ;" ; DEM; 432 ; I $$ ISRX^IBCEF 1(IBIFN) D . N IBZ,I BRXDEF . S IBRXDEF=$ P($G(^IBE( 350.9,1,1) ),U,30),IB Z=0 . F S IBZ=$O(IB ZPRCUB(IBZ )) Q:'IBZ I IBZPRCU B(IBZ),+$P (IBZPRCUB( IBZ),U)'=I BRXDEF S I BER=IBER_" IB102;" Q . K IBZ ; ; Check th at COB seq uences are not skipp ed K Z F Z =1:1:3 S:+ $G(^DGCR(3 99,IBIFN," I"_Z)) Z(Z )="" F Z=0 :1:2 S Z0= $O(Z(Z)) Q :'Z0 I Z0 '=(Z+1) S IBER=IBER_ "IB322;" Q K Z ; HD6 4676 IB*2* 371 - OK f or payer s equence to be blank when the R ate ; Type is either Interagen cy or Shar ing Agreem ent I $P($ G(^DGCR(39 9,IBIFN,0) ),U,21)="" ,$P($G(^DG CR(399,IBI FN,0)),U,7 )'=4,$P($G (^DGCR(399 ,IBIFN,0)) ,U,7)'=9 S IBER=IBER _"IB323;" K IBXDATA D F^IBCEF( "N-PROCEDU RE CODING METHD",,,I BIFN) ; Co ding metho d should a gree with types of p rocedure c odes S IBO K=$S('$O(I BZPRC(0))! (IBXDATA=" "):1,1:0) I 'IBOK S IBOK=1,IBZ =0 F S IB Z=$O(IBZPR C(IBZ)) Q: 'IBZ I IB ZPRC(IBZ), $P(IBZPRC( IBZ),U)'[$ S(IBXDATA= 9:"ICD",1: "ICP") S I BOK=0 Q I 'IBOK D WA RN^IBCBB11 ("Coding M ethod does not agree with all procedure codes foun d on bill" ) D EDITMR A^IBCBB3(. IBQUIT,.IB ER,IBIFN,I BFT) Q:$G( IBQUIT) ; ;Other thi ngs that c ould be ad ded: Rev C ode - calc ulating ch arges ; Di agnosis Co ding, if M T copay - check for other co-p ayments ; I $P(IBNDT X,U,8),$$R EQMRA^IBEF UNC(IBIFN) S IBER=IB ER_"IB121; " ; can' t force MR As to prin t I $P(IBN DTX,U,8)!$ P(IBNDTX,U ,9) D . Q: $P(IBNDTX, U,8)=2 ; D on't want to do this for optio n 2 any mo re. . D WA RN^IBCBB11 ($S($$REQM RA^IBEFUNC (IBIFN)&($ P(IBNDTX,U ,9)):"MRA Secondary ",1:"")_"B ill has be en forced to print " _$S($P(IBN DTX,U,8)=1 !($P(IBNDT X,U,9)=1): "locally", 1:"at clea ringhouse" )) N IBXZ, IBIZ F IBI Z=12,13,14 S IBXZ=$P (IBNDM,U,I BIZ) I +IB XZ S IBXZ= $P($G(^DPT (DFN,.312, IBXZ,0)),U ,18) I +IB XZ S IBXZ= $G(^IBA(35 5.3,+IBXZ, 0)) I +$P( IBXZ,U,12) D . D WAR N^IBCBB11( $P($G(^DIC (36,+IBXZ, 0)),U,1)_" requires Amb Care C ertificati on") ; D V ALNDC^IBCB B11(IBIFN, DFN) ;vali date NDC# ; ;Build A R array if no errors and MRA n ot needed or already rec'd I I BER="",$S( $$NEEDMRA^ IBEFUNC(IB IFN)!($$RE QMRA^IBEFU NC(IBIFN)) :0,1:1) D ARRAY ; ;C heck ROI N ROIERR S ROIERR=0 I $P($G(^DG CR(399,IBI FN,"U")),U ,5)=1,+$P( $G(^DGCR(3 99,IBIFN," U")),U,7)= 0 S ROIERR =1 ; scree n 7 sensit ive record and no RO I I $$ROIC HK^IBCBB11 (IBIFN,DFN ,+IBNDMP) S ROIERR=1 ; check f ile for se nsitive Rx and missi ng ROI I R OIERR S IB ER=IBER_"I B328;" ; ; Verify Lin e Charges Match Clai m Total Ch arge. IB*2 .0*447 BI I +$$GET1^ DIQ(399,IB IFN_",",20 1)'=+$$IBL NTOT^IBCBB 13(IBIFN) S IBER=IBE R_"IB344;" ; ;Test f or valid E IN/SY ID V alues. IB* 2.0*447 BI I $$IBSYE I^IBCBB13( IBIFN) S I BER=IBER_" IB345;" ; ;Test for a missing ICN. IB*2. 0*447 BI I $$IBMICN^ IBCBB13(IB IFN) S IBE R=IBER_"IB 346;" ; ;T est for a ZERO charg e amounts. IB*2.0*44 7 BI I $$I BRCCHK^IBC BB13(IBIFN ) D WARN^I BCBB11("Cl aim contai ns revenue codes wit h no assoc iated char ges.") ; ; Test for m issing "Pa tient reas on for vis it". IB*2. 0*447 BI I $$FT^IBCE F(IBIFN)=3 ,'$$INPAT^ IBCEF(IBIF N),$$IBPRV 3^IBCBB13( IBIFN) S I BER=IBER_" IB347;" ; ;Test for missing Pa yer ID. IB *2.0*447 B I ;I $$IBM PID^IBCBB1 3(IBIFN) S IBER=IBER _"IB348;" ;Changed E rror to Wa rning. IB* 2.0*447 TA Z I $$IBMP ID^IBCBB13 (IBIFN) D WARN^IBCBB 11("Not al l payers h ave Payer IDs.") ; ; Test for m issing "Pr iority (Ty pe) of Adm ission" fo r UB-04. I B*2.0*447 BI I $$FT^ IBCEF(IBIF N)=3,$$GET 1^DIQ(399, IBIFN_",", 158)="" S IBER=IBER_ "IB349;" ; END ;Don't kill IBIF N, IBER, D FN I $O(^T MP($J,"BIL L-WARN",0) ),$G(IBER) ="" S IBER ="WARN" ;W arnings on ly K IBBNO ,IBEVDT,IB LOC,IBCL,I BTF,IBAT,I BWHO,IBST, IBFDT,IBTD T,IBTC,IBF Y,IBFY1,IB AU,IBRU,IB EU,IBARTP, IBFYC,IBMR A,IBTOB,IB TOB12,IBND U2,IBNDUF3 ,IBNDUF31, IBNDTX K I BNDS,IBND0 ,IBNDU,IBN DM,IBNDMP, IBNDU1,IBF FY,IBTFY,I BFT,IBRTCH V,IBPICHV, IBXDATA,IB OK I $D(IB ER),IBER=" " W !,"No Errors fou nd for Nat ional edit s" Q ;ARRA Y ;Build P RCASV(arra y) N IBCOB N,X K PRCA SV Q:$$MCR WNR^IBEFUN C(+$$CURR^ IBCEF2(IBI FN)) S IBC OBN=$$COBN ^IBCEF(IBI FN) S X=IB IFN S PRCA SV("BDT")= DT,PRCASV( "ARREC")=I BIFN S PRC ASV("APR") =DUZ S PRC ASV("PAT") =DFN,PRCAS V("CAT")=$ P(^DGCR(39 9.3,IBAT,0 ),"^",6) I IBWHO="i" S PRCASV( "DEBTOR")= +IBNDMP_"; DIC(36," S PRCASV("D EBTOR")=$S (IBWHO="p" :DFN_";DPT (",IBWHO=" o":$P(IBND M,"^",11)_ ";DIC(4,", IBWHO="i": PRCASV("DE BTOR"),1:" ") S PRCAS V("CARE")= $E($$TOB^I BCEF1(IBIF N),1,2) S PRCASV("FY ")=$$FY^IB OUTL(DT)_U _($P(IBNDU 1,U)-$P(IB NDU1,U,2)) ;S PRCASV ("FY")=$P( IBNDU1,U,9 )_U_$S($P( IBNDU1,U,2 )]"":($P(I BNDU1,U,10 )-$P(IBNDU 1,U,2)),1: $P(IBNDU1, U,10))_$S( $P(IBNDU1, U,11)]"":U _$P(IBNDU1 ,U,11)_U_$ P(IBNDU1,U ,12),1:"") PLUS I IBW HO="i",$P( IBNDM,"^", 2),$D(^DIC (36,$P(IBN DM,"^",2), 0)) S PRCA SV("2NDINS ")=$P(IBND M,"^",2) I IBWHO="i" ,$P(IBNDM, "^",3),$D( ^DIC(36,$P (IBNDM,"^" ,3),0)) S PRCASV("3R DINS")=$P( IBNDM,"^", 3) ; N IBX S IBX=$P( IBND0,U,21 ),IBX=$S(I BX="P":"I1 ",IBX="S": "I2",IBX=" T":"I3",1: "") Q:IBX= "" N IBNDI 1 Q:'$D(^D GCR(399,IB IFN,IBX)) S IBNDI1=^ (IBX) S:$P (IBNDI1,"^ ",3)]"" PR CASV("GPNO ")=$P(IBND I1,"^",3) S:$P(IBNDI 1,"^",15)] "" PRCASV( "GPNM")=$P (IBNDI1,"^ ",15) S:$P (IBNDI1,"^ ",17)]"" P RCASV("INP A")=$P(IBN DI1,"^",17 ) S:$P(IBN DI1,"^",2) ]"" PRCASV ("IDNO")=$ P(IBNDI1," ^",2),PRCA SV("INID") =PRCASV("I DNO") ; Ch eck that t his is a s econdary o r tertiary bill and insurance for previo us ; COB s equence is Medicare WNR and MR A is activ e --> send data elem ents to AR I IBCOBN> 1,$$WNRBIL L^IBEFUNC( IBIFN,IBCO BN-1),$$ED IACTV^IBCE F4(2) D MR A Q ;MRA N IBEOB S I BEOB=0 ; K PRCASV("M EDURE"),PR CASV("MEDC A") ; Get EOB data F S IBEOB= $O(^IBM(36 1.1,"B",IB IFN,IBEOB) ) Q:'IBEOB D . D MR ACALC^IBCE MU2(IBEOB, IBIFN,1,.P RCASV) Q ;MRA ; ;; PREGNANCY DX CODES: V22**-V24* *, V27**-V 28**, 630* *-677** ;; FLU SHOTS PROCEDURE CODES: 90 724, G0008 , 90732, G 0009 ;NONV AFLG(IBIFN ) ; Check if Non-VA bill ; Fun ction retu rns 1 if N on-VA bill ; IB*2.0* 554/DRF 10 /9/2015 N FLAG,PTF S FLAG=0 I $P($G(^DGC R(399,IBIF N,"U2")),U ,10)]"" S FLAG=1 ;No n-VA provi der define d S PTF=$P ($G(^DGCR( 399,IBIFN, 0)),U,8) I PTF,$P($G (^DGPT(PTF ,0)),U,4)= 1 S FLAG=1 ;PTF entr y indicate s Non-VA Q FLAG | |
| 199 | Modified L ogic (Chan ges are in bold) | |
| 200 | IBCBB1 ;AL B/AAS - CO NTINUATION OF EDIT C HECK ROUTI NE ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 27,52,80,9 3,106,51,1 51,148,153 ,137,232,2 80,155,320 ,343,349,3 63,371,395 ,384,432,4 47,488,554 ,577**;21- MAR-94;Bui ld 16 ;Per VA Direct ive 6402, this routi ne should not be mod ified. ; ; *** Begin IB*2.0*48 8 VD (Issu e 46 RBN) N I S I="" S X=+$G(^ DGCR(399,I BIFN,"MP") ) I 'X,$$M CRWNR^IBEF UNC(+$$CUR R^IBCEF2(I BIFN)) S X =+$$CURR^I BCEF2(IBIF N) I X,+$G (^DIC(36,X ,3)) S I=$ P(^(3),U,$ S($$FT^IBC EF(IBIFN)= 2:2,1:4)) S I=$$UP^X LFSTR(I) I (I'=""&(I ["PRNT")&( $G(IBER)'[ "IB488")) D . S IBE R=$G(IBER) _"IB488;" ; ; Cause an error i f FORCED T O PRINT TO CLEARINGH OUSE I $P( $G(^DGCR(3 99,IBIFN," TX")),U,8) =2 D . S I BER=$G(IBE R)_"IB489; " ; ; Caus e a fatal error if t he claim h as no proc edures & i s NOT a UB -04 Inpati ent claim. I +$O(^DG CR(399,IBI FN,"CP",0) )=0 D .I $ $INPAT^IBC EF(IBIFN,1 ),$$INSPRF ^IBCEF(IBI FN) Q ; inpatient UB-04 chec k .I '$$IN PAT^IBCEF( IBIFN,1),$ $INSPRF^IB CEF(IBIFN) D Q ; Outpati ent Instit utional Cl aim. ..I I BER["IB352 " Q ..S IB ER=IBER_"I B352;" .; .; Profess ional clai m .I IBER[ "IB353" Q .S IBER=IB ER_"IB353; " .Q ; *** End IB*2. 0*488 -- V D ; ;MAP T O DGCRBB1 ;% ;Bill S tatus N Z, Z0,Z1,IBFT I $S(+IBS T=0:1,1:"^ 1^2^3^4^7^ "'[(U_IBST _U)) S IBE R=IBER_"IB 045;" ; ;S tatement C overs From I IBFDT=" " S IBER=I BER_"IB061 ;" I IBFDT ]"",IBFDT' ?7N&(IBFDT '?7N1".".N ) S IBER=I BER_"IB061 ;" I IBFDT >IBTDT S I BER=IBER_" IB061;" ; from must be on or b efore the to date S IBFFY=$$F Y^IBOUTL(I BFDT) ; if inpat - f rom date m ust not be prior to admit date . I $$INPA T^IBCEF(IB IFN,1),(IB FDT<($P($G (^DGPT(+$P (IBND0,U,8 ),0)),U,2) \1)) S IBE R=IBER_"IB 061;" ; ;S tatement C overs To I IBTDT="" S IBER=IBE R_"IB062;" I IBTDT]" ",IBTDT'?7 N&(IBTDT'? 7N1".".N) S IBER=IBE R_"IB062;" I IBTDT>D T!(IBTDT<I BFDT) S IB ER=IBER_"I B062;" ; to date mu st not be >than toda y's date S IBTFY=$$F Y^IBOUTL(I BTDT) ; ;T otal Charg es ; IB*2. 0*447/TAZ Removed th is error s o that zer o dollar r evenue cod es can pro cess on th e 837 ;I + IBTC'>0!(+ IBTC'=IBTC ) S IBER=I BER_"IB064 ;" ; ;Bill able charg es for sec ondary cla im I $$MCR ONBIL^IBEF UNC(IBIFN) &(($P(IBND U1,U,1)-$P (IBNDU1,U, 2))'>0) S IBER=IBER_ "IB094;" ; Fiscal Yea r 1 S IBFF Y=$$FY^IBO UTL(IBFDT) ; ;Check provider l ink for cu rrent user , enterer, reviewer and Author izor I '$D (^VA(200,D UZ,0)) S I BER=IBER_" IB048;" I IBEU]"",'$ D(^VA(200, IBEU,0)) S IBER=IBER _"IB048;" I IBRU]"", '$D(^VA(20 0,IBRU,0)) S IBER=IB ER_"IB060; " I IBAU]" ",'$D(^VA( 200,IBAU,0 )) S IBER= IBER_"IB04 1;" ; I IB ER="",+$$S TA^PRCAFN( IBIFN)=104 S IBER=IB ER_"IB040; " ; If ins bill, mus t have val id COB seq uence I $P (IBND0,U,1 1)="i",$S( $P(IBND0,U ,21)="":1, 1:"PST"'[$ P(IBND0,U, 21)) S IBE R=IBER_"IB 324;" ; ; Check for valid sec provider i d for curr ent ins S Z=0 F S Z =$O(^DGCR( 399,IBIFN, "PRV",Z)) Q:'Z S Z0 =$G(^(Z,0) ),Z1=+$$CO BN^IBCEF(I BIFN) I $P (Z0,U,4+Z1 )'="",$P(Z 0,U,11+Z1) '="" D . I '$$SECIDC K^IBCEF74( IBIFN,Z1,$ P(Z0,U,11+ Z1),Z) D W ARN^IBCBB1 1("Prov se condary id type for the "_$P(" PRIMARY^SE CONDARY^TE RTIARY",U, Z1)_" "_$$ EXTERNAL^D ILFD(399.0 222,.01,,+ Z0)_" is i nvalid/won 't transmi t") ; Chec k NPIs D N PICHK^IBCB B11 ; ; Ch eck multip le rx NPIs D RXNPI^I BCBB11(IBI FN) ; ; Ch eck taxono mies D TAX CHK^IBCBB1 1 ; ; Chec k for Phys ician Name K IBXDATA D F^IBCEF ("N-ATT/RE ND PHYSICI AN NAME",, ,IBIFN) ; IB*2.0*432 - CMS1500 no longer needs a c laim level rendering S IBFT=$$ FT^IBCEF(I BIFN) I IB FT'=2,$P($ G(IBXDATA) ,U)="" S I BER=IBER_" IB303;" ; N FUNCTION ,IBINS ; I B*2.0*432 - CMS1500 no longer needs a cl aim level rendering ;S FUNCTIO N=$S($$FT^ IBCEF(IBIF N)=3:4,1:3 ) S FUNCTI ON=$S(IBFT =3:4,1:3) I IBFT'=2, IBER'["IB3 03;" D . F IBINS=1:1 :3 D .. S Z=$$GETTYP ^IBCEP2A(I BIFN,IBINS ) .. I Z,$ P(Z,U,2) D ; Render ing/attend ing prov s econdary i d required ... N IBI D,IBOK,Q0 ... D PROV INF^IBCEF7 4(IBIFN,IB INS,.IBID, 1,"C") ; c heck all a s though t hey were c urrent ... S IBOK=0 ... S Q0=0 F S Q0=$ O(IBID(1,F UNCTION,Q0 )) Q:'Q0 I $P(IBID( 1,FUNCTION ,Q0),U,9)= +Z S IBOK= 1 Q ... I 'IBOK S IB ER=IBER_$S (IBINS=1:" IB236;",IB INS=2:"IB2 37;",IBINS =3:"IB238; ",1:"") ; ; Patch 43 2 enh5:The IB system shall no longer pre vent users from auth orizing(fa tal error message)a claim beca use the sy stem canno t find the providers SSNorEIN ; D PRIIDCH K^IBCBB11 ; N IBM,IB M1 S IBM=$ G(^DGCR(39 9,IBIFN,"M ")) S IBM1 =$G(^DGCR( 399,IBIFN, "M1")) I $ P(IBM,U),$ P($G(^DIC( 36,$P(IBM, U),4)),U,6 ),$P(IBM1, U,2)="" S IBER=IBER_ "IB244;" I $P(IBM,U, 2),$P($G(^ DIC(36,$P( IBM,U,2),4 )),U,6),$P (IBM1,U,3) ="" S IBER =IBER_"IB2 45;" I $P( IBM,U,3),$ P($G(^DIC( 36,$P(IBM, U,3),4)),U ,6),$P(IBM 1,U,4)="" S IBER=IBE R_"IB246;" ; ; If ou tside faci lity, chec k for ID a nd qualifi er in 355. 93 ; 5/15/ 06 - esg - hard erro r IB243 tu rned into warning me ssage inst ead S Z=$P ($G(^DGCR( 399,IBIFN, "U2")),U,1 0) I Z D . I $P($G(^ IBA(355.93 ,Z,0)),U,9 )=""!($P($ G(^IBA(355 .93,Z,0)), U,13)="") D .. N Z1, Z2 .. S Z1 ="Missing Lab or Fac ility Prim ary ID for non-VA fa cility, " .. S Z2=$$ EXTERNAL^D ILFD(399,2 32,,Z) .. I $L(Z2)'> 19 D WARN^ IBCBB11(Z1 _Z2) Q .. D WARN^IBC BB11(Z1),W ARN^IBCBB1 1(" "_Z2) .. Q . Q ; ; Must be one and o nly one di vision on bill S IBZ =$$MULTDIV ^IBCBB11(I BIFN,IBND0 ) ; I IBZ S IBER=IBE R_$S(IBZ=1 :"IB095;", IBZ=2:"IB1 04;",1:"IB 105;") ; A llow multi -divisiona l for OP i nstutional claims I IBZ,$$INPA T^IBCEF(IB IFN)!'($$I NSPRF^IBCE F(IBIFN)) S IBER=IBE R_$S(IBZ=1 :"IB095;", IBZ=2:"IB1 04;",1:"IB 105;") ; S till need error msg on OP Inst itutional if No Defa ult divisi on I IBZ=3 ,'$$INPAT^ IBCEF(IBIF N),$$INSPR F^IBCEF(IB IFN) S IBE R=IBER_"IB 105;" ; Di vision add ress must be defined in instit ution file I $P(IBND 0,U,22) D . N Z,Z0,Z 1 . S Z0=$ G(^DIC(4,+ $P($G(^DG( 40.8,+$P(I BND0,U,22) ,0)),U,7), 0)) . S Z1 =$G(^DIC(4 ,+$P($G(^D G(40.8,+$P (IBND0,U,2 2),0)),U,7 ),1)) . I $P(Z0,U,2) ="" S IBER =IBER_"IB0 97;" Q . F Z=1,3,4 I $P(Z1,U,Z )="" S IBE R=IBER_"IB 097;" Q ; ; IB*2.0*4 32 Check a mbulance a ddresses, COB Non-co vered amt. & Attachm ent Contro l I $$AMBC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB329;" I $$COBAMT ^IBCBB11(I BIFN)=1 S IBER=IBER_ "IB330;" I $$TMCK^IB CBB11(IBIF N)=1 S IBE R=IBER_"IB 331;" I $$ ACCK^IBCBB 11(IBIFN)= 1 S IBER=I BER_"IB332 ;" I $$COB MRA^IBCBB1 1(IBIFN)=1 S IBER=IB ER_"IB342; " I $$COBS EC^IBCBB11 (IBIFN)=1 S IBER=IBE R_"IB343;" ; ;CHAMPV A Rate Typ e and Prim ary Insura nce Carrie rs Type of Coverage must match S (IBRTCH V,IBPICHV) =0 I $P($G (^DGCR(399 .3,+IBAT,0 )),U,1)="C HAMPVA" S IBRTCHV=1 I $P($G(^I BE(355.2,+ $P($G(^DIC (36,+IBNDM P,0)),U,13 ),0)),U,1) ="CHAMPVA" S IBPICHV =1 I (+IBR TCHV!+IBPI CHV)&('IBR TCHV!'IBPI CHV) S IBE R=IBER_"IB 085;" ; ;N on-VA bill must use FEE REIMB INS rate t ype; FEE R EIMB INS r ate type c an only be used for Non-VA bil l ;IB*2.0* 554/DRF 10 /9/2015 ;N IBNVART,I BNVAST ;S (IBNVART,I BNVAST)=0 ;I $P($G(^ DGCR(399.3 ,+IBAT,0)) ,U,1)="FEE REIMB INS " S IBNVAR T=1 ;S IBN VAST=$$NON VAFLG(IBIF N) ;I IBNV ART,'IBNVA ST S IBER= IBER_"IB36 0;" ;Non-V A rate typ e used for bill that is not No n-VA ;I 'I BNVART,IBN VAST S IBE R=IBER_"IB 361;" ;Non -VA rate t ype not us ed for bil l that is Non-VA ; N IBZPRC,IB ZPRCUB D F ^IBCEF("N- ALL PROCED URES","IBZ PRC",,IBIF N) ; Proce dure Clini c is requi red for Su rgical Pro cedures Ou tpt Facili ty Charges I +$P(IBN D0,U,27)'= 2,$$BILLRA TE^IBCRU3( IBAT,IBCL, IBEVDT,"RC OUTPATIEN T") D . N Z,Z0,Z1,ZE S (ZE,Z)= 0 F S Z=$ O(^DGCR(39 9,IBIFN,"C P",Z)) Q:' Z D I +Z E S IBER=I BER_"IB320 ;" Q .. S Z0=$G(^DGC R(399,IBIF N,"CP",Z,0 )),Z1=+Z0 I Z0'[";IC PT(" Q .. I '((Z1'<1 0000)&(Z1' >69999))&' ((Z1'<9350 1)&(Z1'>93 533)) Q .. I '$P(Z0, U,7) S ZE= 1 ; ; Extr act proced ures for U B-04 D F^I BCEF("N-UB -04 PROCED URES","IBZ PRCUB",,IB IFN) ; Doe s this bil l have ANY prescript ions assoc iated with it? ; Mus t bill pre scriptions separatel y from oth er charges ; ; DEM;4 32 - Call line level provider edit check s. D LNPRO V^IBCBB12( IBIFN) ; D EM;432 - I f there ar e line pro vider edit s, then ro utine LNPR OV^IBCBB12 (IBIFN) up dates IBER string. ; DEM;432 - Call to O ther Opera ting/Opera ting Provi der edit c hecks. I $ $OPPROVCK^ IBCBB12(IB IFN)=1 S I BER=IBER_" IB337;" ; DEM;432 ; DEM;432 - Line leve l Attachme nt Control edits. I $$LNTMCK^I BCBB11(IBI FN)=1 S IB ER=IBER_"I B331;" ; DEM;432 I $$LNACCK^I BCBB11(IBI FN)=1 S IB ER=IBER_"I B332;" ; DEM;432 ; ; vd/Begin ning of IB *2*577 - V alidate Li ne Level N DC edits. I $$LNNDCC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB360;" ;IB*2*577 ; vd/End of IB*2*57 7 I $$ISRX ^IBCEF1(IB IFN) D . N IBZ,IBRXD EF . S IBR XDEF=$P($G (^IBE(350. 9,1,1)),U, 30),IBZ=0 . F S IBZ =$O(IBZPRC UB(IBZ)) Q :'IBZ I I BZPRCUB(IB Z),+$P(IBZ PRCUB(IBZ) ,U)'=IBRXD EF S IBER= IBER_"IB10 2;" Q . K IBZ ; ; Ch eck that C OB sequenc es are not skipped K Z F Z=1:1 :3 S:+$G(^ DGCR(399,I BIFN,"I"_Z )) Z(Z)="" F Z=0:1:2 S Z0=$O(Z (Z)) Q:'Z0 I Z0'=(Z +1) S IBER =IBER_"IB3 22;" Q K Z ; HD64676 IB*2*371 - OK for p ayer seque nce to be blank when the Rate ; Type is either Int eragency o r Sharing Agreement I $P($G(^D GCR(399,IB IFN,0)),U, 21)="",$P( $G(^DGCR(3 99,IBIFN,0 )),U,7)'=4 ,$P($G(^DG CR(399,IBI FN,0)),U,7 )'=9 S IBE R=IBER_"IB 323;" K IB XDATA D F^ IBCEF("N-P ROCEDURE C ODING METH D",,,IBIFN ) ; Coding method sh ould agree with type s of proce dure codes S IBOK=$S ('$O(IBZPR C(0))!(IBX DATA=""):1 ,1:0) I 'I BOK S IBOK =1,IBZ=0 F S IBZ=$O (IBZPRC(IB Z)) Q:'IBZ I IBZPRC (IBZ),$P(I BZPRC(IBZ) ,U)'[$S(IB XDATA=9:"I CD",1:"ICP ") S IBOK= 0 Q I 'IBO K D WARN^I BCBB11("Co ding Metho d does not agree wit h all proc edure code s found on bill") D EDITMRA^IB CBB3(.IBQU IT,.IBER,I BIFN,IBFT) Q:$G(IBQU IT) ; ;Oth er things that could be added: Rev Code - calculat ing charge s ; Diagno sis Coding , if MT co pay - chec k for othe r co-payme nts ; I $P (IBNDTX,U, 8),$$REQMR A^IBEFUNC( IBIFN) S I BER=IBER_" IB121;" ; can't fo rce MRAs t o print I $P(IBNDTX, U,8)!$P(IB NDTX,U,9) D . Q:$P(I BNDTX,U,8) =2 ; Don't want to d o this for option 2 any more. . D WARN^I BCBB11($S( $$REQMRA^I BEFUNC(IBI FN)&($P(IB NDTX,U,9)) :"MRA Seco ndary ",1: "")_"Bill has been f orced to p rint "_$S( $P(IBNDTX, U,8)=1!($P (IBNDTX,U, 9)=1):"loc ally",1:"a t clearing house")) N IBXZ,IBIZ F IBIZ=12 ,13,14 S I BXZ=$P(IBN DM,U,IBIZ) I +IBXZ S IBXZ=$P($ G(^DPT(DFN ,.312,IBXZ ,0)),U,18) I +IBXZ S IBXZ=$G(^ IBA(355.3, +IBXZ,0)) I +$P(IBXZ ,U,12) D . D WARN^IB CBB11($P($ G(^DIC(36, +IBXZ,0)), U,1)_" req uires Amb Care Certi fication") ; D VALND C^IBCBB11( IBIFN,DFN) ;validate NDC# ; ;B uild AR ar ray if no errors and MRA not n eeded or a lready rec 'd I IBER= "",$S($$NE EDMRA^IBEF UNC(IBIFN) !($$REQMRA ^IBEFUNC(I BIFN)):0,1 :1) D ARRA Y ; ;Check ROI N ROI ERR S ROIE RR=0 I $P( $G(^DGCR(3 99,IBIFN," U")),U,5)= 1,+$P($G(^ DGCR(399,I BIFN,"U")) ,U,7)=0 S ROIERR=1 ; screen 7 sensitive record and no ROI I $$ROICHK^I BCBB11(IBI FN,DFN,+IB NDMP) S RO IERR=1 ; c heck file for sensit ive Rx and missing R OI I ROIER R S IBER=I BER_"IB328 ;" ; ;Veri fy Line Ch arges Matc h Claim To tal Charge . IB*2.0*4 47 BI I +$ $GET1^DIQ( 399,IBIFN_ ",",201)'= +$$IBLNTOT ^IBCBB13(I BIFN) S IB ER=IBER_"I B344;" ; ; Test for v alid EIN/S Y ID Value s. IB*2.0* 447 BI I $ $IBSYEI^IB CBB13(IBIF N) S IBER= IBER_"IB34 5;" ; ;Tes t for a mi ssing ICN. IB*2.0*44 7 BI I $$I BMICN^IBCB B13(IBIFN) S IBER=IB ER_"IB346; " ; ;Test for a ZERO charge am ounts. IB* 2.0*447 BI I $$IBRCC HK^IBCBB13 (IBIFN) D WARN^IBCBB 11("Claim contains r evenue cod es with no associate d charges. ") ; ;Test for missi ng "Patien t reason f or visit". IB*2.0*44 7 BI I $$F T^IBCEF(IB IFN)=3,'$$ INPAT^IBCE F(IBIFN),$ $IBPRV3^IB CBB13(IBIF N) S IBER= IBER_"IB34 7;" ; ;Tes t for miss ing Payer ID. IB*2.0 *447 BI ;I $$IBMPID^ IBCBB13(IB IFN) S IBE R=IBER_"IB 348;" ;Cha nged Error to Warnin g. IB*2.0* 447 TAZ I $$IBMPID^I BCBB13(IBI FN) D WARN ^IBCBB11(" Not all pa yers have Payer IDs. ") ; ;Test for missi ng "Priori ty (Type) of Admissi on" for UB -04. IB*2. 0*447 BI I $$FT^IBCE F(IBIFN)=3 ,$$GET1^DI Q(399,IBIF N_",",158) ="" S IBER =IBER_"IB3 49;" ;END ;Don't kil l IBIFN, I BER, DFN I $O(^TMP($ J,"BILL-WA RN",0)),$G (IBER)="" S IBER="WA RN" ;Warni ngs only K IBBNO,IBE VDT,IBLOC, IBCL,IBTF, IBAT,IBWHO ,IBST,IBFD T,IBTDT,IB TC,IBFY,IB FY1,IBAU,I BRU,IBEU,I BARTP,IBFY C,IBMRA,IB TOB,IBTOB1 2,IBNDU2,I BNDUF3,IBN DUF31,IBND TX K IBNDS ,IBND0,IBN DU,IBNDM,I BNDMP,IBND U1,IBFFY,I BTFY,IBFT, IBRTCHV,IB PICHV,IBXD ATA,IBOK I $D(IBER), IBER="" W !,"No Erro rs found f or Nationa l edits" Q ;ARRAY ;B uild PRCAS V(array) N IBCOBN,X K PRCASV Q :$$MCRWNR^ IBEFUNC(+$ $CURR^IBCE F2(IBIFN)) S IBCOBN= $$COBN^IBC EF(IBIFN) S X=IBIFN S PRCASV(" BDT")=DT,P RCASV("ARR EC")=IBIFN S PRCASV( "APR")=DUZ S PRCASV( "PAT")=DFN ,PRCASV("C AT")=$P(^D GCR(399.3, IBAT,0),"^ ",6) I IBW HO="i" S P RCASV("DEB TOR")=+IBN DMP_";DIC( 36," S PRC ASV("DEBTO R")=$S(IBW HO="p":DFN _";DPT(",I BWHO="o":$ P(IBNDM,"^ ",11)_";DI C(4,",IBWH O="i":PRCA SV("DEBTOR "),1:"") S PRCASV("C ARE")=$E($ $TOB^IBCEF 1(IBIFN),1 ,2) S PRCA SV("FY")=$ $FY^IBOUTL (DT)_U_($P (IBNDU1,U) -$P(IBNDU1 ,U,2)) ;S PRCASV("FY ")=$P(IBND U1,U,9)_U_ $S($P(IBND U1,U,2)]"" :($P(IBNDU 1,U,10)-$P (IBNDU1,U, 2)),1:$P(I BNDU1,U,10 ))_$S($P(I BNDU1,U,11 )]"":U_$P( IBNDU1,U,1 1)_U_$P(IB NDU1,U,12) ,1:"")PLUS I IBWHO=" i",$P(IBND M,"^",2),$ D(^DIC(36, $P(IBNDM," ^",2),0)) S PRCASV(" 2NDINS")=$ P(IBNDM,"^ ",2) I IBW HO="i",$P( IBNDM,"^", 3),$D(^DIC (36,$P(IBN DM,"^",3), 0)) S PRCA SV("3RDINS ")=$P(IBND M,"^",3) ; N IBX S I BX=$P(IBND 0,U,21),IB X=$S(IBX=" P":"I1",IB X="S":"I2" ,IBX="T":" I3",1:"") Q:IBX="" N IBNDI1 Q: '$D(^DGCR( 399,IBIFN, IBX)) S IB NDI1=^(IBX ) S:$P(IBN DI1,"^",3) ]"" PRCASV ("GPNO")=$ P(IBNDI1," ^",3) S:$P (IBNDI1,"^ ",15)]"" P RCASV("GPN M")=$P(IBN DI1,"^",15 ) S:$P(IBN DI1,"^",17 )]"" PRCAS V("INPA")= $P(IBNDI1, "^",17) S: $P(IBNDI1, "^",2)]"" PRCASV("ID NO")=$P(IB NDI1,"^",2 ),PRCASV(" INID")=PRC ASV("IDNO" ) ; Check that this is a secon dary or te rtiary bil l and insu rance for previous ; COB seque nce is Med icare WNR and MRA is active -- > send dat a elements to AR I I BCOBN>1,$$ WNRBILL^IB EFUNC(IBIF N,IBCOBN-1 ),$$EDIACT V^IBCEF4(2 ) D MRA Q ;MRA N IBE OB S IBEOB =0 ; K PRC ASV("MEDUR E"),PRCASV ("MEDCA") ; Get EOB data F S IBEOB=$O(^ IBM(361.1, "B",IBIFN, IBEOB)) Q: 'IBEOB D . D MRACAL C^IBCEMU2( IBEOB,IBIF N,1,.PRCAS V) Q ;MRA ; ;; PREG NANCY DX C ODES: V22* *-V24**, V 27**-V28** , 630**-67 7** ;; FLU SHOTS PRO CEDURE COD ES: 90724, G0008, 90 732, G0009 ;NONVAFLG (IBIFN) ; Check if N on-VA bill ; Functio n returns 1 if Non-V A bill ; I B*2.0*554/ DRF 10/9/2 015 N FLAG ,PTF S FLA G=0 I $P($ G(^DGCR(39 9,IBIFN,"U 2")),U,10) ]"" S FLAG =1 ;Non-VA provider defined S PTF=$P($G( ^DGCR(399, IBIFN,0)), U,8) I PTF ,$P($G(^DG PT(PTF,0)) ,U,4)=1 S FLAG=1 ;PT F entry in dicates No n-VA Q FLA G | |
| 201 | ||
| 202 | Routines | |
| 203 | Activities | |
| 204 | Routine Na me | |
| 205 | IBCBB11 | |
| 206 | Enhancemen t Category | |
| 207 | New | |
| 208 | Modify | |
| 209 | Delete | |
| 210 | No Change | |
| 211 | RTM | |
| 212 | ||
| 213 | Related Op tions | |
| 214 | None | |
| 215 | Related Ro utines | |
| 216 | Routines “ Called By” | |
| 217 | Routines “ Called” | |
| 218 | ||
| 219 | ||
| 220 | ||
| 221 | ||
| 222 | Data Dicti onary (DD) Reference s | |
| 223 | None | |
| 224 | Related Pr otocols | |
| 225 | None | |
| 226 | Related In tegration Control Re gistration s (ICRs) | |
| 227 | None | |
| 228 | Data Passi ng | |
| 229 | Input | |
| 230 | Output Re ference | |
| 231 | Both | |
| 232 | Global Re ference | |
| 233 | Local | |
| 234 | Input Attr ibute Name and Defin ition | |
| 235 | Name: | |
| 236 | Definition : | |
| 237 | Output Att ribute Nam e and Defi nition | |
| 238 | Name: | |
| 239 | Definition : | |
| 240 | Current Lo gic | |
| 241 | IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3 :45 PM ;;2 .0;INTEGRA TED BILLIN G;**51,343 ,363,371,3 95,392,401 ,384,400,4 36,432,516 ,550**;21- MAR-94;Bui ld 25 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ;W ARN(IBDISP ) ; Set wa rning in g lobal ; DI SP = warni ng text to display ; N Z S Z=+ $O(^TMP($J ,"BILL-WAR N",""),-1) I Z=0 S ^ TMP($J,"BI LL-WARN",1 )=$J("",5) _"**Warnin gs**:",Z=1 S Z=Z+1,^ TMP($J,"BI LL-WARN",Z )=$J("",5) _IBDISP Q ;MULTDIV(I BIFN,IBND0 ) ; Check for multip le divisio ns on a bi ll ien IBI FN ; IBND0 = 0-node of bill ; ; Function returns 1 if more t han 1 divi sion found on bill N Z,Z0,Z1,M ULT S MULT =0,Z1=$P(I BND0,U,22) I Z1 D . S Z=0 F S Z=$O(^DGC R(399,IBIF N,"RC",Z)) Q:'Z S Z 0=$P(^(Z,0 ),U,7) I Z 0,Z0'=Z1 S MULT=1 Q . S Z=0 F S Z=$O(^D GCR(399,IB IFN,"CP",Z )) Q:'Z S Z0=$P(^(Z ,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q I 'Z1 S MULT=3 Q M ULT ; ;; P REGNANCY D X CODES: V 22**-V24** , V27**-V2 8**, 630** -677** ;; FLU SHOTS PROCEDURE CODES: 907 24, G0008, 90732, G0 009 ;NPICH K ; Check for requir ed NPIs N IBNPIS,IBN ONPI,IBNPI REQ,Z,IBNF I,IBTF,IBW C,IBXSAVE, IBPRV,IBLI NE ;*** pi j start IB *20*436 ** * N IBRATY PE,IBLEGAL S (IBRATY PE,IBLEGAL )="" S IBR ATYPE=$P($ G(^DGCR(39 9,IBIFN,0) ),U,7) ; L egal types for this use. ; 7=N O FAULT IN S. ; 10=TO RT FEASOR ; 11=WORKE RS' COMP. S IBNFI=$O (^DGCR(399 .3,"B","NO FAULT INS .",0)) S:' IBNFI IBNF I=7 S IBTF =$O(^DGCR( 399.3,"B", "TORT FEAS OR",0)) S: 'IBTF IBTF =10 S IBWC =$O(^DGCR( 399.3,"B", "WORKERS' COMP.",0)) S:'IBWC I BWC=11 ; I IBRATYPE= IBNFI!(IBR ATYPE=IBTF )!(IBRATYP E=IBWC) D . ; One of the legal types - f orce local print . S IBLEGAL=1 ;*** pij end *** S IBNPIREQ=$ $NPIREQ^IB CEP81(DT) ; Check if NPI is re quired ; C heck provi ders ; IB* 2.0*432 ch anged the NPI check to the new Provider Array ;S I BNPIS=$$PR OVNPI^IBCE F73A(IBIFN ,.IBNONPI) D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1) S IBP RV="" F S IBPRV=$O( IBXSAVE("P ROVINF",IB IFN,"C",1, IBPRV)) Q: 'IBPRV D . I $P($G( IBXSAVE("P ROVINF",IB IFN,"C",1, IBPRV,0)), U,4)="" S IBNONPI(IB PRV)="" S IBLINE="" F S IBLIN E=$O(IBXSA VE("L-PROV ",IBIFN,IB LINE)) Q:' IBLINE D . S IBPRV= "" . F S IBPRV=$O(I BXSAVE("L- PROV",IBIF N,IBLINE," C",1,IBPRV )) Q:IBPRV ="" D .. I $P($G(IB XSAVE("L-P ROV",IBIFN ,IBLINE,"C ",1,IBPRV, 0)),U,4)=" " S IBNONP I(IBPRV)=" " I $D(IBN ONPI) S IB PRV="" F S IBPRV=$O (IBNONPI(I BPRV)) Q:' IBPRV D . S IBER=IB ER_"IB"_(1 40+IBPRV)_ ";" Q ; I f required , set erro r IB*2*516 ; Check o rganizatio ns S IBNON PI="" S IB NPIS=$$ORG NPI^IBCEF7 3A(IBIFN,. IBNONPI) I $L(IBNONP I) F Z=1:1 :$L(IBNONP I,U) D . S IBER=IBER _$P("IB339 ;^IB340;^I B341;",U,$ P(IBNONPI, U,Z)) ; DE M;432 Adde d NPI erro rs. Q ;TAX CHK ; Chec k for requ ired taxon omies N IB DT,IBLINE, IBNOTAX,IB PRV,IBTAXS ,IBXSAVE,Z ; ; MRD;I B*2.0*516 - This che ck is now moot; 'tod ay' is alw ays on or ; after Ma y 23, 2008 , so taxon omy codes are always required ; for cert ain provid ers. ;S IB TAXREQ=$$T AXREQ^IBCE P81(DT) ; Check if t axonomy is required ; ; Check providers ; IB*2.0*4 32 changed the Taxon omy check to the new Provider Array ;S I BTAXS=$$PR OVTAX^IBCE F73A(IBIFN ,.IBNOTAX) D ALLIDS^ IBCEFP(IBI FN,.IBXSAV E,1) S IBP RV="" F S IBPRV=$O( IBXSAVE("P ROVINF",IB IFN,"C",1, IBPRV)) Q: 'IBPRV D . I $G(IBX SAVE("PROV INF",IBIFN ,"C",1,IBP RV,"TAXONO MY"))="" S IBNOTAX(I BPRV)="" . Q ; S IBL INE="" F S IBLINE=$ O(IBXSAVE( "L-PROV",I BIFN,IBLIN E)) Q:'IBL INE D . S IBPRV="" . F S IBP RV=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE,"C", 1,IBPRV)) Q:IBPRV="" D . . I $G(IBXSAVE ("L-PROV", IBIFN,IBLI NE,"C",1,I BPRV,"TAXO NOMY"))="" S IBNOTAX (IBPRV)="" . . Q . Q ; ; IB251 = Referri ng provide r taxonomy missing. ; IB253 = Rendering provider t axonomy mi ssing. ; I B254 = Att ending pro vider taxo nomy missi ng. ; I $D (IBNOTAX) S IBPRV="" F S IBPR V=$O(IBNOT AX(IBPRV)) Q:'IBPRV D . ; Onl y Referrin g, Renderi ng and Att ending are currently sent to t he payer . ;I IBTAXR EQ,"134"[I BPRV S IBE R=IBER_"IB "_(250+IBP RV)_";" Q ; MRD;IB*2 .0*516 - A lways requ ired. . I "134"[IBPR V S IBER=I BER_"IB"_( 250+IBPRV) _";" Q ; If require d, set err or and qui t . D WARN ("Taxonomy for the " _$P("refer ring^opera ting^rende ring^atten ding^super vising^^^^ other",U,I BPRV)_" pr ovider has no value" ) ; Else, set warnin g . Q ; ; Check orga nizations. The funct ion ORGTAX will set IBNOTAX to be a ; li st of enti ties missi ng taxonom y codes, i f any (n, n^m, n^m^p , ; where each 1 is service fa cility, 2 is non-VA service fa cility and ; 3 is bi lling prov ider. ; S IBNOTAX="" S IBTAXS= $$ORGTAX^I BCEF73A(IB IFN,.IBNOT AX) I $L(I BNOTAX) F Z=1:1:$L(I BNOTAX,U) D . ; IB16 7 = Billin g Provider taxonomy missing. . ;I IBTAXR EQ,$P(IBNO TAX,U,Z)=3 S IBER=IB ER_"IB167; " Q ; MRD; IB*2.0*516 - Always required. . I $P(IBN OTAX,U,Z)= 3 S IBER=I BER_"IB167 ;" Q . ; M RD;IB*2.0* 516 - Remo ve warning message f or missing taxonomy code for l ab or faci lity. . ; D WARN("Ta xonomy for the "_$P( "Service F acility^No n-VA Servi ce Facilit y^Billing Provider", U,$P(IBNOT AX,U,Z))_" has no va lue") ; El se, set wa rning . Q ; Q ;VALND C(IBIFN,IB DFN) ; IB* 2*363 - va lidate NDC # between PRESCRIPTI ON file (# 52) ; and IB BILL/CL AIMS PRESC RIPTION RE FILL file (#362.4) ; input - I BIFN = int ernal entr y number o f the bill ing record in the BI LL/CLAIMS file (#399 ) ; IBDFN = internal entry num ber of pat ient recor d in the P ATIENT fil e (#2) N I BX,IBRXCOL ; call pr ogram that determine s if NDC d ifferences exist D V ALNDC^IBEF UNC3(IBIFN ,IBDFN,.IB RXCOL) Q:' $D(IBRXCOL ) ; at lea st one RX on the IB record has an NDC di screpancy S IBX=0 F S IBX=$O (IBRXCOL(I BX)) Q:'IB X D WARN( "NDC# on B ill does n ot equal t he NDC# on Rx "_IBRX COL(IBX)) Q ;PRIIDCH K ; Check for requir ed Pimarar y ID (SSN/ EIN) ; If the provid er is on t he claim, he must ha ve one ; N IBI,IBZ I $$TXMT^I BCEF4(IBIF N) D . D F ^IBCEF("N- ALL ATT/RE ND PROV SS N/EI","IBZ ",,IBIFN) . S IBI="" F S IBI= $O(^DGCR(3 99,IBIFN," PRV","B",I BI)) Q:IBI ="" D .. I $P(IBZ,U ,IBI)="" S IBER=IBER _$S(IBI=1: "IB151;",I BI=2:"IB15 2;",IBI=3! (IBI=4):"I B321;",IBI =5:"IB153; ",IBI=9:"I B154;",1:" ") Q ;RXNP I(IBIFN) ; check for multiple pharmacy n pi's on th e same bil l N IBORG, IBRXNPI,IB X,IBY S IB ORG=$$RXSI TE^IBCEF73 A(IBIFN,.I BORG) S IB X=0 F S I BX=$O(IBOR G(IBX)) Q: 'IBX S IB Y=0 F S I BY=$O(IBOR G(IBX,IBY) ) Q:'IBY S IBRXNPI( +IBORG(IBX ,IBY))="" S (IBX,IBY )=0 F S I BX=$O(IBRX NPI(IBX)) Q:'IBX S IBY=IBY+1 I IBY>1 D WARN("Bill has presc riptions r esulting f rom "_IBY_ " differen t NPI loca tions") Q ;ROICHK(IB IFN,IBDFN, IBINS) ; I B*2.0*384 - check pr escription s that con tain the ; SENSITIVE DIAGNOSIS DRUG fiel d #87 in t he DRUG Fi le #50 set to 1 agai nst ; the Claims Tra cking ROI file (#356 .25) to se e if an RO I is on fi le ; input - IBIFN = IEN of th e Bill/Cla ims file ( #399) ; IB DFN = IEN of the pat ient ; IBI NS = IEN o f the paye r insuranc e company (#36) ; OU TPUT - 0 = no error ; 1 = a p rescriptio n is sensi tive and t here is no ROI on fi le ; N IBX ,IBY0,IBRX IEN,IBDT,I BDRUG,ROIQ S ROIQ=0 S IBX=0 F S IBX=$O( ^IBA(362.4 ,"C",IBIFN ,IBX)) Q:' IBX D .S IBY0=^IBA( 362.4,IBX, 0),IBRXIEN =$P(IBY0,U ,5) I 'IBR XIEN Q .S IBDT=$P(IB Y0,U,3),IB DRUG=$P(IB Y0,U,4) .D ZERO^IBRX UTL(IBDRUG ) .I $$SEN S^IBNCPDR( IBDRUG) D ; Sensiti ve Diagnos is Drug - check for ROI .. I $ $ROI^IBNCP DR4(IBDFN, IBDRUG,IBI NS,IBDT) Q ;ROI is on file .. D WARN("R OI not on file for p rescriptio n "_$$RXAP I1^IBNCPUT 1(IBRXIEN, .01,"E")) .. S ROIQ= 1ROICHKQ ; K ^TMP($J ,"IBDRUG") Q ROIQ ;A MBCK(IBIFN ) ; IB*2.0 *432 - if ambulance location d efined, ad dress must be define d ; if the re is anyt hing enter ed in any of the add ress field s (either p/up or dr op/off fie lds), than there nee ds to be: ; Address 1, State and ZIP un less the S tate is no t a US sta te or poss ession, th en zip cod e is not n eeded (CMS 1500 only) ; input - IBIFN = I EN of the Bill/Claim s file (#3 99) ; OUTP UT - 0 = n o error ; 1 = Error ; N IBPAM B,IBDAMB,I BAMBR,IBCK S IBAMBR= 0 Q:$$INSP RF^IBCEF(I BIFN)'=0 I BAMBR S IB PAMB=$G(^D GCR(399,IB IFN,"U5")) ,IBDAMB=$G (^DGCR(399 ,IBIFN,"U6 ")) S IBCK (5)=$$NOPU NCT^IBCEF( $P(IBPAMB, U,2,6),1), IBCK(6)=$$ NOPUNCT^IB CEF($P(IBD AMB,U,1,6) ,1) I IBCK (5)="",IBC K(6)="" Q IBAMBR ; a t this poi nt we know that at l east one a mbulance f ield has d ata, so ch eck to see if all ha ve data I IBCK(5)'=" " F I=2,4, 5 I $P(IBP AMB,U,I)=" " S IBAMBR =1 I IBCK( 6)'="" F I =1,2,4,5 I $P(IBDAMB ,U,I)="" S IBAMBR=1 Q:IBAMBR=1 IBAMBR ; now check zip code. OK to be n ull if sta te is not a US Poses sion F I=" IBPAMB","I BDAMB" I $ P(I,U,5)'= "",$P($G(^ DIC(5,$P(I ,U,5),0)), U,6)=1,$P( I,U,6)="" S IBAMBR=1 Q IBAMBR ;COBAMT(IB IFN) ; IB* 2.0*432 - IF there i s a COB am t. it must equal the Total Cla im Charge Amount ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - 0 = no er ror ; 1 = Error ; Q :IBIFN="" 0 Q:$P($G( ^DGCR(399, IBIFN,"U4" )),U)="" 0 Q:+$P($G( ^DGCR(399, IBIFN,"U1" )),U)'=+$P ($G(^DGCR( 399,IBIFN, "U4")),U) 1 Q 0 ;COB MRA(IBIFN) ; IB*2.0* 432 - If t here is a 'COB total non-cover ed amount' (File#399 , Field#26 0), ; Pri mary Insur ance must be Medicar e that nev er went to Medicare, and this must be a 2ndary or tertiary c laim ; inp ut - IBIFN = IEN of the Bill/C laims file (#399) ; OUTPUT - 0 = no erro r ; 1 = E rror ; N I BP Q:IBIFN ="" 0 Q:$P ($G(^DGCR( 399,IBIFN, "U4")),U)= "" 0 S IBP =$P($G(^DG CR(399,IBI FN,"M1")), U,5) S:IBP ="" IBP=IB IFN I $$WN RBILL^IBEF UNC(IBIFN, 1),$P($G(^ DGCR(399,I BP,"S")),U ,7)="",$$C OBN^IBCEF( IBIFN)>1 Q 0 Q 1 ;CO BSEC(IBIFN ) ; IB*2.0 *432 - If there is N OT a 'COB total non- covered am ount' (Fil e#399, Fie ld#260), ; and Prim ary Insura nce is Med icare that never wen t to Medic are, 2ndar y or terti ary claim cannot be set to tra nsmit ; in put - IBIF N = IEN of the Bill/ Claims fil e (#399) ; OUTPUT - 0 = no err or ; 1 = Error ; N IBP Q:IBIF N="" 0 Q:$ P($G(^DGCR (399,IBIFN ,"U4")),U) '="" 0 Q:$ $COBN^IBCE F(IBIFN)<2 0 S IBP=$ P($G(^DGCR (399,IBIFN ,"M1")),U, 5) S:IBP=" " IBP=IBIF N I $$WNRB ILL^IBEFUN C(IBIFN,1) ,$P($G(^DG CR(399,IBP ,"S")),U,7 )="",$P($G (^DGCR(399 ,IBIFN,"TX ")),U,8)'= 1 Q 1 Q 0 ;TMCK(IBIF N) ; IB*2. 0*432 - At tachment C ontrol Num ber - REQU IRED when Transmissi on Method = BM, EL, EM, or FT ; input - IBIFN = IE N of the B ill/Claims file (#39 9) ; OUTPU T - 0 = no error ; 1 = Error ; N IBAC Q :IBIFN="" 0 F I=1,3 S IBAC(I)= $P($G(^DGC R(399,IBIF N,"U8")),U ,I) Q:IBAC (3)="" 0 Q :IBAC(1)'= "" 0 Q:IBA C(3)="AA" 0 Q 1 ;ACC K(IBIFN) ; IB*2.0*43 2 If any o f the loop info is p resent, th en Report Type & Tra nsmission Method req 'd ; input - IBIFN = IEN of th e Bill/Cla ims file ( #399) ; OU TPUT - 0 = no error ; 1 = Err or ; N IBA C Q:IBIFN= "" 0 F I=1 :1:3 S IBA C(I)=$P($G (^DGCR(399 ,IBIFN,"U8 ")),U,I) ; All field s null, no error I I BAC(1)="", IBAC(2)="" ,IBAC(3)=" " Q 0 ; Bo th require d fields c omplete, n o error I IBAC(2)'=" ",IBAC(3)' ="" Q 0 ; At this po int, one o f the 2 re quired fie lds has da ta and one does not, so error Q 1 ;LNTMC K(IBIFN) ; DEM;IB*2. 0*432 - (L ine Level) Attachmen t Control Number - R EQUIRED wh en Transmi ssion Meth od = BM, E L, EM, or FT ; input - IBIFN = IEN of th e Bill/Cla ims file ( #399) ; OU TPUT - IBL NERR = 0 = no error ; IBLNERR = 1 = Err or ; N IBA C,IBPROCP, I,IBLNERR S IBLNERR= 0 ; DEM;43 2 - Initia lize error flag IBLN ERR to '0' for no er rors. Q:IB IFN="" IBL NERR S IBP ROCP=0 F S IBPROCP= $O(^DGCR(3 99,IBIFN," CP",IBPROC P)) Q:'IBP ROCP D Q :IBLNERR . Q:'($D(^D GCR(399,IB IFN,"CP",I BPROCP,0)) #10) ; DEM ;432 - Nod e '0' is p rocedure n ode. . Q:' ($D(^DGCR( 399,IBIFN, "CP",IBPRO CP,1))#10) ; DEM;432 - Node '1 ' is line level Atta chment Con trol field s. . F I=1 ,3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I) . I IBA C(3)="" S IBLNERR=0 Q . I IBAC (1)'="" S IBLNERR=0 Q . I (IBA C(3)="AA") S IBLNERR =0 Q . S I BLNERR=1 . Q ; Q IBL NERR ;LNAC CK(IBIFN) ; DEM;IB*2 .0*432 (Li ne Level) If any of the loop i nfo is pre sent, then Report Ty pe & Trans mission Me thod req'd ; input - IBIFN = I EN of the Bill/Claim s file (#3 99) ; OUTP UT - IBLNE RR = 0 = n o error ; IBLNERR = 1 = Error ; N IBAC, IBPROCP,I, IBLNERR S IBLNERR=0 ; DEM;432 - Initiali ze error f lag IBLNER R to '0' f or no erro rs. Q:IBIF N="" IBLNE RR S IBPRO CP=0 F S IBPROCP=$O (^DGCR(399 ,IBIFN,"CP ",IBPROCP) ) Q:'IBPRO CP D Q:I BLNERR . Q :'($D(^DGC R(399,IBIF N,"CP",IBP ROCP,0))#1 0) ; DEM;4 32 - Node '0' is pro cedure nod e. . Q:'($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,1))#10) ; DEM;432 - Node '1' is line le vel Attach ment Contr ol fields. . F I=1:1 :3 S IBAC( I)=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,1),U, I) . ; All fields nu ll, no err or . I IBA C(1)="",IB AC(2)="",I BAC(3)="" S IBLNERR= 0 Q . ; Bo th require d fields c omplete, n o error . I IBAC(2)' ="",IBAC(3 )'="" S IB LNERR=0 Q . ; At thi s point, o ne of the 2 required fields ha s data and one does not, so er ror . S IB LNERR=1 . Q ; Q IBLN ERR | |
| 242 | Modified L ogic (Chan ges are in bold) | |
| 243 | IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3 :45 PM ;;2 .0;INTEGRA TED BILLIN G;**51,343 ,363,371,3 95,392,401 ,384,400,4 36,432,516 ,550,577** ;21-MAR-94 ;Build 16 ;;Per VA D irective 6 402, this routine sh ould not b e modified . ;WARN(IB DISP) ; Se t warning in global ; DISP = w arning tex t to displ ay ; N Z S Z=+$O(^TM P($J,"BILL -WARN","") ,-1) I Z=0 S ^TMP($J ,"BILL-WAR N",1)=$J(" ",5)_"**Wa rnings**:" ,Z=1 S Z=Z +1,^TMP($J ,"BILL-WAR N",Z)=$J(" ",5)_IBDIS P Q ;MULTD IV(IBIFN,I BND0) ; Ch eck for mu ltiple div isions on a bill ien IBIFN ; I BND0 = 0-n ode of bil l ; ; Func tion retur ns 1 if mo re than 1 division f ound on bi ll N Z,Z0, Z1,MULT S MULT=0,Z1= $P(IBND0,U ,22) I Z1 D . S Z=0 F S Z=$O( ^DGCR(399, IBIFN,"RC" ,Z)) Q:'Z S Z0=$P(^ (Z,0),U,7) I Z0,Z0'= Z1 S MULT= 1 Q . S Z= 0 F S Z=$ O(^DGCR(39 9,IBIFN,"C P",Z)) Q:' Z S Z0=$P (^(Z,0),U, 6) I Z0,Z0 '=Z1 S MUL T=2 Q I 'Z 1 S MULT=3 Q MULT ; ;; PREGNAN CY DX CODE S: V22**-V 24**, V27* *-V28**, 6 30**-677** ;; FLU SH OTS PROCED URE CODES: 90724, G0 008, 90732 , G0009 ;N PICHK ; Ch eck for re quired NPI s N IBNPIS ,IBNONPI,I BNPIREQ,Z, IBNFI,IBTF ,IBWC,IBXS AVE,IBPRV, IBLINE ;** * pij star t IB*20*43 6 *** N IB RATYPE,IBL EGAL S (IB RATYPE,IBL EGAL)="" S IBRATYPE= $P($G(^DGC R(399,IBIF N,0)),U,7) ; Legal t ypes for t his use. ; 7=NO FAUL T INS. ; 1 0=TORT FEA SOR ; 11=W ORKERS' CO MP. S IBNF I=$O(^DGCR (399.3,"B" ,"NO FAULT INS.",0)) S:'IBNFI IBNFI=7 S IBTF=$O(^D GCR(399.3, "B","TORT FEASOR",0) ) S:'IBTF IBTF=10 S IBWC=$O(^D GCR(399.3, "B","WORKE RS' COMP." ,0)) S:'IB WC IBWC=11 ; I IBRAT YPE=IBNFI! (IBRATYPE= IBTF)!(IBR ATYPE=IBWC ) D . ; On e of the l egal types - force l ocal print . S IBLEG AL=1 ;*** pij end ** * S IBNPIR EQ=$$NPIRE Q^IBCEP81( DT) ; Chec k if NPI i s required ; Check p roviders ; IB*2.0*43 2 changed the NPI ch eck to the new Provi der Array ;S IBNPIS= $$PROVNPI^ IBCEF73A(I BIFN,.IBNO NPI) D ALL IDS^IBCEFP (IBIFN,.IB XSAVE,1) S IBPRV="" F S IBPRV =$O(IBXSAV E("PROVINF ",IBIFN,"C ",1,IBPRV) ) Q:'IBPRV D . I $P ($G(IBXSAV E("PROVINF ",IBIFN,"C ",1,IBPRV, 0)),U,4)=" " S IBNONP I(IBPRV)=" " S IBLINE ="" F S I BLINE=$O(I BXSAVE("L- PROV",IBIF N,IBLINE)) Q:'IBLINE D . S IB PRV="" . F S IBPRV= $O(IBXSAVE ("L-PROV", IBIFN,IBLI NE,"C",1,I BPRV)) Q:I BPRV="" D .. I $P($ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,0)),U, 4)="" S IB NONPI(IBPR V)="" I $D (IBNONPI) S IBPRV="" F S IBPR V=$O(IBNON PI(IBPRV)) Q:'IBPRV D . S IBE R=IBER_"IB "_(140+IBP RV)_";" Q ; If requ ired, set error IB*2 *516 ; Che ck organiz ations S I BNONPI="" S IBNPIS=$ $ORGNPI^IB CEF73A(IBI FN,.IBNONP I) I $L(IB NONPI) F Z =1:1:$L(IB NONPI,U) D . S IBER= IBER_$P("I B339;^IB34 0;^IB341;" ,U,$P(IBNO NPI,U,Z)) ; DEM;432 Added NPI errors. Q ;TAXCHK ; Check for required t axonomies N IBDT,IBL INE,IBNOTA X,IBPRV,IB TAXS,IBXSA VE,Z ; ; M RD;IB*2.0* 516 - This check is now moot; 'today' is always on or ; afte r May 23, 2008, so t axonomy co des are al ways requi red ; for certain pr oviders. ; S IBTAXREQ =$$TAXREQ^ IBCEP81(DT ) ; Check if taxonom y is requi red ; ; Ch eck provid ers ; IB*2 .0*432 cha nged the T axonomy ch eck to the new Provi der Array ;S IBTAXS= $$PROVTAX^ IBCEF73A(I BIFN,.IBNO TAX) D ALL IDS^IBCEFP (IBIFN,.IB XSAVE,1) S IBPRV="" F S IBPRV =$O(IBXSAV E("PROVINF ",IBIFN,"C ",1,IBPRV) ) Q:'IBPRV D . I $G (IBXSAVE(" PROVINF",I BIFN,"C",1 ,IBPRV,"TA XONOMY"))= "" S IBNOT AX(IBPRV)= "" . Q ; S IBLINE="" F S IBLI NE=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE)) Q: 'IBLINE D . S IBPRV ="" . F S IBPRV=$O( IBXSAVE("L -PROV",IBI FN,IBLINE, "C",1,IBPR V)) Q:IBPR V="" D . . I $G(IBX SAVE("L-PR OV",IBIFN, IBLINE,"C" ,1,IBPRV," TAXONOMY") )="" S IBN OTAX(IBPRV )="" . . Q . Q ; ; I B251 = Ref erring pro vider taxo nomy missi ng. ; IB25 3 = Render ing provid er taxonom y missing. ; IB254 = Attending provider taxonomy m issing. ; I $D(IBNOT AX) S IBPR V="" F S IBPRV=$O(I BNOTAX(IBP RV)) Q:'IB PRV D . ; Only Refe rring, Ren dering and Attending are curre ntly sent to the pay er . ;I IB TAXREQ,"13 4"[IBPRV S IBER=IBER _"IB"_(250 +IBPRV)_"; " Q ; MRD; IB*2.0*516 - Always required. . I "134"[ IBPRV S IB ER=IBER_"I B"_(250+IB PRV)_";" Q ; If req uired, set error and quit . D WARN("Taxo nomy for t he "_$P("r eferring^o perating^r endering^a ttending^s upervising ^^^^other" ,U,IBPRV)_ " provider has no va lue") ; El se, set wa rning . Q ; ; Check organizati ons. The f unction OR GTAX will set IBNOTA X to be a ; list of entities m issing tax onomy code s, if any (n, n^m, n ^m^p, ; wh ere each 1 is servic e facility , 2 is non -VA servic e facility and ; 3 i s billing provider. ; S IBNOTA X="" S IBT AXS=$$ORGT AX^IBCEF73 A(IBIFN,.I BNOTAX) I $L(IBNOTAX ) F Z=1:1: $L(IBNOTAX ,U) D . ; IB167 = Bi lling Prov ider taxon omy missin g. . ;I IB TAXREQ,$P( IBNOTAX,U, Z)=3 S IBE R=IBER_"IB 167;" Q ; MRD;IB*2.0 *516 - Alw ays requir ed. . I $P (IBNOTAX,U ,Z)=3 S IB ER=IBER_"I B167;" Q . ; MRD;IB* 2.0*516 - Remove war ning messa ge for mis sing taxon omy code f or lab or facility. . ; D WARN ("Taxonomy for the " _$P("Servi ce Facilit y^Non-VA S ervice Fac ility^Bill ing Provid er",U,$P(I BNOTAX,U,Z ))_" has n o value") ; Else, se t warning . Q ; Q ;V ALNDC(IBIF N,IBDFN) ; IB*2*363 - validate NDC# betw een PRESCR IPTION fil e (#52) ; and IB BIL L/CLAIMS P RESCRIPTIO N REFILL f ile (#362. 4) ; input - IBIFN = internal entry numb er of the billing re cord in th e BILL/CLA IMS file ( #399) ; IB DFN = inte rnal entry number of patient r ecord in t he PATIENT file (#2) N IBX,IBR XCOL ; cal l program that deter mines if N DC differe nces exist D VALNDC^ IBEFUNC3(I BIFN,IBDFN ,.IBRXCOL) Q:'$D(IBR XCOL) ; at least one RX on the IB record has an ND C discrepa ncy S IBX =0 F S IB X=$O(IBRXC OL(IBX)) Q :'IBX D W ARN("NDC# on Bill do es not equ al the NDC # on Rx "_ IBRXCOL(IB X)) Q ;PRI IDCHK ; Ch eck for re quired Pim arary ID ( SSN/EIN) ; If the pr ovider is on the cla im, he mus t have one ; N IBI, IBZ I $$TX MT^IBCEF4( IBIFN) D . D F^IBCEF ("N-ALL AT T/REND PRO V SSN/EI", "IBZ",,IBI FN) . S IB I="" F S IBI=$O(^DG CR(399,IBI FN,"PRV"," B",IBI)) Q :IBI="" D .. I $P(I BZ,U,IBI)= "" S IBER= IBER_$S(IB I=1:"IB151 ;",IBI=2:" IB152;",IB I=3!(IBI=4 ):"IB321;" ,IBI=5:"IB 153;",IBI= 9:"IB154;" ,1:"") Q ; RXNPI(IBIF N) ; check for multi ple pharma cy npi's o n the same bill N IB ORG,IBRXNP I,IBX,IBY S IBORG=$$ RXSITE^IBC EF73A(IBIF N,.IBORG) S IBX=0 F S IBX=$O( IBORG(IBX) ) Q:'IBX S IBY=0 F S IBY=$O( IBORG(IBX, IBY)) Q:'I BY S IBRX NPI(+IBORG (IBX,IBY)) ="" S (IBX ,IBY)=0 F S IBX=$O( IBRXNPI(IB X)) Q:'IBX S IBY=IB Y+1 I IBY> 1 D WARN(" Bill has p rescriptio ns resulti ng from "_ IBY_" diff erent NPI locations" ) Q ;ROICH K(IBIFN,IB DFN,IBINS) ; IB*2.0* 384 - chec k prescrip tions that contain t he ; SENSI TIVE DIAGN OSIS DRUG field #87 in the DRU G File #50 set to 1 against ; the Claims Tracking ROI file ( #356.25) t o see if a n ROI is o n file ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; IBDFN = IEN of the patient ; IBINS = I EN of the payer insu rance comp any (#36) ; OUTPUT - 0 = no er ror ; 1 = a prescri ption is s ensitive a nd there i s no ROI o n file ; N IBX,IBY0, IBRXIEN,IB DT,IBDRUG, ROIQ S ROI Q=0 S IBX= 0 F S IBX =$O(^IBA(3 62.4,"C",I BIFN,IBX)) Q:'IBX D .S IBY0=^ IBA(362.4, IBX,0),IBR XIEN=$P(IB Y0,U,5) I 'IBRXIEN Q .S IBDT=$ P(IBY0,U,3 ),IBDRUG=$ P(IBY0,U,4 ) .D ZERO^ IBRXUTL(IB DRUG) .I $ $SENS^IBNC PDR(IBDRUG ) D ; Sen sitive Dia gnosis Dru g - check for ROI .. I $$ROI^I BNCPDR4(IB DFN,IBDRUG ,IBINS,IBD T) Q ;ROI is on fil e .. D WAR N("ROI not on file f or prescri ption "_$$ RXAPI1^IBN CPUT1(IBRX IEN,.01,"E ")) .. S R OIQ=1ROICH KQ ; K ^TM P($J,"IBDR UG") Q ROI Q ;AMBCK(I BIFN) ; IB *2.0*432 - if ambula nce locati on defined , address must be de fined ; if there is anything e ntered in any of the address f ields (eit her p/up o r drop/off fields), than there needs to be: ; Add ress 1, St ate and ZI P unless t he State i s not a US state or possession , then zip code is n ot needed (CMS1500 o nly) ; inp ut - IBIFN = IEN of the Bill/C laims file (#399) ; OUTPUT - 0 = no erro r ; 1 = E rror ; N I BPAMB,IBDA MB,IBAMBR, IBCK S IBA MBR=0 Q:$$ INSPRF^IBC EF(IBIFN)' =0 IBAMBR S IBPAMB=$ G(^DGCR(39 9,IBIFN,"U 5")),IBDAM B=$G(^DGCR (399,IBIFN ,"U6")) S IBCK(5)=$$ NOPUNCT^IB CEF($P(IBP AMB,U,2,6) ,1),IBCK(6 )=$$NOPUNC T^IBCEF($P (IBDAMB,U, 1,6),1) I IBCK(5)="" ,IBCK(6)=" " Q IBAMBR ; at this point we know that at least o ne ambulan ce field h as data, s o check to see if al l have dat a I IBCK(5 )'="" F I= 2,4,5 I $P (IBPAMB,U, I)="" S IB AMBR=1 I I BCK(6)'="" F I=1,2,4 ,5 I $P(IB DAMB,U,I)= "" S IBAMB R=1 Q:IBAM BR=1 IBAMB R ; now ch eck zip co de. OK to be null if state is not a US P osession F I="IBPAMB ","IBDAMB" I $P(I,U, 5)'="",$P( $G(^DIC(5, $P(I,U,5), 0)),U,6)=1 ,$P(I,U,6) ="" S IBAM BR=1 Q IBA MBR ;COBAM T(IBIFN) ; IB*2.0*43 2 - IF the re is a CO B amt. it must equal the Total Claim Cha rge Amount ; input - IBIFN = I EN of the Bill/Claim s file (#3 99) ; OUTP UT - 0 = n o error ; 1 = Error ; Q:IBIFN ="" 0 Q:$P ($G(^DGCR( 399,IBIFN, "U4")),U)= "" 0 Q:+$P ($G(^DGCR( 399,IBIFN, "U1")),U)' =+$P($G(^D GCR(399,IB IFN,"U4")) ,U) 1 Q 0 ;COBMRA(IB IFN) ; IB* 2.0*432 - If there i s a 'COB t otal non-c overed amo unt' (File #399, Fiel d#260), ; Primary I nsurance m ust be Med icare that never wen t to Medic are, and t his must b e a 2ndary or tertia ry claim ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; OUTPUT - 0 = no error ; 1 = Error ; N IBP Q:I BIFN="" 0 Q:$P($G(^D GCR(399,IB IFN,"U4")) ,U)="" 0 S IBP=$P($G (^DGCR(399 ,IBIFN,"M1 ")),U,5) S :IBP="" IB P=IBIFN I $$WNRBILL^ IBEFUNC(IB IFN,1),$P( $G(^DGCR(3 99,IBP,"S" )),U,7)="" ,$$COBN^IB CEF(IBIFN) >1 Q 0 Q 1 ;COBSEC(I BIFN) ; IB *2.0*432 - If there is NOT a ' COB total non-covere d amount' (File#399, Field#260 ), ; and Primary In surance is Medicare that never went to M edicare, 2 ndary or t ertiary cl aim cannot be set to transmit ; input - IBIFN = IE N of the B ill/Claims file (#39 9) ; OUTPU T - 0 = no error ; 1 = Error ; N IBP Q: IBIFN="" 0 Q:$P($G(^ DGCR(399,I BIFN,"U4") ),U)'="" 0 Q:$$COBN^ IBCEF(IBIF N)<2 0 S I BP=$P($G(^ DGCR(399,I BIFN,"M1") ),U,5) S:I BP="" IBP= IBIFN I $$ WNRBILL^IB EFUNC(IBIF N,1),$P($G (^DGCR(399 ,IBP,"S")) ,U,7)="",$ P($G(^DGCR (399,IBIFN ,"TX")),U, 8)'=1 Q 1 Q 0 ;TMCK( IBIFN) ; I B*2.0*432 - Attachme nt Control Number - REQUIRED w hen Transm ission Met hod = BM, EL, EM, or FT ; inpu t - IBIFN = IEN of t he Bill/Cl aims file (#399) ; O UTPUT - 0 = no error ; 1 = Er ror ; N IB AC Q:IBIFN ="" 0 F I= 1,3 S IBAC (I)=$P($G( ^DGCR(399, IBIFN,"U8" )),U,I) Q: IBAC(3)="" 0 Q:IBAC( 1)'="" 0 Q :IBAC(3)=" AA" 0 Q 1 ;ACCK(IBIF N) ; IB*2. 0*432 If a ny of the loop info is present , then Rep ort Type & Transmiss ion Method req'd ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - 0 = no er ror ; 1 = Error ; N IBAC Q:IB IFN="" 0 F I=1:1:3 S IBAC(I)=$ P($G(^DGCR (399,IBIFN ,"U8")),U, I) ; All f ields null , no error I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" Q 0 ; Both req uired fiel ds complet e, no erro r I IBAC(2 )'="",IBAC (3)'="" Q 0 ; At thi s point, o ne of the 2 required fields ha s data and one does not, so er ror Q 1 ;L NTMCK(IBIF N) ; DEM;I B*2.0*432 - (Line Le vel) Attac hment Cont rol Number - REQUIRE D when Tra nsmission Method = B M, EL, EM, or FT ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - IBLNERR = 0 = no er ror ; IBL NERR = 1 = Error ; N IBAC,IBPR OCP,I,IBLN ERR S IBLN ERR=0 ; DE M;432 - In itialize e rror flag IBLNERR to '0' for n o errors. Q:IBIFN="" IBLNERR S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:IBLNE RR . Q:'($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,0))#10) ; DEM;432 - Node '0' is procedu re node. . Q:'($D(^D GCR(399,IB IFN,"CP",I BPROCP,1)) #10) ; DEM ;432 - Nod e '1' is l ine level Attachment Control f ields. . F I=1,3 S I BAC(I)=$P( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ),U,I) . I IBAC(3)=" " S IBLNER R=0 Q . I IBAC(1)'=" " S IBLNER R=0 Q . I (IBAC(3)=" AA") S IBL NERR=0 Q . S IBLNERR =1 . Q ; Q IBLNERR ; LNACCK(IBI FN) ; DEM; IB*2.0*432 (Line Lev el) If any of the lo op info is present, then Repor t Type & T ransmissio n Method r eq'd ; inp ut - IBIFN = IEN of the Bill/C laims file (#399) ; OUTPUT - I BLNERR = 0 = no erro r ; IBLNE RR = 1 = E rror ; N I BAC,IBPROC P,I,IBLNER R S IBLNER R=0 ; DEM; 432 - Init ialize err or flag IB LNERR to ' 0' for no errors. Q: IBIFN="" I BLNERR S I BPROCP=0 F S IBPROC P=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP)) Q:'I BPROCP D Q:IBLNERR . Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,0 ))#10) ; D EM;432 - N ode '0' is procedure node. . Q :'($D(^DGC R(399,IBIF N,"CP",IBP ROCP,1))#1 0) ; DEM;4 32 - Node '1' is lin e level At tachment C ontrol fie lds. . F I =1:1:3 S I BAC(I)=$P( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ),U,I) . ; All field s null, no error . I IBAC(1)=" ",IBAC(2)= "",IBAC(3) ="" S IBLN ERR=0 Q . ; Both req uired fiel ds complet e, no erro r . I IBAC (2)'="",IB AC(3)'="" S IBLNERR= 0 Q . ; At this poin t, one of the 2 requ ired field s has data and one d oes not, s o error . S IBLNERR= 1 . Q ; Q IBLNERR ; ;vd/Beginn ing of IB* 2*577 - Va lidate Lin e Level fo r NDCLNNDC CK(IBIFN) ;IB*2*577 (Line Leve l) The Uni ts and Uni ts/Basis o f Measurem ent fields are requi red if the NDC field is popula ted. ; INP UT - IBIFN = IEN of the Bill/C laims file (#399) ; OUTPUT - I BLNERR = 0 = no erro r ; IBLNER R = 1 = Er ror ; N IB AC,IBPROCP ,I,IBLNERR S IBLNERR =0 ; IB*2* 577 - Init ialize err or flag IB LNERR to ' 0' for no errors. Q: IBIFN="" I BLNERR S I BPROCP=0 F S IBPROC P=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP)) Q:'I BPROCP D Q:IBLNERR . Q:($$GE T1^DIQ(399 .0304,IBPR OCP_","_IB IFN_",","N DC","I")=" ") ; IB*2* 577 - No N DC Code . ; If there is an NDC Code, the n the UNIT S and UNIT S/BASIS OF MEASUREME NT are Req uired. . I $$GET1^DI Q(399.0304 ,IBPROCP_" ,"_IBIFN_" ,","UNITS/ BASIS OF M EASUREMENT ","I")="" S IBLNERR= 1 Q . I $$ GET1^DIQ(3 99.0304,IB PROCP_","_ IBIFN_",", "UNITS","I ")="" S IB LNERR=1 Q ;Units (Q uantity) i s required if there is an NDC Code. . Q ; Q IBLNER R ;vd/End of IB*2*57 7 | |
| 244 | ||
| 245 | MODIFY [#3 64.7, 941] to proper ly include the UNITS /BASIS OF MEASUREMEN T in the “ PRF” (Prof essional) Segment of the 837, piece 25. | |
| 246 | PIECE 25 Unit or Basis of Measuremen t Code 364.6[ 979] | |
| 247 | 364.7[94 1] 364.5[ 5] Le ngth=2 Max Lines =0 | |
| 248 | >Consta nt Value: "" | |
| 249 | Change the following code from this: | |
| 250 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("OUTPT", Z)) Q:'Z I | |
| 251 | $P(IBX SAVE("OUTP T",Z),U,16 )'="" S IB XDATA(Z)=" UN" | |
| 252 | ||
| 253 | To this: | |
| 254 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("OUTPT", Z)) Q:'Z I | |
| 255 | $P(IBX SAVE("OUTP T",Z),U,16 )'="" S I BXDATA(Z)= | |
| 256 | $P( IBXSAVE(“O UTPT”,Z),U ,17) I IBX DATA(Z)=”” S IBXDATA (Z)=”UN” | |
| 257 | ||
| 258 | MODIFY [#3 64.7, 1950 ] to prope rly includ e the UNIT S/BASIS OF MEASUREME NT in the “INS” (Ins titutional ) Segment of the 837 , piece 17 . | |
| 259 | PIECE 17 Unit or B asis of Me asurement Code 364.6[22 37] | |
| 260 | 364.7[1950 ] 364.5[5] Leng th=2 M ax Lines=0 | |
| 261 | >Constan t Value: "" | |
| 262 | ||
| 263 | Change the following code from this: | |
| 264 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("INPT",Z )) Q:'Z I | |
| 265 | $P(IBXSAVE ("INPT",Z) ,U,12)'="" S IBXDATA (Z)="UN" | |
| 266 | ||
| 267 | To this: | |
| 268 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("INPT",Z )) Q:'Z I | |
| 269 | $P(IBX SAVE(“INPT ”,Z),U,12) ’=”” S IBX DATA(Z)= | |
| 270 | $P(IBX SAVE(“INPT ”,Z),U,13) I IBXDATA (Z)=”” S I BXDATA(Z)= ”UN” | |
| 271 | ||
| 272 | ADD a new error code (“IB360”) to the Er ror Code f ile [#350. 8] for the line leve l check on NDC numbe r and the UNITS/BASI S OF MEASU REMENT and the UNITS fields. | |
| 273 | The Error Message sh ould be: “ Units & Un its/Basis of Measure ment are R equired if NDC Code exists.” | |
| 274 | (Refer to the INC350 8 module o f code in the new ^I BY577PR Pr e-Install Routine.) | |
| 275 | ||
| 276 | ADD the 36 4.7 file t o the buil d for all of the upd ated OUTPU T FORMATTE R entries. | |
| 277 | ||
| 278 | Edi t a Build PAGE 2 OF 5 | |
| 279 | Name: IB*2 .0*??? TYPE: SINGLE PAC KAGE | |
| 280 | ---------- ---------- ---------- ---------- ---------- ---------- ---------- --------- | |
| 281 | Fil e List (N ame or Num ber) | |
| 282 | DD Export Opt ions | |
| 283 | | |
| 284 | File: I B FORM FIE LD CONTENT | |
| 285 | | |
| 286 | Send F ull or Par tial DD... : FULL | |
| 287 | | |
| 288 | Update th e Data Dic tionary: N O Send Secu rity Code: NO | |
| 289 | | |
| 290 | Screen to Determine DD Update | |
| 291 | | |
| 292 | | |
| 293 | Dat a Comes Wi th File... : YES | |
| 294 | | |
| 295 | __________ __________ __________ __________ __________ __________ __________ _________ | |
| 296 | ||
| 297 | ||
| 298 | ||
| 299 | ||
| 300 | Name: IB*2 .0*??? TYPE: SINGLE PAC KAGE | |
| 301 | ---------- ---------- ---------- ---------- ---------- ---------- ---------- --------- | |
| 302 | Fil e List (N ame or Num ber) | |
| 303 | DD Export Opt ions | |
| 304 | Data Expor t Options | |
| 305 | | |
| 306 | Si te's Data: OVERWRITE | |
| 307 | | |
| 308 | Resolve Pointers: YES May User Over ride Data Update: NO | |
| 309 | | |
| 310 | Data List: | |
| 311 | | |
| 312 | Screen to Select Data | |
| 313 | I $$INC LUDE^IBY?? ?PR(7,Y) | |
| 314 | | |
| 315 | | |
| 316 | __________ __________ __________ __________ __________ __________ __________ _________ | |
| 317 | ||
| 318 | MODIFY the ^IBCEF11 and ^IBCF2 3A routine s to updat e the 837 and printe d CMS 1500 for the n ew UNITS/B ASIS OF ME ASUREMENT field. | |
| 319 | Routines | |
| 320 | Activities | |
| 321 | Routine Na me | |
| 322 | IBCEF11 | |
| 323 | Enhancemen t Category | |
| 324 | New | |
| 325 | Modify | |
| 326 | Delete | |
| 327 | No Change | |
| 328 | RTM | |
| 329 | ||
| 330 | Related Op tions | |
| 331 | None | |
| 332 | Related Ro utines | |
| 333 | Routines “ Called By” | |
| 334 | Routines “ Called” | |
| 335 | ||
| 336 | ||
| 337 | ||
| 338 | ||
| 339 | Data Dicti onary (DD) Reference s | |
| 340 | None | |
| 341 | Related Pr otocols | |
| 342 | None | |
| 343 | Related In tegration Control Re gistration s (ICRs) | |
| 344 | None | |
| 345 | Data Passi ng | |
| 346 | Input | |
| 347 | Output Re ference | |
| 348 | Both | |
| 349 | Global Re ference | |
| 350 | Local | |
| 351 | Input Attr ibute Name and Defin ition | |
| 352 | Name: | |
| 353 | Definition : | |
| 354 | Output Att ribute Nam e and Defi nition | |
| 355 | Name: | |
| 356 | Definition : | |
| 357 | Current Lo gic | |
| 358 | IBCEF11 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS - CONT ;30-JAN-96 ;;2.0;INT EGRATED BI LLING;**51 ,137,155,3 09,335,348 ,349,371,4 32,447,473 ,516**;21- MAR-94;Bui ld 123 ;;P er VA Dire ctive 6402 , this rou tine shoul d not be m odified. ; BOX24D(A,I B) ; Retur ns the lin es for box es 19-24 o f the CMS- 1500 displ ay ; IB = flag is 1 if only bo x 24 is ne eded Q $S( '$G(IB):"3 6",1:"44") _"^55" ;RC BOX() ; Re turns the lines for revenue co de boxes o f the UB-0 4 display Q "19^41" ;OUTPT(IBI FN,IBPRINT ) ; Return s an array of servic e line dat a from ; C MS-1500 bo x 24. Outp ut is in I BXDATA(n) ; IBPRINT = print fl ag 1: retu rn print f ields ; 0: return ED I fields ; Uses diag nosis arra y ^TMP("IB XSAVE",$J, "DX",IBIFN ,DIAG CODE )=SEQ # ; if it alre ady exists . If not, it builds it from N- DIAGNOSES element ; ; For EDI call: Retu rns IBXDAT A(n)= ; be gin date(Y YYYMMDD) ^ end date( YYYYMMDD) ^ pos ^ to s ^ ; proc code/reve nue code - if no pro cedure (no t the poin ters) ^ ; type of co de ^ dx po inter(s ) ^ unit cha rge ^ unit s ^ modifi ers separa ted by ; ; ^ purchas ed charge amount ^ a nesthesia minutes ^ emergency indicator ^ ; lab-ty pe service flag ^ ND C ^ Units ; ; Also R eturns IBX DATA(IBI," COB",COB,m ) with COB data for each line ; item fou nd in an a ccepted EO B for the bill and = the refer ence ; lin e in the f irst '^' p iece follo wed by the '0' node data of fi le ; 361.1 15 (LINE L EVEL ADJUS TMENTS) ; COB = COB sequence # of adjust ment's ins co, m = s eq # ; -- AND -- ; I BXDATA(IBI ,"COB",COB ,m,z,p)= ; the data on the '0' node for each subor dinate ent ry of file ; 361.115 11 (REASON S) (Only f irst 3 pie ces for 83 7 output) ; z = grou p code, so metimes pr eceeded by a space p = seq # ; ; For Pri nt call: R eturns beg in date(DD MMYYYY)^en d date(DDM MYYYY) or ; null if equal to b egin date^ pos^tos^be dsection n ame(if no procedure) ; or proc edure code (not the p ointer)^ . .. refer t o EDI call results ; Also, IBX DATA(n,"TE XT")=the t ext to pri nt on firs t line of box 24, ; If no proc edure code , returns IBXDATA(n, "A")=rev c ode abbrev ; ; For b oth calls, returns I BXDATA(n,i tem type,i tem ptr)=" " ; -- AND -- ; IBXD ATA(n,"RX" )=RX#^drug name^NDC^ refill #^( re)fill da te^qty^day s ; ^chrge ^ien of fi le 362.4^N DC format ; If line references a prescri ption ; -- AND -- ; If no reve nue code f or a presc ription, r eturns IBX DATA(n,"AR X")="" ; - - AND -- ; IBXDATA(n ,"AUX")='A UX' node o f the proc edure entr y ; ; Also returns I BXDATA(n," CPLNK") = soft link to corresp onding ent ry in PROC EDURES mul tiple of f ile 399 ; N IB,IBI,I BJ,IBFLD,I BDXI,IBXIE N,Z,IBXTRA ,IBRX,IBRX 0,IBRX1,Z0 ,Z1 ; K ^T MP($J,"IBI TEM") S ^T MP($J,"IBI TEM")="" ; Build dia gnosis arr ay if not already bu ilt I $O(^ TMP("IBXSA VE",$J,"DX ",IBIFN,"" ))="",$O(^ IBA(362.3, "AIFN"_IBI FN,"")) D .N Z,IBXDA TA D F^IBC EF("N-DIAG NOSES",,,I BIFN) .S Z ="" F S Z =$O(IBXDAT A(Z)) K:$O (IBXDATA(0 ))=""&(Z=" ") IBXDATA Q:Z="" S :$P(IBXDAT A(Z),U,2) ^TMP("IBXS AVE",$J,"D X",IBIFN,$ P(IBXDATA( Z),U,2))=Z ; S IB(0) =$G(^DGCR( 399,IBIFN, 0)),IB("U" )=$G(^("U" )),IB("U1" )=$G(^("U1 ")) S IBI= "" F S IB I=$O(^TMP( "IBXSAVE", $J,"DX",IB IFN,IBI)) Q:IBI="" S IBDXI(IB I)=^(IBI) I '$G(IBPR INT) D RVC E^IBCF23(I BIFN,IBIFN ) I $G(IBP RINT) D RV CE^IBCF23( ,IBIFN) ; Returns IB FLD(24) = begin date ^ end dat e ^ pos ^ tos ^ ; pr oc/bedsect ion/revenu e code ^ d x pointer ^ unit cha rge ^ ; un its ^ modi fiers ^ pu rchased ch arge amoun t ^ anesth esia minut es ^ ; eme rgency ind icator ^ s oft pointe r to PROCE DURES mult iple in fi le 399 ^ ; NDC ^ Uni ts ; IBFLD (24,n,type ,item)="" ; IBFLD(24 ,n_"A") = revenue co de abbrevi ation if n o procedur e ; IBFLD( 24,n,"AUX" ) = 'AUX' node of li ne item ; IBFLD(24, n,"RX") = soft point er to file 362.4 fro m 'item' f ld ; (can be null) ; D SET^IBC SC5A(IBIFN ,.IBRX) ;p rescriptio ns ; IBRX1 (ien 362.4 )=RX#^drug ien^NDC^r efil #^(re )fil date^ qty^days^c hrge I IBR X S IBRX=" " F S IBR X=$O(IBRX( IBRX)) Q:I BRX="" S IBRX0=0 F S IBRX0=$ O(IBRX(IBR X,IBRX0)) Q:'IBRX0 D . N IBRX H . S IBRX H=IBRX(IBR X,IBRX0) . ; **IB*2. 0*432** ad ded _U_$P( IBRXH,U,9) (Rx Date) to Output Formatter . S IBRX1 (+IBRXH)=I BRX_U_$P(I BRXH,U,2)_ U_$P(IBRXH ,U,5)_U_$P (IBRXH,U,7 )_U_IBRX0_ U_$P(IBRXH ,U,4)_U_$P (IBRXH,U,3 )_U_$P(IBR XH,U,6)_U_ +IBRXH_U_$ P(IBRXH,U, 8)_U_$P(IB RXH,U,9) K IBRX ; ; for EDI, r emove any $0 line it ems from t he IBFLD a rray befor e ; dropp ing down i nto the ne xt loop (I B*2*371) ; Start IB* 2.0*447 BI - Code re moved to a llow 0 dol lars to pr int. ;I '$ G(IBPRINT) D ;. NEW IBZ,IBI,Z ;. M IBZ=I BFLD K IBF LD ;. S (I BI,Z)=0 ;. F S IBI=$ O(IBZ(24,I BI)) Q:IBI '=+IBI D ; .. I $P(IB Z(24,IBI), U,7)*$P(IB Z(24,IBI), U,8)'>0 Q ;.. S Z=Z+ 1 ;.. M IB FLD(24,Z)= IBZ(24,IBI ) ;.. S IB FLD(24)=Z ;.. Q ;. Q ; End IB* 2.0*447 BI ; S IBI=0 F S IBI= $O(IBFLD(2 4,IBI)) Q: IBI'=+IBI D . S IBR X1=0 . S I BXDATA(IBI )=$P(IBFLD (24,IBI),U )_U_$P(IBF LD(24,IBI) ,U,$S($P(I BFLD(24,IB I),U,2)="" &'$G(IBPRI NT):1,1:2) ) . S $P(I BXDATA(IBI ),U,3,5)=$ P(IBFLD(24 ,IBI),U,3, 5) . S $P( IBXDATA(IB I),U,6)=$S ($D(IBFLD( 24,IBI_"X" )):"CJ",1: "HC") . S $P(IBXDATA (IBI),U,7, 13)=$P(IBF LD(24,IBI) ,U,6,12) . S $P(IBXD ATA(IBI),U ,14)=+$$IS LAB(IBXDAT A(IBI)) . ; MRD;IB*2 .0*516 - A dded NDC a nd Units t o line lev el of clai m, . ; pie ces 14 & 1 5 of IBFLD , pieces 1 5 & 16 of IBXDATA. P rint . ; i n Box 24 b y setting in IBXDATA (IBI,"TEXT "). . S $P (IBXDATA(I BI),U,15,1 6)=$P(IBFL D(24,IBI), U,14,15) . I $P(IBFL D(24,IBI), U,14)'="" S IBXDATA( IBI,"TEXT" )="N4"_$P( IBFLD(24,I BI),U,14)_ " UN"_$P(I BFLD(24,IB I),U,15) . ; . I $D( IBFLD(24,I BI,"RX")) D ;Rx .. S IBRX1=1 .. I $P($G (IBFLD(24, IBI,"AUX") ),U,8)'="" S $P(IBFL D(24,IBI," AUX"),U,8) ="",$P(IBF LD(24,IBI, "AUX"),U,9 )="" ;No free text allowed fo r rx's .. I $D(IBRX1 (+IBFLD(24 ,IBI,"RX") )) D Q ; Soft link exists ... D ZERO^IBR XUTL(+$P(I BRX1(+IBFL D(24,IBI," RX")),U,2) ) ... S IB XDATA(IBI, "RX")=IBRX 1(+IBFLD(2 4,IBI,"RX" )),$P(IBXD ATA(IBI,"R X"),U,2)=$ E($G(^TMP( $J,"IBDRUG ",+$P(IBRX 1(+IBFLD(2 4,IBI,"RX" )),U,2),.0 1)),1,30) ... K IBRX 1(+IBFLD(2 4,IBI,"RX" )) ... ; N o soft lin k - must f ind the fi rst Rx wit h the same charge .. S IBRX="" F S IBRX =$O(IBRX1( IBRX)) Q:' IBRX I +$ P(IBRX1(IB RX),U,8)=+ $P(IBXDATA (IBI),U,8) D Q ... D ZERO^IBR XUTL(+$P(I BRX1(IBRX) ,U,2)) ... S IBXDATA (IBI,"RX") =IBRX1(IBR X),$P(IBXD ATA(IBI,"R X"),U,2)=$ E($G(^TMP( $J,"IBDRUG ",+$P(IBRX 1(IBRX),U, 2),.01)),1 ,30) K IBR X1(IBRX) Q ... Q .. Q . ; . ; MRD;IB*2.0 *516 - If additional service l ine commen ts to appe ar in . ; Box 24, co ncatenate to front i f somethin g (NDC) is already t here. . I $G(IBFLD(2 4,IBI,"AUX "))'="" D .. I $G(IB PRINT),$P( IBFLD(24,I BI,"AUX"), U,8)'="" D ... I $G( IBXDATA(IB I,"TEXT")) '="" S IBX DATA(IBI," TEXT")=$E( $P(IBFLD(2 4,IBI,"AUX "),U,8)_" "_IBXDATA( IBI,"TEXT" ),1,59) .. . E S IBX DATA(IBI," TEXT")=$P( IBFLD(24,I BI,"AUX"), U,8) ... S $P(IBFLD( 24,IBI,"AU X"),U,8)=" " ... Q .. S IBXDATA (IBI,"AUX" )=IBFLD(24 ,IBI,"AUX" ) .. Q . ; . I $G(IB PRINT) D . . ; START IB*2.0*447 BI ZERO D OLLAR CHAN GES .. ; I '$P(IBXDA TA(IBI),U, 8),'$G(IBX DATA(IBI," RX")) D Q .. I $P(IB XDATA(IBI) ,U,8)="",' $G(IBXDATA (IBI,"RX") ) D Q ... ; END IB* 2.0*447 BI ZERO DOLL AR CHANGES ... I $G( IBNOSHOW) Q ; don 't show er rors/warni ngs ... S IBXDATA(IB I,"TEXT")= "Warning:* * REV CODE UNITS < # PROCEDURES , THEY MUS T BE =" .. . I $D(IBX DATA(IBI," AUX")) S $ P(IBXDATA( IBI,"AUX") ,U,9)="" . .. Q .. ; .. I $G(IB FLD(24,IBI _"A"))'="" D Q ... S IBXDATA( IBI,"A")=I BFLD(24,IB I_"A") ... I $G(IBNO SHOW) Q ; don't s how errors /warnings ... S IBXD ATA(IBI,"T EXT")="War ning:** RE V CODE UNI TS > #PROC EDURES, TH EY MUST BE =: "_IBFLD (24,IBI_"A ") ... I $ D(IBXDATA( IBI,"AUX") ) S $P(IBX DATA(IBI," AUX"),U,9) ="" ... Q .. ; .. S IBRX=$G(IB XDATA(IBI, "RX")) .. I IBRX'="" D ;Forma t Rx detai l ... N Z ... S Z=$P (IBRX,U) . .. S Z=$S( Z'="":"Rx# "_Z_" ",1: "RX: ") .. . S IBXDAT A(IBI,"TEX T")=Z_$S($ P(IBRX,U,3 )'="":"NDC : "_$P(IBR X,U,3),1:" NOC: "_$P( IBRX,U,2)) _" Qty: "_ $P(IBRX,U, 6)_" Days: "_$P(IBRX ,U,7) ... S $P(IBXDA TA(IBI,"AU X"),U,9)=" N4" ; se rvice line comment q ualifier f or RX's .. . Q .. Q . S IBXDATA (IBI,"CPLN K")=$P(IBF LD(24,IBI) ,U,13) . I '$G(IBPRI NT) D COBL INE^IBCEU6 (IBIFN,IBI ,.IBXDATA, ,.IBXTRA) . Q ; I $G (IBPRINT) D . S IBRX =0 F S IB RX=$O(IBRX 1(IBRX)) Q :'IBRX D .. S IBI=+ $O(IBXDATA (""),-1)+1 .. S IBXD ATA(IBI)=$ $DATE($P(I BRX1(IBRX) ,U,5)) .. S IBXDATA( IBI,"TEXT" )="**** ER ROR - NO P ROC LINK T O REV CODE FOR DRUG: RX#: "_$P (IBRX1(IBR X),U)_" ND C #: "_$P( IBRX1(IBRX ),U,3) .. I $D(IBXDA TA(IBI,"AU X")) S $P( IBXDATA(IB I,"AUX"),U ,9)="" .. S IBXDATA( IBI,"ARX") ="" .. D Z ERO^IBRXUT L(+$P(IBRX 1(IBRX),U, 2)) .. S I BXDATA(IBI ,"RX")=IBR X1(IBRX),$ P(IBXDATA( IBI,"RX"), U,2)=$E($G (^TMP($J," IBDRUG",+$ P(IBRX1(IB RX),U,2),. 01)),1,30) K IBRX1(I BRX) .. Q . Q ; I '$ G(IBPRINT) ,$D(IBXTRA ) D COMBO^ IBCEU2(.IB XDATA,.IBX TRA,0) ;Ha ndle bundl ed/unbundl ed lines K ^TMP($J," IBDRUG") Q ;ISLAB(LD ATA) ; Ret urns 0/1 i f line ite m data ind icates the item is a lab (1) ; 'LAB' is defined he re as type of servic e = 5 Q $E ($P(LDATA, U,4))="5" ;FMT(DATA, DLEN,FLEN) ; Returns a string in DATA wi th a max l ength of D LEN ; and a field le ngth of FL EN Q $E($E (DATA,1,DL EN)_$J("", FLEN),1,FL EN) ;DATE( X,DEL) ; R eturns FM date in X as MMxDDxY YYY where x=DEL S DE L=$G(DEL) S X=$$DATE ^IBCF2(X,1 ,1) I X'=" " S X=$E(X ,1,2)_DEL_ $E(X,3,4)_ DEL_$E(X,5 ,8) Q X ;B ATCH() ; S ets up rec ord for an d stores/r eturns the next batc h number N NUM,FAC,D O,DD,DLAYG O,DIC,X,Y ;Keep late st batch n umber for view/print edi bill extract da ta option I $D(IBVNU M) S NUM=I BVNUM G BA TCHQ ;Chec k for batc h resubmit - if yes, use same number as original b atch I $P( $G(^TMP("I BRESUBMIT" ,$J)),U,3) =1 S NUM=$ P(^($J),U) G BATCHQ L +^IBA(36 4.1,0):5 I '$T Q 0 S FAC=+$P($ $SITE^VASI TE(),U,3), NUM=$O(^IB A(364.1,"B ",""),-1) I $D(^IBA( 364.1,+NUM ,0)),$P(^( 0),U,2)="" F D Q:' NUM!($P($G (^IBA(364. 1,+NUM,0)) ,U,2)'="") . I $D(^I BA(364.1,N UM,0)) S D A=NUM,DIK= "^IBA(364. 1," D ^DIK . S NUM=$ O(^IBA(364 .1,"B","") ,-1) F S NUM=$S($P( NUM,FAC,2) '="":NUM+1 ,1:FAC_"00 00001") Q: '$D(^IBA(3 64.1,"B",N UM)) K DO, DD S DIC=" ^IBA(364.1 ,",DLAYGO= 364.1,DIC( 0)="L",X=N UM D FILE^ DICN K DD, DO I Y'>0 S NUM=0 L -^IBA(364. 1,0)BATCHQ Q NUM ;GE TLDAT(IBXI EN) ; Extr act data f or 837 tra nsmission LDAT recor d ; IBXIEN - ien in file 399 ; Sets up I BXSAVE("LD AT",n) arr ay: ; Atta chment rep ort type ^ Attachmen t report t ransmissio n code ^ A ttachment control nu mber ^ ; OB Anesthe sia Additi onal Units ^ Purchas e Service Provider I D ^ Purcha se Service Amount ^ N CPIEN,FT YPE,IBXDAT A,IDS,IBID S,NODE1,PS AMNT,PSPID ,Z,PCE1,LI NE I '+$G( IBXIEN) Q K IBXSAVE( "LDAT") S FTYPE=$$FT ^IBCEF(IBX IEN) I FTY PE=2 D OUT PT(IBXIEN, 0) I FTYPE =3 D HOS^I BCEF2(IBXI EN) D ALLI DS^IBCEFP( IBXIEN,.ID S,1) S (PS PID,PSAMNT )="" ; IB* 2.0*473/TA Z - Conver t PROVIDER code to f unction ca ll to PSID ^IBCEFP I $$SUB1OK^I BCEP8A(IBX IEN),(FTYP E=2) D . D PSID^IBCE FP(IBXIEN, .IDS,.IBID S) . S PSP ID=$G(IBID S(0)) I PS PID="" S P SPID=$P($G (IBIDS(1)) ,U,1) ;IB* 2.0*473/TA Z - END S Z=0 F S Z =$O(IBXDAT A(Z)) Q:'Z D . S CP IEN=+$G(IB XDATA(Z,"C PLNK")) ;I 'CPIEN Q . I FTYPE= 2,$$SUB1OK ^IBCEP8A(I BXIEN) S P SAMNT=$$DO LLAR^IBCEF G1($P($G(I BXDATA(Z)) ,U,11)) . S (PCE1,NO DE1)="" . I CPIEN D . . S NODE 1=$G(^DGCR (399,IBXIE N,"CP",CPI EN,1)) . . S PCE1=$$ GET1^DIQ(3 99.0304,CP IEN_","_IB XIEN_",",7 1) . . Q . ; MRD;IB* 2.0*516 - Added addl . procedur e descript ion as pie ce 7 . ; of IBXSAVE , which wi ll exist o nly if the procedure ends in ' 99' . ; or is an 'NO C/NOS' pro cedure. . S IBXSAVE( "LDAT",Z)= PCE1_U_$P( NODE1,U,3) _U_$P(NODE 1,U)_U_$P( NODE1,U,5) _U_$G(PSPI D)_U_$G(PS AMNT)_U_$P (NODE1,U,4 ) . Q Q | |
| 359 | Modified L ogic (Chan ges are in bold) | |
| 360 | IBCEF11 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS - CONT ;30-JAN-96 ;;2.0;INT EGRATED BI LLING;**51 ,137,155,3 09,335,348 ,349,371,4 32,447,473 ,516,577** ;21-MAR-94 ;Build 16 ;;Per VA D irective 6 402, this routine sh ould not b e modified . ;BOX24D( A,IB) ; Re turns the lines for boxes 19-2 4 of the C MS-1500 di splay ; IB = flag is 1 if only box 24 is needed Q $S('$G(IB) :"36",1:"4 4")_"^55" ;RCBOX() ; Returns t he lines f or revenue code boxe s of the U B-04 displ ay Q "19^4 1" ;OUTPT( IBIFN,IBPR INT) ; Ret urns an ar ray of ser vice line data from ; CMS-1500 box 24. O utput is i n IBXDATA( n) ; IBPRI NT = print flag 1: r eturn prin t fields ; 0: return EDI field s ; Uses d iagnosis a rray ^TMP( "IBXSAVE", $J,"DX",IB IFN,DIAG C ODE)=SEQ # ; if it a lready exi sts. If no t, it buil ds it from N-DIAGNOS ES element ; ; For E DI call: R eturns IBX DATA(n)= ; begin dat e(YYYYMMDD ) ^ end da te(YYYYMMD D) ^ pos ^ tos ^ ; p roc code/r evenue cod e - if no procedure (not the p ointers) ^ ; type of code ^ dx pointer(s ) ^ unit charge ^ u nits ^ mod ifiers sep arated by ; ; ^ purc hased char ge amount ^ anesthes ia minutes ^ emergen cy indicat or ^ ; lab -type serv ice flag ^ NDC ^ Uni ts/Quantit y ^ Unit/B asis of Me asurement (vd/IB*2*5 77) ; ; Al so Returns IBXDATA(I BI,"COB",C OB,m) with COB data for each l ine ; item found in an accepte d EOB for the bill a nd = the r eference ; line in t he first ' ^' piece f ollowed by the '0' n ode data o f file ; 3 61.115 (LI NE LEVEL A DJUSTMENTS ) ; COB = COB sequen ce # of ad justment's ins co, m = seq # ; -- AND -- ; IBXDATA (IBI,"COB" ,COB,m,z,p )= ; the d ata on the '0' node for each s ubordinate entry of file ; 361 .11511 (RE ASONS) (On ly first 3 pieces fo r 837 outp ut) ; z = group code , sometime s preceede d by a spa ce p = seq # ; ; For Print cal l: Returns begin dat e(DDMMYYYY )^end date (DDMMYYYY) or ; null if equal to begin d ate^pos^to s^bedsecti on name(if no proced ure) ; or procedure code(not t he pointer )^ ... ref er to EDI call resul ts ; Also, IBXDATA(n ,"TEXT")=t he text to print on first line of box 24 , ; If no procedure code, retu rns IBXDAT A(n,"A")=r ev code ab brev ; ; F or both ca lls, retur ns IBXDATA (n,item ty pe,item pt r)="" ; -- AND -- ; IBXDATA(n, "RX")=RX#^ drug name^ NDC^refill #^(re)fil l date^qty ^days ; ^c hrge^ien o f file 362 .4^NDC for mat ; If l ine refere nces a pre scription ; -- AND - - ; If no revenue co de for a p rescriptio n, returns IBXDATA(n ,"ARX")="" ; -- AND -- ; IBXDA TA(n,"AUX" )='AUX' no de of the procedure entry ; ; Also retur ns IBXDATA (n,"CPLNK" ) = soft l ink to cor responding entry in PROCEDURES multiple of file 39 9 ; N IB,I BI,IBJ,IBF LD,IBDXI,I BXIEN,Z,IB XTRA,IBRX, IBRX0,IBRX 1,Z0,Z1 ; K ^TMP($J, "IBITEM") S ^TMP($J, "IBITEM")= "" ; Build diagnosis array if not alread y built I $O(^TMP("I BXSAVE",$J ,"DX",IBIF N,""))="", $O(^IBA(36 2.3,"AIFN" _IBIFN,"") ) D .N Z,I BXDATA D F ^IBCEF("N- DIAGNOSES" ,,,IBIFN) .S Z="" F S Z=$O(IB XDATA(Z)) K:$O(IBXDA TA(0))=""& (Z="") IBX DATA Q:Z=" " S:$P(IB XDATA(Z),U ,2) ^TMP(" IBXSAVE",$ J,"DX",IBI FN,$P(IBXD ATA(Z),U,2 ))=Z ; S I B(0)=$G(^D GCR(399,IB IFN,0)),IB ("U")=$G(^ ("U")),IB( "U1")=$G(^ ("U1")) S IBI="" F S IBI=$O(^ TMP("IBXSA VE",$J,"DX ",IBIFN,IB I)) Q:IBI= "" S IBDX I(IBI)=^(I BI) I '$G( IBPRINT) D RVCE^IBCF 23(IBIFN,I BIFN) I $G (IBPRINT) D RVCE^IBC F23(,IBIFN ) ; Return s IBFLD(24 ) = begin date ^ end date ^ po s ^ tos ^ ; proc/bed section/re venue code ^ dx poin ter ^ unit charge ^ ; units ^ modifiers ^ purchase d charge a mount ^ an esthesia m inutes ^ ; emergency indicator ^ soft po inter to P ROCEDURES multiple i n file 399 ^ ; NDC ^ Units ; I BFLD(24,n, type,item) ="" ; IBFL D(24,n_"A" ) = revenu e code abb reviation if no proc edure ; IB FLD(24,n," AUX") = 'A UX' node o f line ite m ; IBFLD (24,n,"RX" ) = soft p ointer to file 362.4 from 'ite m' fld ; ( can be nul l) ; D SET ^IBCSC5A(I BIFN,.IBRX ) ;prescri ptions ; I BRX1(ien 3 62.4)=RX#^ drug ien^N DC^refil # ^(re)fil d ate^qty^da ys^chrge I IBRX S IB RX="" F S IBRX=$O(I BRX(IBRX)) Q:IBRX="" S IBRX0= 0 F S IBR X0=$O(IBRX (IBRX,IBRX 0)) Q:'IBR X0 D . N IBRXH . S IBRXH=IBRX (IBRX,IBRX 0) . ; **I B*2.0*432* * added _U _$P(IBRXH, U,9) (Rx D ate) to Ou tput Forma tter . S I BRX1(+IBRX H)=IBRX_U_ $P(IBRXH,U ,2)_U_$P(I BRXH,U,5)_ U_$P(IBRXH ,U,7)_U_IB RX0_U_$P(I BRXH,U,4)_ U_$P(IBRXH ,U,3)_U_$P (IBRXH,U,6 )_U_+IBRXH _U_$P(IBRX H,U,8)_U_$ P(IBRXH,U, 9) K IBRX ; ; for ED I, remove any $0 lin e items fr om the IBF LD array b efore ; d ropping do wn into th e next loo p (IB*2*37 1) ; Start IB*2.0*44 7 BI - Cod e removed to allow 0 dollars t o print. ; I '$G(IBPR INT) D ;. NEW IBZ,IB I,Z ;. M I BZ=IBFLD K IBFLD ;. S (IBI,Z)= 0 ;. F S I BI=$O(IBZ( 24,IBI)) Q :IBI'=+IBI D ;.. I $ P(IBZ(24,I BI),U,7)*$ P(IBZ(24,I BI),U,8)'> 0 Q ;.. S Z=Z+1 ;.. M IBFLD(24 ,Z)=IBZ(24 ,IBI) ;.. S IBFLD(24 )=Z ;.. Q ;. Q ; End IB*2.0*44 7 BI ; S I BI=0 F S IBI=$O(IBF LD(24,IBI) ) Q:IBI'=+ IBI D . S IBRX1=0 . S IBXDATA (IBI)=$P(I BFLD(24,IB I),U)_U_$P (IBFLD(24, IBI),U,$S( $P(IBFLD(2 4,IBI),U,2 )=""&'$G(I BPRINT):1, 1:2)) . S $P(IBXDATA (IBI),U,3, 5)=$P(IBFL D(24,IBI), U,3,5) . S $P(IBXDAT A(IBI),U,6 )=$S($D(IB FLD(24,IBI _"X")):"CJ ",1:"HC") . S $P(IBX DATA(IBI), U,7,13)=$P (IBFLD(24, IBI),U,6,1 2) . S $P( IBXDATA(IB I),U,14)=+ $$ISLAB(IB XDATA(IBI) ) . ; MRD; IB*2.0*516 - Added N DC and Uni ts to line level of claim, . ; pieces 14 & 15 of I BFLD, piec es 15 & 16 of IBXDAT A. Print . ; in Box 24 by sett ing in IBX DATA(IBI," TEXT"). . ;S $P(IBXD ATA(IBI),U ,15,16)=$P (IBFLD(24, IBI),U,14, 15) . ;I $ P(IBFLD(24 ,IBI),U,14 )'="" S IB XDATA(IBI, "TEXT")="N 4"_$P(IBFL D(24,IBI), U,14)_" UN "_$P(IBFLD (24,IBI),U ,15) . ; v d/IB*2*577 - Added U nit/Basis of Measure ment to li ne level o f claim, . ; piece 1 6 of IBFLD , piece 17 of IBXDAT A. . ; Pri nt in Box 24 by sett ing in IBX DATA(IBI," TEXT"). . S $P(IBXDA TA(IBI),U, 15,17)=$P( IBFLD(24,I BI),U,14,1 6) . I $P( IBFLD(24,I BI),U,14)' ="" S IBXD ATA(IBI,"T EXT")="N4" _$P(IBFLD( 24,IBI),U, 14)_" "_$P (IBFLD(24, IBI),U,16) _$P(IBFLD( 24,IBI),U, 15) . ; . I $D(IBFLD (24,IBI,"R X")) D ;R x .. S IBR X1=1 .. I $P($G(IBFL D(24,IBI," AUX")),U,8 )'="" S $P (IBFLD(24, IBI,"AUX") ,U,8)="",$ P(IBFLD(24 ,IBI,"AUX" ),U,9)="" ;No free text allow ed for rx' s .. I $D( IBRX1(+IBF LD(24,IBI, "RX"))) D Q ;Soft link exist s ...D ZER O^IBRXUTL( +$P(IBRX1( +IBFLD(24, IBI,"RX")) ,U,2)) ... S IBXDATA (IBI,"RX") =IBRX1(+IB FLD(24,IBI ,"RX")),$P (IBXDATA(I BI,"RX"),U ,2)=$E($G( ^TMP($J,"I BDRUG",+$P (IBRX1(+IB FLD(24,IBI ,"RX")),U, 2),.01)),1 ,30) ... K IBRX1(+IB FLD(24,IBI ,"RX")) .. . ; No sof t link - m ust find t he first R x with the same char ge .. S IB RX="" F S IBRX=$O(I BRX1(IBRX) ) Q:'IBRX I +$P(IBR X1(IBRX),U ,8)=+$P(IB XDATA(IBI) ,U,8) D Q ... D ZER O^IBRXUTL( +$P(IBRX1( IBRX),U,2) ) ... S IB XDATA(IBI, "RX")=IBRX 1(IBRX),$P (IBXDATA(I BI,"RX"),U ,2)=$E($G( ^TMP($J,"I BDRUG",+$P (IBRX1(IBR X),U,2),.0 1)),1,30) K IBRX1(IB RX) Q ... Q .. Q . ; . ; MRD;I B*2.0*516 - If addit ional serv ice line c omments to appear in . ; Box 2 4, concate nate to fr ont if som ething (ND C) is alre ady there. . I $G(IB FLD(24,IBI ,"AUX"))'= "" D .. I $G(IBPRINT ),$P(IBFLD (24,IBI,"A UX"),U,8)' ="" D ... I $G(IBXDA TA(IBI,"TE XT"))'="" S IBXDATA( IBI,"TEXT" )=$E($P(IB FLD(24,IBI ,"AUX"),U, 8)_" "_IBX DATA(IBI," TEXT"),1,5 9) ... E S IBXDATA( IBI,"TEXT" )=$P(IBFLD (24,IBI,"A UX"),U,8) ... S $P(I BFLD(24,IB I,"AUX"),U ,8)="" ... Q .. S IB XDATA(IBI, "AUX")=IBF LD(24,IBI, "AUX") .. Q . ; . I $G(IBPRINT ) D .. ; S TART IB*2. 0*447 BI Z ERO DOLLAR CHANGES . . ; I '$P( IBXDATA(IB I),U,8),'$ G(IBXDATA( IBI,"RX")) D Q .. I $P(IBXDATA (IBI),U,8) ="",'$G(IB XDATA(IBI, "RX")) D Q ... ; EN D IB*2.0*4 47 BI ZERO DOLLAR CH ANGES ... I $G(IBNOS HOW) Q ; don't sh ow errors/ warnings . .. S IBXDA TA(IBI,"TE XT")="Warn ing:** REV CODE UNIT S < #PROCE DURES, THE Y MUST BE =" ... I $ D(IBXDATA( IBI,"AUX") ) S $P(IBX DATA(IBI," AUX"),U,9) ="" ... Q .. ; .. I $G(IBFLD(2 4,IBI_"A") )'="" D Q ... S IBX DATA(IBI," A")=IBFLD( 24,IBI_"A" ) ... I $G (IBNOSHOW) Q ; do n't show e rrors/warn ings ... S IBXDATA(I BI,"TEXT") ="Warning: ** REV COD E UNITS > #PROCEDURE S, THEY MU ST BE=: "_ IBFLD(24,I BI_"A") .. . I $D(IBX DATA(IBI," AUX")) S $ P(IBXDATA( IBI,"AUX") ,U,9)="" . .. Q .. ; .. S IBRX= $G(IBXDATA (IBI,"RX") ) .. I IBR X'="" D ; Format Rx detail ... N Z ... S Z=$P(IBRX ,U) ... S Z=$S(Z'="" :"Rx#"_Z_" ",1:"RX: ") ... S I BXDATA(IBI ,"TEXT")=Z _$S($P(IBR X,U,3)'="" :"NDC: "_$ P(IBRX,U,3 ),1:"NOC: "_$P(IBRX, U,2))_" Qt y: "_$P(IB RX,U,6)_" Days: "_$P (IBRX,U,7) ... S $P( IBXDATA(IB I,"AUX"),U ,9)="N4" ; service line comm ent qualif ier for RX 's ... Q . . Q . S IB XDATA(IBI, "CPLNK")=$ P(IBFLD(24 ,IBI),U,13 ) . I '$G( IBPRINT) D COBLINE^I BCEU6(IBIF N,IBI,.IBX DATA,,.IBX TRA) . Q ; I $G(IBPR INT) D . S IBRX=0 F S IBRX=$O (IBRX1(IBR X)) Q:'IBR X D .. S IBI=+$O(IB XDATA(""), -1)+1 .. S IBXDATA(I BI)=$$DATE ($P(IBRX1( IBRX),U,5) ) .. S IBX DATA(IBI," TEXT")="** ** ERROR - NO PROC L INK TO REV CODE FOR DRUG: RX#: "_$P(IBRX 1(IBRX),U) _" NDC #: "_$P(IBRX1 (IBRX),U,3 ) .. I $D( IBXDATA(IB I,"AUX")) S $P(IBXDA TA(IBI,"AU X"),U,9)=" " .. S IBX DATA(IBI," ARX")="" . . D ZERO^I BRXUTL(+$P (IBRX1(IBR X),U,2)) . . S IBXDAT A(IBI,"RX" )=IBRX1(IB RX),$P(IBX DATA(IBI," RX"),U,2)= $E($G(^TMP ($J,"IBDRU G",+$P(IBR X1(IBRX),U ,2),.01)), 1,30) K IB RX1(IBRX) .. Q . Q ; I '$G(IBP RINT),$D(I BXTRA) D C OMBO^IBCEU 2(.IBXDATA ,.IBXTRA,0 ) ;Handle bundled/un bundled li nes K ^TMP ($J,"IBDRU G") Q ;ISL AB(LDATA) ; Returns 0/1 if lin e item dat a indicate s the item is a lab (1) ; 'LAB ' is defin ed here as type of s ervice = 5 Q $E($P(L DATA,U,4)) ="5" ;FMT( DATA,DLEN, FLEN) ; Re turns a st ring in DA TA with a max length of DLEN ; and a fie ld length of FLEN Q $E($E(DATA ,1,DLEN)_$ J("",FLEN) ,1,FLEN) ; DATE(X,DEL ) ; Return s FM date in X as MM xDDxYYYY w here x=DEL S DEL=$G( DEL) S X=$ $DATE^IBCF 2(X,1,1) I X'="" S X =$E(X,1,2) _DEL_$E(X, 3,4)_DEL_$ E(X,5,8) Q X ;BATCH( ) ; Sets u p record f or and sto res/return s the next batch num ber N NUM, FAC,DO,DD, DLAYGO,DIC ,X,Y ;Keep latest ba tch number for view/ print edi bill extra ct data op tion I $D( IBVNUM) S NUM=IBVNUM G BATCHQ ;Check for batch res ubmit - if yes, use same numbe r as origi nal batch I $P($G(^T MP("IBRESU BMIT",$J)) ,U,3)=1 S NUM=$P(^($ J),U) G BA TCHQ L +^I BA(364.1,0 ):5 I '$T Q 0 S FAC= +$P($$SITE ^VASITE(), U,3),NUM=$ O(^IBA(364 .1,"B","") ,-1) I $D( ^IBA(364.1 ,+NUM,0)), $P(^(0),U, 2)="" F D Q:'NUM!( $P($G(^IBA (364.1,+NU M,0)),U,2) '="") . I $D(^IBA(36 4.1,NUM,0) ) S DA=NUM ,DIK="^IBA (364.1," D ^DIK . S NUM=$O(^IB A(364.1,"B ",""),-1) F S NUM=$ S($P(NUM,F AC,2)'="": NUM+1,1:FA C_"0000001 ") Q:'$D(^ IBA(364.1, "B",NUM)) K DO,DD S DIC="^IBA( 364.1,",DL AYGO=364.1 ,DIC(0)="L ",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM =0 L -^IBA (364.1,0)B ATCHQ Q NU M ;GETLDAT (IBXIEN) ; Extract d ata for 83 7 transmis sion LDAT record ; I BXIEN - ie n in file 399 ; Sets up IBXSAV E("LDAT",n ) array: ; Attachmen t report t ype ^ Atta chment rep ort transm ission cod e ^ Attach ment contr ol number ^ ; OB An esthesia A dditional Units ^ Pu rchase Ser vice Provi der ID ^ P urchase Se rvice Amou nt ^ N CPI EN,FTYPE,I BXDATA,IDS ,IBIDS,NOD E1,PSAMNT, PSPID,Z,PC E1,LINE I '+$G(IBXIE N) Q K IBX SAVE("LDAT ") S FTYPE =$$FT^IBCE F(IBXIEN) I FTYPE=2 D OUTPT(IB XIEN,0) I FTYPE=3 D HOS^IBCEF2 (IBXIEN) D ALLIDS^IB CEFP(IBXIE N,.IDS,1) S (PSPID,P SAMNT)="" ; IB*2.0*4 73/TAZ - C onvert PRO VIDER code to functi on call to PSID^IBCE FP I $$SUB 1OK^IBCEP8 A(IBXIEN), (FTYPE=2) D . D PSID ^IBCEFP(IB XIEN,.IDS, .IBIDS) . S PSPID=$G (IBIDS(0)) I PSPID=" " S PSPID= $P($G(IBID S(1)),U,1) ;IB*2.0*4 73/TAZ - E ND S Z=0 F S Z=$O(I BXDATA(Z)) Q:'Z D . S CPIEN=+ $G(IBXDATA (Z,"CPLNK" )) ;I 'CPI EN Q . I F TYPE=2,$$S UB1OK^IBCE P8A(IBXIEN ) S PSAMNT =$$DOLLAR^ IBCEFG1($P ($G(IBXDAT A(Z)),U,11 )) . S (PC E1,NODE1)= "" . I CPI EN D . . S NODE1=$G( ^DGCR(399, IBXIEN,"CP ",CPIEN,1) ) . . S PC E1=$$GET1^ DIQ(399.03 04,CPIEN_" ,"_IBXIEN_ ",",71) . . Q . ; MR D;IB*2.0*5 16 - Added addl. pro cedure des cription a s piece 7 . ; of IB XSAVE, whi ch will ex ist only i f the proc edure ends in '99' . ; or is a n 'NOC/NOS ' procedur e. . S IBX SAVE("LDAT ",Z)=PCE1_ U_$P(NODE1 ,U,3)_U_$P (NODE1,U)_ U_$P(NODE1 ,U,5)_U_$G (PSPID)_U_ $G(PSAMNT) _U_$P(NODE 1,U,4) . Q Q | |
| 361 | ||
| 362 | ||
| 363 | Routines | |
| 364 | Activities | |
| 365 | Routine Na me | |
| 366 | IBCF23A | |
| 367 | Enhancemen t Category | |
| 368 | New | |
| 369 | Modify | |
| 370 | Delete | |
| 371 | No Change | |
| 372 | RTM | |
| 373 | ||
| 374 | Related Op tions | |
| 375 | None | |
| 376 | Related Ro utines | |
| 377 | Routines “ Called By” | |
| 378 | Routines “ Called” | |
| 379 | ||
| 380 | ||
| 381 | ||
| 382 | ||
| 383 | Data Dicti onary (DD) Reference s | |
| 384 | None | |
| 385 | Related Pr otocols | |
| 386 | None | |
| 387 | Related In tegration Control Re gistration s (ICRs) | |
| 388 | None | |
| 389 | Data Passi ng | |
| 390 | Input | |
| 391 | Output Re ference | |
| 392 | Both | |
| 393 | Global Re ference | |
| 394 | Local | |
| 395 | Input Attr ibute Name and Defin ition | |
| 396 | Name: | |
| 397 | Definition : | |
| 398 | Output Att ribute Nam e and Defi nition | |
| 399 | Name: | |
| 400 | Definition : | |
| 401 | Current Lo gic | |
| 402 | IBCF23A ;A LB/ARH - H CFA 1500 1 9-90 DATA - Split fr om IBCF23 ;12-JUN-93 ;;2.0;INT EGRATED BI LLING;**51 ,432,516,5 47**;21-MA R-94;Build 119 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ; ; $$INSTALD T^XPDUTL(I BPATCH,.IB ARY) - ICR 10141 ;B2 4 ; set in dividual e ntries in print arra y, externa l format ; IBAUX = a dditional data for E DI output ; IBRXF = array of R X procedur es N IBX,Z ,IBD1,IBD2 ,IBCPLINK S IBI=IBI+ 1,IBPROC=$ P(IBSS,U,2 ),IBD1=$$D ATE^IBCF23 (IBDT1),IB D2=$S(IBDT 1'=IBDT2:$ $DATE^IBCF 23(IBDT2), 1:"") I '$ D(IBXIEN) S IBD1=$E( IBD1,5,8)_ $E(IBD1,1, 4),IBD2=$E (IBD2,5,8) _$E(IBD2,1 ,4) S IBFL D(24,IBI)= IBD1_U_IBD 2_U_$P($G( ^IBE(353.1 ,+$P(IBSS, U,6),0)),U )_U_$P($G( ^IBE(353.2 ,+$P(IBSS, U,7),0)),U ) I +IBPRO C D . S IB FLD(24,IBI )=IBFLD(24 ,IBI)_U_$P ($$PRCD^IB CEF1(IBPRO C,1),U,2) S:$P(IBPRO C,";",2)'[ "ICPT" IBF LD(24,IBI_ "X")="" I 'IBPROC S IBFLD(24,I BI)=IBFLD( 24,IBI)_U_ $S('$D(IBX IEN):IBPRO C,1:+IBREV ),IBFLD(24 ,IBI_"A")= $P($G(^DGC R(399.2,+I BREV,0)),U ,2) I $D(I BRXF),IBCH ARG="" S I BFLD(24,IB I_"A")=$P( $G(^DGCR(3 99.2,+IBRE V,0)),U,2) S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$P(IBSS ,U,5)_U_IB CHARG_U_IB UNIT_U_$P( IBSS,U,8)_ U_$G(IBPCH G)_U_$G(IB MIN)_U_$G( IBEMG) I $ D(IBSS("L" )) S Z=0 F S Z=$O(I BSS("L",Z) ) Q:'Z S IBFLD(24,I BI,$P(IBSS ("L",Z),U) ,$P(IBSS(" L",Z),U,2) )=$G(IBFLD (24,IBI,$P (IBSS("L", Z),U),$P(I BSS("L",Z) ,U,2)))+1 S:$TR($G(I BAUX),U)'= "" IBFLD(2 4,IBI,"AUX ")=$G(IBAU X) S:$D(IB RXF) IBFLD (24,IBI,"R X")=IBRXF K IBPROC,I BSS("L") S IBCPLINK= $P(IBSS,U, $L(IBSS,U) ) S IBFLD( 24,IBI)=IB FLD(24,IBI )_U_IBCPLI NK ; MRD;I B*2.0*516 - Added ND C and Unit s to line level of c laim. I IB CPLINK'="" S $P(IBFL D(24,IBI), U,14,15)=$ TR($P($G(^ DGCR(399,I BIFN,"CP", IBCPLINK,1 )),U,7,8), "-") Q ;AU XOK(IBSS,I BSS1) ; Ch eck all ot her flds a re the sam e to combi ne procs ; IBSS = su bscript of IBCP to c heck for d ups to com bine - pas s by ref ; IBSS(IBSS ,"AUX-X",n ) = all th e previous ly extract ed line it ems for th e ; same s et of basi c data, bu t having d ifferent " AUX" data ; IBSS1 = the "AUX" data of th e current IBCP entry ; ; Retur ns entry # in IBSS a rray if ma tch found, or 0 if n o match ; Set the IB SS "AUX-X" node for no match N Z,Z0 S Z= 0 F S Z=$ O(IBSS(IBS S,"AUX-X", Z)) Q:'Z I IBSS1=IB SS(IBSS,"A UX-X",Z) Q I 'Z S Z0 =+$O(IBSS( IBSS,"AUX- X",""),-1) +1,IBSS(IB SS,"AUX-X" ,Z0)=IBSS1 Q +Z ;PRC ; Extract procedure data for HCFA 1500 ; IBRC(IBS S) = #rev codes with same bill ing criter ia (IBSS) ; IBLINK(' CP' ien,'R C' ien) = IBSS inclu ding modif iers,rx se q in pc 7, 8 ; IBLINK 1(IBSS, 'R C' ien) = auto (1)^ 'CP' ien ( soft link) ; ; proc array w/ch rg N IBPR, IBP S IBI= 0 F S IBI =$O(^DGCR( 399,IBIFN, "CP",IBI)) Q:'IBI S IBLN=^(IB I,0),IBAUX LN=$G(^("A UX")) D . N Z,Z0,Z1, Q1 . S IBP DT=$P(IBLN ,U,2) . S IBSS=$$IBS S(IBI,.IBD XI,IBLN) . S IBPO=$S ($P(IBLN,U ,4):+$P(IB LN,U,4),1: IBI+1000) ;Set print order . S IBCP(IBPO )=IBPDT_"^ "_IBSS,IBC P(IBPO,"AU X")=IBAUXL N . S IBCP (IBPO,"LNK ")=IBI . ; Rx . N IB Z,IBITEM . S IBZ=$S( $P(IBSS,U) :$P(IBSS,U ),1:"") . I IBZ'="", $D(IBLINKR X(IBZ,IBI) ) D Q:IBC HARG'="" . . S IBPO1= IBPO .. S IBITEM=+$O (IBLINKRX( IBZ,IBI,0) ),IBRV=$G( IBLINKRX(I BZ,IBI,IBI TEM)) .. Q :$S(IBRV=" ":1,1:'$G( IBRC(IBRV) )) .. S IB CHARG=$P(I BRV,U,6),I BRC(IBRV)= IBRC(IBRV) -1 .. S $P (IBCP(IBPO 1),U,9)=IB CHARG,IBCP (IBPO1,"RX ")=IBITEM K IBLINKRX (IBZ,IBI,I BITEM) . ; find chrg s directly linked to proc . S IBK=0 F S IBK=$O(IB LINK(IBI,I BK)) Q:'IB K S IBRV1 =IBLINK(IB I,IBK),IBR V=$P(IBRV1 ,U,1,6) I +IBRC(IBRV 1) D .. S IBCHARG=$P (IBRV,U,6) ,IBRC(IBRV 1)=IBRC(IB RV1)-1 .. I IBCHARG' ="" S $P(I BSS,U,8)=I BCHARG,IBC P(IBPO)=IB PDT_"^"_IB SS,IBPO=IB PO+.1 ; ; add chrgs associated with a pr oc (not a direct lin k) ; find chrg assoc iated with proc, if any (match proc,div, +/-basc) K IBP(0) F IBP=3,2 Q: $D(IBP(0)) S IBPO="" F S IBPO =$O(IBCP(I BPO)) Q:'I BPO I $P( IBCP(IBPO) ,U,9)="" D . S IBSS= $P(IBCP(IB PO),U,2,9) . S IBCHA RG="",(IBR V,IBSS)=$P (IBSS,U,1, IBP) F S IBRV=$O(IB RC(IBRV)) Q:$P(IBRV, U,1,IBP)'= IBSS S IB P(0)=0 I + IBRC(IBRV) D Q .. S IBCHARG=$ P(IBRV,U,6 ),IBRC(IBR V)=IBRC(IB RV)-1 .. I IBRC(IBRV ) S Z=0 F S Z=$O(IB CP(IBPO,Z) ) Q:'Z S IBRC(IBRV) =IBRC(IBRV )-1 . S $P (IBCP(IBPO ),U,9)=IBC HARG . I I BCHARG'="" S Z=$O(IB LINK1(IBRV ,0)) I Z S IBCP(IBPO ,"L",Z)=IB LINK1(IBRV ,Z) K IBLI NK1(IBRV,Z ) ; ; add chrgs not associated with a pr oc to firs t proc wit h no chrg ; Aggggh!! ! TP S IBP O="" F S IBPO=$O(IB CP(IBPO)) Q:'IBPO I $P(IBCP(I BPO),U,9)= "" D . S I BCHARG="", IBRV="^" F S IBRV=$ O(IBRC(IBR V)) Q:IBRV =""!+IBRV I +IBRC(I BRV) D Q .. S IBCHA RG=$P(IBRV ,U,6),IBRC (IBRV)=IBR C(IBRV)-1 .. S Z=$O( IBLINK1(IB RV,0)) I Z S IBCP(IB PO,"L",Z)= IBLINK1(IB RV,Z) K IB LINK1(IBRV ,Z) . S $P (IBCP(IBPO ),U,9)=IBC HARG ; QIB SS(IBI,IBD XI,IBLN) ; Creates i ndex seque nce for pr ocedure N IBPC,IBJ,I BSS,IBLPI, IBX,IBLPAR S (IBPC,I BLPI)=0 F IBJ=1,6,5, 0,9,10 S I BPC=IBPC+1 S:IBJ $P( IBSS,U,IBP C,IBPC+1)= ($P(IBLN,U ,IBJ)_U) S $P(IBSS,U ,7)=($$GET MOD^IBEFUN C(IBIFN,IB I)_U) ;Mod ifiers ;IB *547/TAZ - IBDXI not defined, use intern al DX poin ter I '$G( IBNWPTCH) F IBJ=11:1 :14 I $P(I BLN,U,IBJ) S $P(IBSS ,U,4)=$P(I BSS,U,4)_$ S(IBJ>11:" ,",1:"")_$ G(IBDXI(+$ P(IBLN,U,I BJ))) ; dx I $G(IBNW PTCH) F IB J=11:1:14 S IBX=$P(I BLN,U,IBJ) I IBX S $ P(IBSS,U,4 )=$P(IBSS, U,4)_$S(IB J>11:",",1 :"")_$G(IB DXI(IBX),I BX) ; dx S $P(IBSS,U ,10)=$P(IB LN,U,16),$ P(IBSS,U,9 )=$P(IBLN, U,19),$P(I BSS,U,11)= +$P(IBLN,U ,17) G:'$G (IBNWPTCH) IBSSX ;IB *547/TAZ - Add addit ional fiel ds for rol l-up compa re S $P(IB SS,U,21)=$ $GET1^DIQ( 399.0304,I BI_","_IBI FN_",","AS SOCIATED C LINIC","I" ) S $P(IBS S,U,22)=$$ GET1^DIQ(3 99.0304,IB I_","_IBIF N_",","TYP E OF SERVI CE","I") S $P(IBSS,U ,23)=$$GET 1^DIQ(399. 0304,IBI_" ,"_IBIFN_" ,","ATTACH MENT CONTR OL NUMBER" ,"I") S $P (IBSS,U,24 )=$$GET1^D IQ(399.030 4,IBI_","_ IBIFN_",", "NDC","I") S $P(IBSS ,U,25)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","PROC EDURE DESC RIPTION"," I") S $P(I BSS,U,26)= $$GET1^DIQ (399.0304, IBI_","_IB IFN_",","A DDITIONAL OB MINUTES ","I") ;Ad d Provider info in p ieces 41-4 9 M IBLPAR =^DGCR(399 ,IBIFN,"CP ",IBI,"LNP RV") F S IBLPI=$O(I BLPAR(IBLP I)) Q:'IBL PI S IBX= IBLPAR(IBL PI,0),$P(I BSS,U,40+I BX)=$TR(IB X,"^","~") K IBLPARI BSSX ; Q I BSS ;IBNWP TCH(IBIFN, IBPATCH) ; ;Checks t he date th e primary claim was 1st transm itted and returns 1 if the tra nsmitted d ate is aft er the pat ch ;refere nced in va riable IBP ATCH was r eleased. T his allows the MRA/E OBs return ing to rol l up proce dures the same ;way as they we nt out. Ot herwise th e order ch anges and the MRA/EO B won't ma tch up. ; N IBARY,IB IDT,IBPFN, IBEFN,IBBN ,IBX,IBBDT S IBX=0 I $$INSTALD T^XPDUTL(I BPATCH,.IB ARY) D ; ICR 10141 . S IBX=1 . S IBIDT= $O(IBARY(" ")) . ; Ge t Primary Bill Numbe r. This wi ll insure COB data i s consiste nt across all bills. . S IBPFN =$$GET1^DI Q(399,IBIF N_",","PRI MARY BILL #","I") I 'IBPFN S I BPFN=IBIFN . ; Find 1st Accept ed Entry ( A1, A2, or Z) of Pri mary Bill in EDI TRA NSMIT BILL FILE (364 ) to deter mine Batch Number . S (IBEFN,I BBN)=0 F S IBEFN=$O (^IBA(364, "B",IBPFN, IBEFN)) Q: 'IBEFN D I IBBN Q .. I ",A1, A2,Z,"'[(" ,"_$$GET1^ DIQ(364,IB EFN_",","T RANSMISSIO N STATUS", "I")_",") Q .. S IBB N=$$GET1^D IQ(364,IBE FN_",","BA TCH NUMBER ","I") . ; Retrieve t he date th e batch wa s 1st sent . If IBBN= "" IBBDT w ill be nul l . S IBBD T=$$GET1^D IQ(364.1,$ $GET1^DIQ( 364,IBBN_" ,","BATCH NUMBER","I ")_",","DA TE FIRST S ENT","I") . I IBBDT, (IBBDT<IBI DT) S IBX= 0 Q IBX | |
| 403 | Modified L ogic (Chan ges are in bold) | |
| 404 | IBCF23A ;A LB/ARH - H CFA 1500 1 9-90 DATA - Split fr om IBCF23 ;12-JUN-93 ;;2.0;INT EGRATED BI LLING;**51 ,432,516,5 47,577**;2 1-MAR-94;B uild 16 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; ; $$INST ALDT^XPDUT L(IBPATCH, .IBARY) - ICR 10141 ;B24 ; set individua l entries in print a rray, exte rnal forma t ; IBAUX = addition al data fo r EDI outp ut ; IBRXF = array o f RX proce dures N IB X,Z,IBD1,I BD2,IBCPLI NK S IBI=I BI+1,IBPRO C=$P(IBSS, U,2),IBD1= $$DATE^IBC F23(IBDT1) ,IBD2=$S(I BDT1'=IBDT 2:$$DATE^I BCF23(IBDT 2),1:"") I '$D(IBXIE N) S IBD1= $E(IBD1,5, 8)_$E(IBD1 ,1,4),IBD2 =$E(IBD2,5 ,8)_$E(IBD 2,1,4) S I BFLD(24,IB I)=IBD1_U_ IBD2_U_$P( $G(^IBE(35 3.1,+$P(IB SS,U,6),0) ),U)_U_$P( $G(^IBE(35 3.2,+$P(IB SS,U,7),0) ),U) I +IB PROC D . S IBFLD(24, IBI)=IBFLD (24,IBI)_U _$P($$PRCD ^IBCEF1(IB PROC,1),U, 2) S:$P(IB PROC,";",2 )'["ICPT" IBFLD(24,I BI_"X")="" I 'IBPROC S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$S('$D( IBXIEN):IB PROC,1:+IB REV),IBFLD (24,IBI_"A ")=$P($G(^ DGCR(399.2 ,+IBREV,0) ),U,2) I $ D(IBRXF),I BCHARG="" S IBFLD(24 ,IBI_"A")= $P($G(^DGC R(399.2,+I BREV,0)),U ,2) S IBFL D(24,IBI)= IBFLD(24,I BI)_U_$P(I BSS,U,5)_U _IBCHARG_U _IBUNIT_U_ $P(IBSS,U, 8)_U_$G(IB PCHG)_U_$G (IBMIN)_U_ $G(IBEMG) I $D(IBSS( "L")) S Z= 0 F S Z=$ O(IBSS("L" ,Z)) Q:'Z S IBFLD(2 4,IBI,$P(I BSS("L",Z) ,U),$P(IBS S("L",Z),U ,2))=$G(IB FLD(24,IBI ,$P(IBSS(" L",Z),U),$ P(IBSS("L" ,Z),U,2))) +1 S:$TR($ G(IBAUX),U )'="" IBFL D(24,IBI," AUX")=$G(I BAUX) S:$D (IBRXF) IB FLD(24,IBI ,"RX")=IBR XF K IBPRO C,IBSS("L" ) S IBCPLI NK=$P(IBSS ,U,$L(IBSS ,U)) S IBF LD(24,IBI) =IBFLD(24, IBI)_U_IBC PLINK ; MR D;IB*2.0*5 16 - Added NDC and U nits to li ne level o f claim. ; I IBCPLINK '="" S $P( IBFLD(24,I BI),U,14,1 5)=$TR($P( $G(^DGCR(3 99,IBIFN," CP",IBCPLI NK,1)),U,7 ,8),"-") ; vd/Beginn ing of IB* 2*577 - Ad ded Unit/B asis of Me asurment t o line lev el of clai m. I IBCPL INK'="" S $P(IBFLD(2 4,IBI),U,1 4,16)=$TR( $P($G(^DGC R(399,IBIF N,"CP",IBC PLINK,1)), U,7,8),"-" )_U_$P($G( ^DGCR(399, IBIFN,"CP" ,IBCPLINK, 2)),U) ; v d/End of I B*2*577 Q ;AUXOK(IBS S,IBSS1) ; Check all other fld s are the same to co mbine proc s ; IBSS = subscript of IBCP t o check fo r dups to combine - pass by re f ; IBSS(I BSS,"AUX-X ",n) = all the previ ously extr acted line items for the ; sam e set of b asic data, but havin g differen t "AUX" da ta ; IBSS1 = the "AU X" data of the curre nt IBCP en try ; ; Re turns entr y # in IBS S array if match fou nd, or 0 i f no match ; Set the IBSS "AUX -X" node f or no matc h N Z,Z0 S Z=0 F S Z=$O(IBSS( IBSS,"AUX- X",Z)) Q:' Z I IBSS1 =IBSS(IBSS ,"AUX-X",Z ) Q I 'Z S Z0=+$O(IB SS(IBSS,"A UX-X",""), -1)+1,IBSS (IBSS,"AUX -X",Z0)=IB SS1 Q +Z ; PRC ; Extr act proced ure data f or HCFA 15 00 ; IBRC( IBSS) = #r ev codes w ith same b illing cri teria (IBS S) ; IBLIN K('CP' ien ,'RC' ien) = IBSS in cluding mo difiers,rx seq in pc 7,8 ; IBL INK1(IBSS, 'RC' ien) = auto (1 )^ 'CP' ie n (soft li nk) ; ; pr oc array w /chrg N IB PR,IBP S I BI=0 F S IBI=$O(^DG CR(399,IBI FN,"CP",IB I)) Q:'IBI S IBLN=^ (IBI,0),IB AUXLN=$G(^ ("AUX")) D . N Z,Z0, Z1,Q1 . S IBPDT=$P(I BLN,U,2) . S IBSS=$$ IBSS(IBI,. IBDXI,IBLN ) . S IBPO =$S($P(IBL N,U,4):+$P (IBLN,U,4) ,1:IBI+100 0) ;Set pr int order . S IBCP(I BPO)=IBPDT _"^"_IBSS, IBCP(IBPO, "AUX")=IBA UXLN . S I BCP(IBPO," LNK")=IBI . ; Rx . N IBZ,IBITE M . S IBZ= $S($P(IBSS ,U):$P(IBS S,U),1:"") . I IBZ'= "",$D(IBLI NKRX(IBZ,I BI)) D Q: IBCHARG'=" " .. S IBP O1=IBPO .. S IBITEM= +$O(IBLINK RX(IBZ,IBI ,0)),IBRV= $G(IBLINKR X(IBZ,IBI, IBITEM)) . . Q:$S(IBR V="":1,1:' $G(IBRC(IB RV))) .. S IBCHARG=$ P(IBRV,U,6 ),IBRC(IBR V)=IBRC(IB RV)-1 .. S $P(IBCP(I BPO1),U,9) =IBCHARG,I BCP(IBPO1, "RX")=IBIT EM K IBLIN KRX(IBZ,IB I,IBITEM) . ; find c hrgs direc tly linked to proc . S IBK=0 F S IBK=$O (IBLINK(IB I,IBK)) Q: 'IBK S IB RV1=IBLINK (IBI,IBK), IBRV=$P(IB RV1,U,1,6) I +IBRC(I BRV1) D .. S IBCHARG =$P(IBRV,U ,6),IBRC(I BRV1)=IBRC (IBRV1)-1 .. I IBCHA RG'="" S $ P(IBSS,U,8 )=IBCHARG, IBCP(IBPO) =IBPDT_"^" _IBSS,IBPO =IBPO+.1 ; ; add chr gs associa ted with a proc (not a direct link) ; fi nd chrg as sociated w ith proc, if any (ma tch proc,d iv,+/-basc ) K IBP(0) F IBP=3,2 Q:$D(IBP( 0)) S IBPO ="" F S I BPO=$O(IBC P(IBPO)) Q :'IBPO I $P(IBCP(IB PO),U,9)=" " D . S IB SS=$P(IBCP (IBPO),U,2 ,9) . S IB CHARG="",( IBRV,IBSS) =$P(IBSS,U ,1,IBP) F S IBRV=$O (IBRC(IBRV )) Q:$P(IB RV,U,1,IBP )'=IBSS S IBP(0)=0 I +IBRC(IB RV) D Q . . S IBCHAR G=$P(IBRV, U,6),IBRC( IBRV)=IBRC (IBRV)-1 . . I IBRC(I BRV) S Z=0 F S Z=$O (IBCP(IBPO ,Z)) Q:'Z S IBRC(IB RV)=IBRC(I BRV)-1 . S $P(IBCP(I BPO),U,9)= IBCHARG . I IBCHARG' ="" S Z=$O (IBLINK1(I BRV,0)) I Z S IBCP(I BPO,"L",Z) =IBLINK1(I BRV,Z) K I BLINK1(IBR V,Z) ; ; a dd chrgs n ot associa ted with a proc to f irst proc with no ch rg ; Agggg h!!! TP S IBPO="" F S IBPO=$O (IBCP(IBPO )) Q:'IBPO I $P(IBC P(IBPO),U, 9)="" D . S IBCHARG= "",IBRV="^ " F S IBR V=$O(IBRC( IBRV)) Q:I BRV=""!+IB RV I +IBR C(IBRV) D Q .. S IB CHARG=$P(I BRV,U,6),I BRC(IBRV)= IBRC(IBRV) -1 .. S Z= $O(IBLINK1 (IBRV,0)) I Z S IBCP (IBPO,"L", Z)=IBLINK1 (IBRV,Z) K IBLINK1(I BRV,Z) . S $P(IBCP(I BPO),U,9)= IBCHARG ; QIBSS(IBI, IBDXI,IBLN ) ; Create s index se quence for procedure N IBPC,IB J,IBSS,IBL PI,IBX,IBL PAR S (IBP C,IBLPI)=0 F IBJ=1,6 ,5,0,9,10 S IBPC=IBP C+1 S:IBJ $P(IBSS,U, IBPC,IBPC+ 1)=($P(IBL N,U,IBJ)_U ) S $P(IBS S,U,7)=($$ GETMOD^IBE FUNC(IBIFN ,IBI)_U) ; Modifiers ;IB*547/TA Z - IBDXI not define d, use int ernal DX p ointer I ' $G(IBNWPTC H) F IBJ=1 1:1:14 I $ P(IBLN,U,I BJ) S $P(I BSS,U,4)=$ P(IBSS,U,4 )_$S(IBJ>1 1:",",1:"" )_$G(IBDXI (+$P(IBLN, U,IBJ))) ; dx I $G(I BNWPTCH) F IBJ=11:1: 14 S IBX=$ P(IBLN,U,I BJ) I IBX S $P(IBSS, U,4)=$P(IB SS,U,4)_$S (IBJ>11:", ",1:"")_$G (IBDXI(IBX ),IBX) ; d x S $P(IBS S,U,10)=$P (IBLN,U,16 ),$P(IBSS, U,9)=$P(IB LN,U,19),$ P(IBSS,U,1 1)=+$P(IBL N,U,17) G: '$G(IBNWPT CH) IBSSX ;IB*547/TA Z - Add ad ditional f ields for roll-up co mpare S $P (IBSS,U,21 )=$$GET1^D IQ(399.030 4,IBI_","_ IBIFN_",", "ASSOCIATE D CLINIC", "I") S $P( IBSS,U,22) =$$GET1^DI Q(399.0304 ,IBI_","_I BIFN_","," TYPE OF SE RVICE","I" ) S $P(IBS S,U,23)=$$ GET1^DIQ(3 99.0304,IB I_","_IBIF N_",","ATT ACHMENT CO NTROL NUMB ER","I") S $P(IBSS,U ,24)=$$GET 1^DIQ(399. 0304,IBI_" ,"_IBIFN_" ,","NDC"," I") S $P(I BSS,U,25)= $$GET1^DIQ (399.0304, IBI_","_IB IFN_",","P ROCEDURE D ESCRIPTION ","I") S $ P(IBSS,U,2 6)=$$GET1^ DIQ(399.03 04,IBI_"," _IBIFN_"," ,"ADDITION AL OB MINU TES","I") ;Add Provi der info i n pieces 4 1-49 M IBL PAR=^DGCR( 399,IBIFN, "CP",IBI," LNPRV") F S IBLPI=$ O(IBLPAR(I BLPI)) Q:' IBLPI S I BX=IBLPAR( IBLPI,0),$ P(IBSS,U,4 0+IBX)=$TR (IBX,"^"," ~") K IBLP ARIBSSX ; Q IBSS ;IB NWPTCH(IBI FN,IBPATCH ) ; ;Check s the date the prima ry claim w as 1st tra nsmitted a nd returns 1 if the transmitte d date is after the patch ;ref erenced in variable IBPATCH wa s released . This all ows the MR A/EOBs ret urning to roll up pr ocedures t he same ;w ay as they went out. Otherwise the order changes a nd the MRA /EOB won't match up. ; N IBARY ,IBIDT,IBP FN,IBEFN,I BBN,IBX,IB BDT S IBX= 0 I $$INST ALDT^XPDUT L(IBPATCH, .IBARY) D ;ICR 101 41 . S IBX =1 . S IBI DT=$O(IBAR Y("")) . ; Get Prima ry Bill Nu mber. This will insu re COB dat a is consi stent acro ss all bil ls. . S IB PFN=$$GET1 ^DIQ(399,I BIFN_","," PRIMARY BI LL #","I") I 'IBPFN S IBPFN=IB IFN . ; Fi nd 1st Acc epted Entr y (A1, A2, or Z) of Primary Bi ll in EDI TRANSMIT B ILL FILE ( 364) to de termine Ba tch Number . S (IBEF N,IBBN)=0 F S IBEFN =$O(^IBA(3 64,"B",IBP FN,IBEFN)) Q:'IBEFN D I IBBN Q .. I ", A1,A2,Z,"' [(","_$$GE T1^DIQ(364 ,IBEFN_"," ,"TRANSMIS SION STATU S","I")_", ") Q .. S IBBN=$$GET 1^DIQ(364, IBEFN_",", "BATCH NUM BER","I") . ;Retriev e the date the batch was 1st s ent. If IB BN="" IBBD T will be null . S I BBDT=$$GET 1^DIQ(364. 1,$$GET1^D IQ(364,IBB N_",","BAT CH NUMBER" ,"I")_",", "DATE FIRS T SENT","I ") . I IBB DT,(IBBDT< IBIDT) S I BX=0 Q IBX | |
| 405 | ||
| 406 | MODIFY the ^IBCEF22 routines t o update t he printed UB-04 for the new U NITS/BASIS OF MEASUR EMENT fiel d. | |
| 407 | Routines | |
| 408 | Activities | |
| 409 | Routine Na me | |
| 410 | IBCEF22 | |
| 411 | Enhancemen t Category | |
| 412 | New | |
| 413 | Modify | |
| 414 | Delete | |
| 415 | No Change | |
| 416 | RTM | |
| 417 | ||
| 418 | Related Op tions | |
| 419 | None | |
| 420 | Related Ro utines | |
| 421 | Routines “ Called By” | |
| 422 | Routines “ Called” | |
| 423 | ||
| 424 | ||
| 425 | ||
| 426 | ||
| 427 | Data Dicti onary (DD) Reference s | |
| 428 | None | |
| 429 | Related Pr otocols | |
| 430 | None | |
| 431 | Related In tegration Control Re gistration s (ICRs) | |
| 432 | None | |
| 433 | Data Passi ng | |
| 434 | Input | |
| 435 | Output Re ference | |
| 436 | Both | |
| 437 | Global Re ference | |
| 438 | Local | |
| 439 | Input Attr ibute Name and Defin ition | |
| 440 | Name: | |
| 441 | Definition : | |
| 442 | Output Att ribute Nam e and Defi nition | |
| 443 | Name: | |
| 444 | Definition : | |
| 445 | Current Lo gic | |
| 446 | IBCEF22 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS ;06-FEB -96 ;;2.0; INTEGRATED BILLING;* *51,137,13 5,155,309, 349,389,43 2,488,516* *;21-MAR-9 4;Build 12 3 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; ; OV ERFLOW FRO M ROUTINE IBCEF2HOS( IBIFN) ; E xtract rev codes for episode b illed on a UB-04 int o IBXDATA ; IBIFN = bill ien ; Format: I BXDATA(n) = ; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charg e ; ^ tot uncov ^ FL 49 value ; ^ ien of rev code m ultiple en try(s) (se parated by ";") ; ^ modifiers specific t o rev code /proc (sep arated by ",") ; ^ r ev code da te, if it can be det ermined by a corresp onding pro c ; ^ NDC from "CP" node of cl aim ^ Unit s from "CP " node ; ; Also Retu rns IBXDAT A(IBI,"COB ",COB,m) w ith COB da ta for eac h line ; i tem found in an acce pted EOB f or the bil l and = th e referenc e ; line i n the firs t '^' piec e followed by the '0 ' node of file ; 361 .115 (LINE LEVEL ADJ USTMENTS) ; COB = CO B seq # of adjustmen t's ins co , m = seq # ; -- AND -- ; IBXD ATA(IBI,"C OB",COB,m, z,p)= ; th e '0' node for each subordinat e entry of file ; 36 1.11511 (R EASONS) (O nly first 3 pieces f or 837) ; z = group code, some times prec eeded by a space p = seq # ; ; -- AND -- ; IBXDATA (n,"CPLNK" ) = soft l ink to cor responding entry in PROCEDURES multiple of file 39 9 ; N IBDA ,IBCOMB,IB INPAT,IBLN ,IBX,IBY,I BZ,IBS,IBS S,IBXTRA,I BX1,IBXS,I BP,IBPO,IB P1,IBDEF,Z ,Z0,Z1,ZX, QQ,IBMOD,L ST S IBINP AT=$$INPAT ^IBCEF(IBI FN,1) I 'I BINPAT D F ^IBCEF("N- STATEMENT COVERS FRO M DATE","I BZ",,IBIFN ) S IBDEF= $G(IBZ),LS T="" ; ; L oop throug h lines of claim ben eath ^DGCR (399,IBIFN ,"CP") and build ; t he array I BP to be u sed below. ; IBP(Pro cedure ^ M odifiers, Print Orde r, Line#) = Procedur e Date ; S IBDA=0 F S IBDA=$O (^DGCR(399 ,IBIFN,"CP ",IBDA)) Q :'IBDA S IBZ=$G(^(I BDA,0)) I IBZ D . S IBP(+$P(IB Z,U)_U_$$G ETMOD^IBEF UNC(IBIFN, IBDA,1),$S ($P(IBZ,U, 4):$P(IBZ, U,4),1:999 ),IBDA)=$P (IBZ,U,2) ; ; Loop t hrough the revenue c odes benea th ^DGCR(3 99,IBIFN," RC") and ; build the array IBX to be use d below. ; IBX(" "_R evenue Cod e, Print O rder, Reve nue Line#) = ; ^DGCR (399.2, Re venue Code IEN, 0) ; IBX(" "_R evenue Cod e, Print O rder, Reve nue Line#, "DT") = P rocedure D ate ; IBX( " "_Revenu e Code, Pr int Order, Revenue L ine#, "MOD ") = Modif iers ; S I BDA=0 F S IBDA=$O(^ DGCR(399,I BIFN,"RC", IBDA)) Q:' IBDA S IB Z=$G(^(IBD A,0)) I IB Z S IBMOD= "" D . S I BX=$G(^DGC R(399.2,+I BZ,0)),IBX 1="",IBPO= 0 . ; Auto -added pro cedure cha rge . I $P (IBZ,U,10) =4,$P(IBZ, U,11) D ; Soft link to proc . . S Z=$G(^ DGCR(399,I BIFN,"CP", $P(IBZ,U,1 1),0)) .. Q:Z="" .. S ZX=+Z_U_ $$GETMOD^I BEFUNC(IBI FN,$P(IBZ, U,11),1) . . Q:'$O(IB P(ZX,0))&' $O(IBP1(ZX ,0)) .. I $P(IBZ,U,6 ) Q:$S($P( Z,U)'["ICP T":1,1:+$P (Z,U)'=$P( IBZ,U,6)) .. S Z0=$S ($D(IBP(ZX )):$O(IBP( ZX,0)),1:$ O(IBP1(ZX, 0))) .. S: 'Z0 Z0=999 .. Q:'$D( IBP(ZX,+Z0 ,$P(IBZ,U, 11)))&'$D( IBP1(ZX,+Z 0,$P(IBZ,U ,11))) .. I '$D(IBP1 (ZX,+Z0,$P (IBZ,U,11) )) S IBP1( ZX,+Z0,$P( IBZ,U,11)) =IBP(ZX,+Z 0,$P(IBZ,U ,11)) K IB P(ZX,+Z0,$ P(IBZ,U,11 )) .. S IB X1=$P(Z,U, 2),IBPO=+Z 0,IBMOD=$P (ZX,U,2) . ; Manuall y added ch arge with a procedur e . I $P(I BZ,U,6),$S ($P(IBZ,U, 10)=4:'$P( IBZ,U,11), 1:1),+$O(I BP($P(IBZ, U,6)))=$P( IBZ,U,6) D .. ; No d irect link , but a pr oc exists on rev cod e and in p rocedure m ult withou t and then with modi fiers .. S ZX=$O(IBP ($P(IBZ,U, 6))) .. F QQ=1,2 Q:I BPO S Z=" " F S Z=$ O(IBP(ZX,Z ),-1) Q:'Z !(IBPO) S Z0=0 F S Z0=$O(IBP( ZX,Z,Z0)) Q:'Z0 S Z 1=$G(^DGCR (399,IBIFN ,"CP",Z0,0 )) D Q:IB PO ... ; I gnore if n ot a CPT o r a modifi er exists and this i s first pa ss ... S I BMOD=$$GET MOD^IBEFUN C(IBIFN,Z0 ,1) ... Q: $S($P(Z1,U )'["ICPT": 1,QQ=1:IBM OD'="",1:0 ) ... S IB PO=+$P(Z1, U,4),IBX1= $P(Z1,U,2) ... K IBP (+Z1_U_IBM OD,Z,Z0) . ; . I IBX '="" D ; revenue co de is vali d .. S LST =$S(LST="" :900,1:LST +1) .. F Z =LST:1 S Z 0=$S(IBPO: IBPO,$D(IB X(" "_$P(I BX,U),Z)): 0,1:Z) I Z 0 S (LST,I BPO)=Z0 Q .. S IBX(" "_$P(IBX, U),IBPO,IB DA)=IBX,IB X(" "_$P(I BX,U),IBPO ,IBDA,"DT" )=$S(IBX1: IBX1,1:IBD EF),IBX(" "_$P(IBX,U ),IBPO,IBD A,"MOD")=I BMOD ; ; L oop throug h revenue codes in I BX and bui ld the arr ay IBX1. ; S IBS="" F S IBS=$ O(IBX(IBS) ) Q:IBS="" S IBPO=0 F S IBPO =$O(IBX(IB S,IBPO)) Q :'IBPO D . S IBDA=0 F S IBDA =$O(IBX(IB S,IBPO,IBD A)) Q:'IBD A S IBX=$ G(IBX(IBS, IBPO,IBDA) ),IBZ=$G(^ DGCR(399,I BIFN,"RC", IBDA,0)) I IBX'="" D .. ;S IBX S=$P(IBZ,U ,2)_U_$P(I BZ,U,6)_U_ $G(IBX(IBS ,IBPO,IBDA ,"MOD")) . . S IBXS=U _$P(IBZ,U, 6)_U_$G(IB X(IBS,IBPO ,IBDA,"MOD ")) ;combi ne same pr oc and mod ifiers reg ardless of rate .. S :IBPO'<900 &'$$ACCRV( $P(IBS," " ,2))&$S(IB INPAT:$P(I BZ,U,6),1: 1) IBCOMB( IBS,IBXS,I BPO)=IBDA .. S:'$D(I BX1(IBS,IB PO,IBXS,1) ) IBX1(IBS ,IBPO,IBXS ,1)=IBX,IB X1(IBS,IBP O,IBXS,2)= IBZ .. S $ P(IBX1(IBS ,IBPO,IBXS ),U)=$P($G (IBX1(IBS, IBPO,IBXS) ),U)+$P(IB Z,U,3) .. S $P(IBX1( IBS,IBPO,I BXS),U,2)= $P($G(IBX1 (IBS,IBPO, IBXS)),U,2 )+$P(IBZ,U ,4) .. S I BX1(IBS,IB PO,IBXS,"D T")=$G(IBX (IBS,IBPO, IBDA,"DT") ),IBX1(IBS ,IBPO,IBXS ,"IEN")=$G (IBX1(IBS, IBPO,IBXS, "IEN"))_$S ($G(IBX1(I BS,IBPO,IB XS,"IEN")) :";",1:"") _IBDA ; S IBS="" F S IBS=$O(I BX1(IBS)) Q:IBS="" S IBPO=899 F S IBPO =$O(IBX1(I BS,IBPO)) Q:'IBPO D ; Check to combine like rev codes with out print order . N Q,Q0,Q1,Z, Z0,Z1,Z2,I BZ1,IBZ2 . S Z="" . N IBACC . F S Z=$O( IBX1(IBS,I BPO,Z)) Q: Z="" S Q= IBPO F S Q=$O(IBCOM B(IBS,Z,Q) ) Q:'Q I Q'=IBPO S IBZ1=$G(IB X1(IBS,IBP O,Z,1)),IB Z2=$G(IBX1 (IBS,IBPO, Z,2)) D .. Q:$G(IBX1 (IBS,IBPO, Z,1))'=$G( IBX1(IBS,Q ,Z,1)) .. S Q1=1,IBA CC=$$ACCRV (+$P(IBS," ",2)) .. F Q0=1,5:1 :7,10:1:13 ,15 D Q:' Q1 ... I I BACC Q:Q0= 5!(Q0>6) . .. I (Q0=1 1!(Q0=15)) &($P($G(IB X1(IBS,Q,Z ,2)),U,10) =3) Q ... I Q0=5,'IB INPAT Q .. . I $P($G( IBX1(IBS,I BPO,Z,2)), U,Q0)'=$P( $G(IBX1(IB S,Q,Z,2)), U,Q0) S Q1 =0 .. Q:'Q 1 .. S $P( IBX1(IBS,I BPO,Z,2),U ,3)=$P(IBX 1(IBS,IBPO ,Z,2),U,3) +$P(IBX1(I BS,Q,Z,2), U,3) .. S $P(IBX1(IB S,IBPO,Z,2 ),U,4)=$P( IBX1(IBS,I BPO,Z,2),U ,4)+$P(IBX 1(IBS,Q,Z, 2),U,4) .. S $P(IBX1 (IBS,IBPO, Z,2),U,9)= $P(IBX1(IB S,IBPO,Z,2 ),U,9)+$P( IBX1(IBS,Q ,Z,2),U,9) .. S IBX1 (IBS,IBPO, Z)=$P(IBX1 (IBS,IBPO, Z,2),U,3)_ U_$P(IBX1( IBS,IBPO,Z ,2),U,4) . . S IBX1(I BS,IBPO,Z, "IEN")=IBX 1(IBS,IBPO ,Z,"IEN")_ ";"_IBX1(I BS,Q,Z,"IE N") .. K I BX1(IBS,Q, Z) ; D SPL IT ; 488 ; baa ; ; Loop throu gh IBX1 an d build th e array IB XDATA. Eve rything in the ; arr ay IBXDATA comes fro m the arra y IBX1. ; S IBS="",I BLN=0 F S IBS=$O(IB X1(IBS)) Q :IBS="" S IBPO=0 F S IBPO=$O (IBX1(IBS, IBPO)) Q:' IBPO S IB SS="" F S IBSS=$O(I BX1(IBS,IB PO,IBSS)) Q:IBSS="" D . S IBX =$G(IBX1(I BS,IBPO,IB SS,1)),IBZ =$G(IBX1(I BS,IBPO,IB SS,2)) . S IBLN=$G(I BLN)+1,IBX DATA(IBLN) =$P(IBX,U) _U_$P(IBZ, U,6)_U_$P( IBZ,U,2)_U _+IBX1(IBS ,IBPO,IBSS )_U_+$P(IB X1(IBS,IBP O,IBSS),U, 2),$P(IBXD ATA(IBLN), U,10)=$G(I BX1(IBS,IB PO,IBSS,"D T")) . S $ P(IBXDATA( IBLN),U,6) =$P(IBZ,U, 9),$P(IBXD ATA(IBLN), U,7)=$P(IB Z,U,13),$P (IBXDATA(I BLN),U,8)= $G(IBX1(IB S,IBPO,IBS S,"IEN")), $P(IBXDATA (IBLN),U,9 )=$P($P(IB SS,U,3),", ",1,2) . S IBXDATA(I BLN,"CPLNK ")=$$RC2CP (IBIFN,$P( $P(IBXDATA (IBLN),U,8 ),";")) . ; . ; MRD; IB*2.0*516 - Added N DC and Uni ts to line level of claim. . I IBXDATA(I BLN,"CPLNK ") S $P(IB XDATA(IBLN ),U,11,12) =$TR($P($G (^DGCR(399 ,IBIFN,"CP ",IBXDATA( IBLN,"CPLN K"),1)),U, 7,8),"-") . ; . ; Ex tract line lev COB d ata for se c or tert bill . I $ $COBN^IBCE F(IBIFN)>1 D COBLINE ^IBCEU6(IB IFN,IBLN,. IBXDATA,,. IBXTRA) I $D(IBXTRA) D COMBO^I BCEU2(.IBX DATA,.IBXT RA,1) ;Han dle bundle d/unbundle d ; I $D(^ IBA(362.4, "AIFN"_IBI FN))!$D(^I BA(362.5," AIFN"_IBIF N)) D . N IBARRAY,IB X,IBZ,IBRX ,IBLCNT . S IBLCNT=0 . ; Print prescript ions, pros thetics on front of UB-04 . D SET^IBCSC5 A(IBIFN,.I BARRAY) . I $P(IBARR AY,U,2) D .. S IBX=+ $P(IBARRAY ,U,2)+2 .. S IBLCNT= IBLCNT+1,I BXSAVE("RX -UB-04",IB LCNT)="" . . S IBLCNT =IBLCNT+1, IBXSAVE("R X-UB-04",I BLCNT)="PR ESCRIPTION REFILLS:" ,IBLCNT=2 .. S IBX=0 F S IBX= $O(IBARRAY (IBX)) Q:I BX="" S I BY=0 F S IBY=$O(IBA RRAY(IBX,I BY)) Q:'IB Y S IBRX= IBARRAY(IB X,IBY) D . .. D ZERO^ IBRXUTL(+$ P(IBRX,U,2 )) ... S I BLCNT=IBLC NT+1,IBXSA VE("RX-UB- 04",IBLCNT )=IBX_$J(" ",(11-$L( IBX)))_" " _$J($S($P( IBRX,U,6): "$"_$FN($P (IBRX,U,6) ,",",2),1: ""),10)_" "_$J($$FMT E^XLFDT(IB Y,2),8)_" "_$G(^TMP( $J,"IBDRUG ",+$P(IBRX ,U,2),.01) ) ... S IB Z=$S(+$P(I BRX,U,4):" QTY: "_$P( IBRX,U,4)_ " ",1:"")_ $S(+$P(IBR X,U,3):"fo r "_$P(IBR X,U,3)_" d ays supply ",1:"") I IBZ'="" S IBLCNT=IB LCNT+1,IBX SAVE("RX-U B-04",IBLC NT)=$J(" " ,35)_IBZ . .. S IBZ=$ S($P(IBRX, U,5)'="":" NDC #: "_$ P(IBRX,U,5 ),1:"") I IBZ'="" S IBLCNT=IBL CNT+1,IBXS AVE("RX-UB -04",IBLCN T)=$J(" ", 35)_IBZ .. . K ^TMP($ J,"IBDRUG" ) ... Q . ; . D SET^ IBCSC5B(IB IFN,.IBARR AY) . I $P (IBARRAY,U ,2) D .. S IBLCNT=0 .. S IBX=+ $P(IBARRAY ,U,2)+2 .. S IBLCNT= IBLCNT+1,I BXSAVE("PR OS-UB-04", IBLCNT)="" .. S IBLC NT=IBLCNT+ 1,IBXSAVE( "PROS-UB-0 4",IBLCNT) ="PROSTHET IC REFILLS :",IBLCNT= 2 .. S IBX =0 F S IB X=$O(IBARR AY(IBX)) Q :IBX="" S IBY=0 F S IBY=$O(I BARRAY(IBX ,IBY)) Q:' IBY D ... S IBLCNT= IBLCNT+1,I BXSAVE("PR OS-UB-04", IBLCNT)=$$ FMTE^XLFDT (IBX,2)_" "_$J($S($P (IBARRAY(I BX,IBY),U, 2):"$"_$FN ($P(IBARRA Y(IBX,IBY) ,U,2),",", 2),1:""),1 0)_" "_$E( $$PINB^IBC SC5B(+IBAR RAY(IBX,IB Y)),1,54) Q ;ACCRV(X ) ; Return s 1 if X i s an accom odation RC , 0 if not Q ((X'<10 0&(X'>219) )!(X=224)) ;RC2CP(IB IFN,IBRCIE N) ; retur ns "CP" mu ltiple poi nter that correspond s to a giv en "RC" mu ltiple poi nter in fi le 399 ; I BIFN - ien in file 3 99, top le vel ; IBRC IEN, ien i n sub-file 399.042 ( REVENUE CO DE) ; ; re turns poin ter to sub -file 399. 0304 (PROC EDURES) or 0 if no v alid point er can be found. ; N IBRC0,IBC PIEN I +IB IFN'>0 Q 0 I +IBRCIE N'>0 Q 0 S IBRC0=$G( ^DGCR(399, IBIFN,"RC" ,IBRCIEN,0 )),IBCPIEN =0 I $P(IB RC0,U,10)= 4 S IBCPIE N=+$P(IBRC 0,U,11) ; type = CPT I $P(IBRC 0,U,10)=3 S IBCPIEN= +$P(IBRC0, U,15) ; ty pe = RX I 'IBCPIEN D . S IBRC= $P(IBRC0,U ,6) . N IB CPTIEN S I BCPTIEN=IB RC . F S IBCPTIEN=$ O(^DGCR(39 9,IBIFN,"C P","B",IBC PTIEN)) Q: (+IBCPTIEN '=IBRC)!IB CPIEN D . . N OK,Z S OK="",Z=" " .. S Z=$ O(^DGCR(39 9,IBIFN,"C P","B",IBC PTIEN,Z)) Q:'Z!OK D ... N CNT R S CNTR=0 ... F S CNTR=$O(IB XDATA(CNTR )) Q:'CNTR !'OK D .. .. I $G(IB XDATA(CNTR ,"CPLNK")) =Z S OK=0 Q ... I OK ="" S OK=1 ,IBCPIEN=Z I IBCPIEN ,'$D(^DGCR (399,IBIFN ,"CP",IBCP IEN)) S IB CPIEN=0 Q IBCPIEN ;S PLIT ; Split code s into mul tiple line s as neede d => baa ; 488 ; The max line $ amount f or a print ed claim i s less tha n the max line $ amo unt for an electroni cally tran smitted cl aim. ; How ever, sinc e the clea ringhouse can drop t o print fo r a myriad of reason s at any t ime, the l ines may n eed to be split ; so they can all fit on a printed claim lin e just in case. In a ddition, s ince some claims are sent to p rimary pay ers as ; electronic claims bu t printed for second ary claims , the line s numbers need to be the same going out to ensure the ; COB data is c orrect app lied (prev ious payme nts adj, e tc are app lied to th e correct line.) N I BS,IBSS,DA TA,CHRG,UN TS,TOT,LNS ,MOD,CPT,L NK,RLNK,IB SS1,LTOT,L UNT,REC,LS T,FST S IB S="",IBLN= 0 F S IBS =$O(IBX1(I BS)) Q:IBS ="" D . S LST=$O(IB X1(IBS,"") ,-1) ;we h ave to go through ea ch level s o must res et for eac h . S LNK= 0 . F S L NK=$O(IBX1 (IBS,LNK)) Q:('LNK!( LNK>LST)) S IBSS="" F S IBSS= $O(IBX1(IB S,LNK,IBSS )) Q:IBSS= "" D .. S DATA=IBX1 (IBS,LNK,I BSS,2) .. S CHRG=$P( DATA,U,2) .. S UNTS= $P(DATA,U, 3) .. I UN TS=1 Q ; if only on e unit can 't split . . S TOT=UN TS*CHRG .. I TOT<=99 99999.99 Q ; if the total is less tham max we don 't need to split .. S LNS=TOT\ 9999999.99 .. S MOD= TOT#999999 9.99 .. I MOD S LNS= LNS+1 .. I CHRG>4999 999.995 S LNS=UNTS ; if the c harge is g reater tha n half the mas can't put more than one o n a line. .. S LUNT= UNTS\LNS . . S MOD=UN TS#LNS .. I MOD S LU NT=LUNT+1 .. F L=1:1 :LNS D ... N Q ... S Q=$O(IBX1 (IBS,""),- 1)+1 ... I L=1 S Q=L NK ... M I BX1(IBS,Q, IBSS)=IBX1 (IBS,LNK,I BSS) ... S $P(IBX1(I BS,Q,IBSS, 2),U,3)=LU NT,$P(IBX1 (IBS,Q,IBS S,2),U,4)= LUNT*CHRG ... S $P(I BX1(IBS,Q, IBSS),U,1) =LUNT,$P(I BX1(IBS,Q, IBSS),U,2) =LUNT*CHRG ... I L>1 S $P(IBX1 (IBS,Q,IBS S,2),U,9)= "" ... S U NTS=UNTS-L UNT,LUNT=$ S(UNTS>LUN T:LUNT,1:U NTS) Q | |
| 447 | Modified L ogic (Chan ges are in bold) | |
| 448 | IBCEF22 ;A LB/TMP - F ORMATTER S PECIFIC BI LL FUNCTIO NS ;06-FEB -96 ;;2.0; INTEGRATED BILLING;* *51,137,13 5,155,309, 349,389,43 2,488,516, 577**;21-M AR-94;Buil d 16 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ; ; OVERFLOW FROM ROUTI NE IBCEF2H OS(IBIFN) ; Extract rev codes for episod e billed o n a UB-04 into IBXDA TA ; IBIFN = bill ie n ; Format : IBXDATA( n) = ; rev cd ptr ^ CPT CODE p tr ^ unit chg ^ unit s ^ tot ch arge ; ^ t ot uncov ^ FL49 valu e ; ^ ien of rev cod e multiple entry(s) (separated by ";") ; ^ modifie rs specifi c to rev c ode/proc ( separated by ",") ; ^ rev code date, if it can be determined by a corr esponding proc ; ^ N DC from "C P" node of claim ^ U nits/Quant ity from " CP" node - vd/IB*2*5 77 ; ^ Uni ts/Basis o f Measurem ent for Dr ugs - vd/I B*2*577 ; ; Also Ret urns IBXDA TA(IBI,"CO B",COB,m) with COB d ata for ea ch line ; item found in an acc epted EOB for the bi ll and = t he referen ce ; line in the fir st '^' pie ce followe d by the ' 0' node of file ; 36 1.115 (LIN E LEVEL AD JUSTMENTS) ; COB = C OB seq # o f adjustme nt's ins c o, m = seq # ; -- AN D -- ; IBX DATA(IBI," COB",COB,m ,z,p)= ; t he '0' nod e for each subordina te entry o f file ; 3 61.11511 ( REASONS) ( Only first 3 pieces for 837) ; z = group code, som etimes pre ceeded by a space p = seq # ; ; -- AND - - ; IBXDAT A(n,"CPLNK ") = soft link to co rrespondin g entry in PROCEDURE S multiple of file 3 99 ; N IBD A,IBCOMB,I BINPAT,IBL N,IBX,IBY, IBZ,IBS,IB SS,IBXTRA, IBX1,IBXS, IBP,IBPO,I BP1,IBDEF, Z,Z0,Z1,ZX ,QQ,IBMOD, LST S IBIN PAT=$$INPA T^IBCEF(IB IFN,1) I ' IBINPAT D F^IBCEF("N -STATEMENT COVERS FR OM DATE"," IBZ",,IBIF N) S IBDEF =$G(IBZ),L ST="" ; ; Loop throu gh lines o f claim be neath ^DGC R(399,IBIF N,"CP") an d build ; the array IBP to be used below . ; IBP(Pr ocedure ^ Modifiers, Print Ord er, Line#) = Procedu re Date ; S IBDA=0 F S IBDA=$ O(^DGCR(39 9,IBIFN,"C P",IBDA)) Q:'IBDA S IBZ=$G(^( IBDA,0)) I IBZ D . S IBP(+$P(I BZ,U)_U_$$ GETMOD^IBE FUNC(IBIFN ,IBDA,1),$ S($P(IBZ,U ,4):$P(IBZ ,U,4),1:99 9),IBDA)=$ P(IBZ,U,2) ; ; Loop through th e revenue codes bene ath ^DGCR( 399,IBIFN, "RC") and ; build th e array IB X to be us ed below. ; IBX(" "_ Revenue Co de, Print Order, Rev enue Line# ) = ; ^DGC R(399.2, R evenue Cod e IEN, 0) ; IBX(" "_ Revenue Co de, Print Order, Rev enue Line# , "DT") = Procedure Date ; IBX (" "_Reven ue Code, P rint Order , Revenue Line#, "MO D") = Modi fiers ; S IBDA=0 F S IBDA=$O( ^DGCR(399, IBIFN,"RC" ,IBDA)) Q: 'IBDA S I BZ=$G(^(IB DA,0)) I I BZ S IBMOD ="" D . S IBX=$G(^DG CR(399.2,+ IBZ,0)),IB X1="",IBPO =0 . ; Aut o-added pr ocedure ch arge . I $ P(IBZ,U,10 )=4,$P(IBZ ,U,11) D ; Soft lin k to proc .. S Z=$G( ^DGCR(399, IBIFN,"CP" ,$P(IBZ,U, 11),0)) .. Q:Z="" .. S ZX=+Z_U _$$GETMOD^ IBEFUNC(IB IFN,$P(IBZ ,U,11),1) .. Q:'$O(I BP(ZX,0))& '$O(IBP1(Z X,0)) .. I $P(IBZ,U, 6) Q:$S($P (Z,U)'["IC PT":1,1:+$ P(Z,U)'=$P (IBZ,U,6)) .. S Z0=$ S($D(IBP(Z X)):$O(IBP (ZX,0)),1: $O(IBP1(ZX ,0))) .. S :'Z0 Z0=99 9 .. Q:'$D (IBP(ZX,+Z 0,$P(IBZ,U ,11)))&'$D (IBP1(ZX,+ Z0,$P(IBZ, U,11))) .. I '$D(IBP 1(ZX,+Z0,$ P(IBZ,U,11 ))) S IBP1 (ZX,+Z0,$P (IBZ,U,11) )=IBP(ZX,+ Z0,$P(IBZ, U,11)) K I BP(ZX,+Z0, $P(IBZ,U,1 1)) .. S I BX1=$P(Z,U ,2),IBPO=+ Z0,IBMOD=$ P(ZX,U,2) . ; Manual ly added c harge with a procedu re . I $P( IBZ,U,6),$ S($P(IBZ,U ,10)=4:'$P (IBZ,U,11) ,1:1),+$O( IBP($P(IBZ ,U,6)))=$P (IBZ,U,6) D .. ; No direct lin k, but a p roc exists on rev co de and in procedure mult witho ut and the n with mod ifiers .. S ZX=$O(IB P($P(IBZ,U ,6))) .. F QQ=1,2 Q: IBPO S Z= "" F S Z= $O(IBP(ZX, Z),-1) Q:' Z!(IBPO) S Z0=0 F S Z0=$O(IBP (ZX,Z,Z0)) Q:'Z0 S Z1=$G(^DGC R(399,IBIF N,"CP",Z0, 0)) D Q:I BPO ... ; Ignore if not a CPT or a modif ier exists and this is first p ass ... S IBMOD=$$GE TMOD^IBEFU NC(IBIFN,Z 0,1) ... Q :$S($P(Z1, U)'["ICPT" :1,QQ=1:IB MOD'="",1: 0) ... S I BPO=+$P(Z1 ,U,4),IBX1 =$P(Z1,U,2 ) ... K IB P(+Z1_U_IB MOD,Z,Z0) . ; . I IB X'="" D ; revenue c ode is val id .. S LS T=$S(LST=" ":900,1:LS T+1) .. F Z=LST:1 S Z0=$S(IBPO :IBPO,$D(I BX(" "_$P( IBX,U),Z)) :0,1:Z) I Z0 S (LST, IBPO)=Z0 Q .. S IBX( " "_$P(IBX ,U),IBPO,I BDA)=IBX,I BX(" "_$P( IBX,U),IBP O,IBDA,"DT ")=$S(IBX1 :IBX1,1:IB DEF),IBX(" "_$P(IBX, U),IBPO,IB DA,"MOD")= IBMOD ; ; Loop throu gh revenue codes in IBX and bu ild the ar ray IBX1. ; S IBS="" F S IBS= $O(IBX(IBS )) Q:IBS=" " S IBPO= 0 F S IBP O=$O(IBX(I BS,IBPO)) Q:'IBPO D . S IBDA= 0 F S IBD A=$O(IBX(I BS,IBPO,IB DA)) Q:'IB DA S IBX= $G(IBX(IBS ,IBPO,IBDA )),IBZ=$G( ^DGCR(399, IBIFN,"RC" ,IBDA,0)) I IBX'="" D .. ;S IB XS=$P(IBZ, U,2)_U_$P( IBZ,U,6)_U _$G(IBX(IB S,IBPO,IBD A,"MOD")) .. S IBXS= U_$P(IBZ,U ,6)_U_$G(I BX(IBS,IBP O,IBDA,"MO D")) ;comb ine same p roc and mo difiers re gardless o f rate .. S:IBPO'<90 0&'$$ACCRV ($P(IBS," ",2))&$S(I BINPAT:$P( IBZ,U,6),1 :1) IBCOMB (IBS,IBXS, IBPO)=IBDA .. S:'$D( IBX1(IBS,I BPO,IBXS,1 )) IBX1(IB S,IBPO,IBX S,1)=IBX,I BX1(IBS,IB PO,IBXS,2) =IBZ .. S $P(IBX1(IB S,IBPO,IBX S),U)=$P($ G(IBX1(IBS ,IBPO,IBXS )),U)+$P(I BZ,U,3) .. S $P(IBX1 (IBS,IBPO, IBXS),U,2) =$P($G(IBX 1(IBS,IBPO ,IBXS)),U, 2)+$P(IBZ, U,4) .. S IBX1(IBS,I BPO,IBXS," DT")=$G(IB X(IBS,IBPO ,IBDA,"DT" )),IBX1(IB S,IBPO,IBX S,"IEN")=$ G(IBX1(IBS ,IBPO,IBXS ,"IEN"))_$ S($G(IBX1( IBS,IBPO,I BXS,"IEN") ):";",1:"" )_IBDA ; S IBS="" F S IBS=$O( IBX1(IBS)) Q:IBS="" S IBPO=89 9 F S IBP O=$O(IBX1( IBS,IBPO)) Q:'IBPO D ; Check to combin e like rev codes wit hout print order . N Q,Q0,Q1,Z ,Z0,Z1,Z2, IBZ1,IBZ2 . S Z="" . N IBACC . F S Z=$O (IBX1(IBS, IBPO,Z)) Q :Z="" S Q =IBPO F S Q=$O(IBCO MB(IBS,Z,Q )) Q:'Q I Q'=IBPO S IBZ1=$G(I BX1(IBS,IB PO,Z,1)),I BZ2=$G(IBX 1(IBS,IBPO ,Z,2)) D . . Q:$G(IBX 1(IBS,IBPO ,Z,1))'=$G (IBX1(IBS, Q,Z,1)) .. S Q1=1,IB ACC=$$ACCR V(+$P(IBS, " ",2)) .. F Q0=1,5: 1:7,10:1:1 3,15 D Q: 'Q1 ... I IBACC Q:Q0 =5!(Q0>6) ... I (Q0= 11!(Q0=15) )&($P($G(I BX1(IBS,Q, Z,2)),U,10 )=3) Q ... I Q0=5,'I BINPAT Q . .. I $P($G (IBX1(IBS, IBPO,Z,2)) ,U,Q0)'=$P ($G(IBX1(I BS,Q,Z,2)) ,U,Q0) S Q 1=0 .. Q:' Q1 .. S $P (IBX1(IBS, IBPO,Z,2), U,3)=$P(IB X1(IBS,IBP O,Z,2),U,3 )+$P(IBX1( IBS,Q,Z,2) ,U,3) .. S $P(IBX1(I BS,IBPO,Z, 2),U,4)=$P (IBX1(IBS, IBPO,Z,2), U,4)+$P(IB X1(IBS,Q,Z ,2),U,4) . . S $P(IBX 1(IBS,IBPO ,Z,2),U,9) =$P(IBX1(I BS,IBPO,Z, 2),U,9)+$P (IBX1(IBS, Q,Z,2),U,9 ) .. S IBX 1(IBS,IBPO ,Z)=$P(IBX 1(IBS,IBPO ,Z,2),U,3) _U_$P(IBX1 (IBS,IBPO, Z,2),U,4) .. S IBX1( IBS,IBPO,Z ,"IEN")=IB X1(IBS,IBP O,Z,"IEN") _";"_IBX1( IBS,Q,Z,"I EN") .. K IBX1(IBS,Q ,Z) ; D SP LIT ; 488 ; baa ; ; Loop thro ugh IBX1 a nd build t he array I BXDATA. Ev erything i n the ; ar ray IBXDAT A comes fr om the arr ay IBX1. ; S IBS="", IBLN=0 F S IBS=$O(I BX1(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$ O(IBX1(IBS ,IBPO)) Q: 'IBPO S I BSS="" F S IBSS=$O( IBX1(IBS,I BPO,IBSS)) Q:IBSS="" D . S IB X=$G(IBX1( IBS,IBPO,I BSS,1)),IB Z=$G(IBX1( IBS,IBPO,I BSS,2)) . S IBLN=$G( IBLN)+1,IB XDATA(IBLN )=$P(IBX,U )_U_$P(IBZ ,U,6)_U_$P (IBZ,U,2)_ U_+IBX1(IB S,IBPO,IBS S)_U_+$P(I BX1(IBS,IB PO,IBSS),U ,2),$P(IBX DATA(IBLN) ,U,10)=$G( IBX1(IBS,I BPO,IBSS," DT")) . S $P(IBXDATA (IBLN),U,6 )=$P(IBZ,U ,9),$P(IBX DATA(IBLN) ,U,7)=$P(I BZ,U,13),$ P(IBXDATA( IBLN),U,8) =$G(IBX1(I BS,IBPO,IB SS,"IEN")) ,$P(IBXDAT A(IBLN),U, 9)=$P($P(I BSS,U,3)," ,",1,2) . S IBXDATA( IBLN,"CPLN K")=$$RC2C P(IBIFN,$P ($P(IBXDAT A(IBLN),U, 8),";")) . ; . ; MRD ;IB*2.0*51 6 - Added NDC and Un its to lin e level of claim. . ;I IBXDATA (IBLN,"CPL NK") S $P( IBXDATA(IB LN),U,11,1 2)=$TR($P( $G(^DGCR(3 99,IBIFN," CP",IBXDAT A(IBLN,"CP LNK"),1)), U,7,8),"-" ) . ; VAD; IB*2.0*577 - Added U nit/Basis of Measure ment to li ne level o f claim. . I IBXDATA (IBLN,"CPL NK") D . . S $P(IBXD ATA(IBLN), U,11,13)=$ TR($P($G(^ DGCR(399,I BIFN,"CP", IBXDATA(IB LN,"CPLNK" ),1)),U,7, 8),"-")_U_ $P($G(^DGC R(399,IBIF N,"CP",IBX DATA(IBLN, "CPLNK"),2 )),U) . . I +$P(IBXD ATA(IBLN), U,12) S $P (IBXDATA(I BLN),U,12) =$S($P(IBX DATA(IBLN) ,U,12)#1:+ $J($P(IBXD ATA(IBLN), U,12),0,3) ,1:$P(IBXD ATA(IBLN), U,12)) . ; . ; Extra ct line le v COB data for sec o r tert bil l . I $$CO BN^IBCEF(I BIFN)>1 D COBLINE^IB CEU6(IBIFN ,IBLN,.IBX DATA,,.IBX TRA) I $D( IBXTRA) D COMBO^IBCE U2(.IBXDAT A,.IBXTRA, 1) ;Handle bundled/u nbundled ; I $D(^IBA (362.4,"AI FN"_IBIFN) )!$D(^IBA( 362.5,"AIF N"_IBIFN)) D . N IBA RRAY,IBX,I BZ,IBRX,IB LCNT . S I BLCNT=0 . ; Print pr escription s, prosthe tics on fr ont of UB- 04 . D SET ^IBCSC5A(I BIFN,.IBAR RAY) . I $ P(IBARRAY, U,2) D .. S IBX=+$P( IBARRAY,U, 2)+2 .. S IBLCNT=IBL CNT+1,IBXS AVE("RX-UB -04",IBLCN T)="" .. S IBLCNT=IB LCNT+1,IBX SAVE("RX-U B-04",IBLC NT)="PRESC RIPTION RE FILLS:",IB LCNT=2 .. S IBX=0 F S IBX=$O( IBARRAY(IB X)) Q:IBX= "" S IBY= 0 F S IBY =$O(IBARRA Y(IBX,IBY) ) Q:'IBY S IBRX=IBA RRAY(IBX,I BY) D ... D ZERO^IBR XUTL(+$P(I BRX,U,2)) ... S IBLC NT=IBLCNT+ 1,IBXSAVE( "RX-UB-04" ,IBLCNT)=I BX_$J(" ", (11-$L(IBX )))_" "_$J ($S($P(IBR X,U,6):"$" _$FN($P(IB RX,U,6),", ",2),1:"") ,10)_" "_$ J($$FMTE^X LFDT(IBY,2 ),8)_" "_$ G(^TMP($J, "IBDRUG",+ $P(IBRX,U, 2),.01)) . .. S IBZ=$ S(+$P(IBRX ,U,4):"QTY : "_$P(IBR X,U,4)_" " ,1:"")_$S( +$P(IBRX,U ,3):"for " _$P(IBRX,U ,3)_" days supply ", 1:"") I IB Z'="" S IB LCNT=IBLCN T+1,IBXSAV E("RX-UB-0 4",IBLCNT) =$J(" ",35 )_IBZ ... S IBZ=$S($ P(IBRX,U,5 )'="":"NDC #: "_$P(I BRX,U,5),1 :"") I IBZ '="" S IBL CNT=IBLCNT +1,IBXSAVE ("RX-UB-04 ",IBLCNT)= $J(" ",35) _IBZ ... K ^TMP($J," IBDRUG") . .. Q . ; . D SET^IBC SC5B(IBIFN ,.IBARRAY) . I $P(IB ARRAY,U,2) D .. S IB LCNT=0 .. S IBX=+$P( IBARRAY,U, 2)+2 .. S IBLCNT=IBL CNT+1,IBXS AVE("PROS- UB-04",IBL CNT)="" .. S IBLCNT= IBLCNT+1,I BXSAVE("PR OS-UB-04", IBLCNT)="P ROSTHETIC REFILLS:", IBLCNT=2 . . S IBX=0 F S IBX=$ O(IBARRAY( IBX)) Q:IB X="" S IB Y=0 F S I BY=$O(IBAR RAY(IBX,IB Y)) Q:'IBY D ... S IBLCNT=IBL CNT+1,IBXS AVE("PROS- UB-04",IBL CNT)=$$FMT E^XLFDT(IB X,2)_" "_$ J($S($P(IB ARRAY(IBX, IBY),U,2): "$"_$FN($P (IBARRAY(I BX,IBY),U, 2),",",2), 1:""),10)_ " "_$E($$P INB^IBCSC5 B(+IBARRAY (IBX,IBY)) ,1,54) Q ; ACCRV(X) ; Returns 1 if X is a n accomoda tion RC, 0 if not Q ((X'<100&( X'>219))!( X=224)) ;R C2CP(IBIFN ,IBRCIEN) ; returns "CP" multi ple pointe r that cor responds t o a given "RC" multi ple pointe r in file 399 ; IBIF N - ien in file 399, top level ; IBRCIEN , ien in s ub-file 39 9.042 (REV ENUE CODE) ; ; retur ns pointer to sub-fi le 399.030 4 (PROCEDU RES) or 0 if no vali d pointer can be fou nd. ; N IB RC0,IBCPIE N I +IBIFN '>0 Q 0 I +IBRCIEN'> 0 Q 0 S IB RC0=$G(^DG CR(399,IBI FN,"RC",IB RCIEN,0)), IBCPIEN=0 I $P(IBRC0 ,U,10)=4 S IBCPIEN=+ $P(IBRC0,U ,11) ; typ e = CPT I $P(IBRC0,U ,10)=3 S I BCPIEN=+$P (IBRC0,U,1 5) ; type = RX I 'IB CPIEN D . S IBRC=$P( IBRC0,U,6) . N IBCPT IEN S IBCP TIEN=IBRC . F S IBC PTIEN=$O(^ DGCR(399,I BIFN,"CP", "B",IBCPTI EN)) Q:(+I BCPTIEN'=I BRC)!IBCPI EN D .. N OK,Z S OK ="",Z="" . . S Z=$O(^ DGCR(399,I BIFN,"CP", "B",IBCPTI EN,Z)) Q:' Z!OK D .. . N CNTR S CNTR=0 .. . F S CNT R=$O(IBXDA TA(CNTR)) Q:'CNTR!'O K D .... I $G(IBXDA TA(CNTR,"C PLNK"))=Z S OK=0 Q . .. I OK="" S OK=1,IB CPIEN=Z I IBCPIEN,'$ D(^DGCR(39 9,IBIFN,"C P",IBCPIEN )) S IBCPI EN=0 Q IBC PIEN ;SPLI T ; Spl it codes i nto multip le lines a s needed = > baa ; 48 8 ; The ma x line $ a mount for a printed claim is l ess than t he max lin e $ amount for an el ectronical ly transmi tted claim . ; Howeve r, since t he clearin ghouse can drop to p rint for a myriad of reasons a t any time , the line s may need to be spl it ; so th ey can all fit on a printed cl aim line j ust in cas e. In addi tion, sinc e some cla ims are se nt to prim ary payers as ; ele ctronic cl aims but p rinted for secondary claims, t he lines n umbers nee d to be th e same goi ng out to ensure the ; COB da ta is corr ect applie d (previou s payments adj, etc are applie d to the c orrect lin e.) N IBS, IBSS,DATA, CHRG,UNTS, TOT,LNS,MO D,CPT,LNK, RLNK,IBSS1 ,LTOT,LUNT ,REC,LST,F ST S IBS=" ",IBLN=0 F S IBS=$O (IBX1(IBS) ) Q:IBS="" D . S LS T=$O(IBX1( IBS,""),-1 ) ;we have to go thr ough each level so m ust reset for each . S LNK=0 . F S LNK= $O(IBX1(IB S,LNK)) Q: ('LNK!(LNK >LST)) S I BSS="" F S IBSS=$O( IBX1(IBS,L NK,IBSS)) Q:IBSS="" D .. S DA TA=IBX1(IB S,LNK,IBSS ,2) .. S C HRG=$P(DAT A,U,2) .. S UNTS=$P( DATA,U,3) .. I UNTS= 1 Q ; if only one u nit can't split .. S TOT=UNTS* CHRG .. I TOT<=99999 99.99 Q ; if the to tal is les s tham max we don't need to sp lit .. S L NS=TOT\999 9999.99 .. S MOD=TOT #9999999.9 9 .. I MOD S LNS=LNS +1 .. I CH RG>4999999 .995 S LNS =UNTS ; i f the char ge is grea ter than h alf the ma s can't pu t more tha n one on a line. .. S LUNT=UNT S\LNS .. S MOD=UNTS# LNS .. I M OD S LUNT= LUNT+1 .. F L=1:1:LN S D ... N Q ... S Q= $O(IBX1(IB S,""),-1)+ 1 ... I L= 1 S Q=LNK ... M IBX1 (IBS,Q,IBS S)=IBX1(IB S,LNK,IBSS ) ... S $P (IBX1(IBS, Q,IBSS,2), U,3)=LUNT, $P(IBX1(IB S,Q,IBSS,2 ),U,4)=LUN T*CHRG ... S $P(IBX1 (IBS,Q,IBS S),U,1)=LU NT,$P(IBX1 (IBS,Q,IBS S),U,2)=LU NT*CHRG .. . I L>1 S $P(IBX1(IB S,Q,IBSS,2 ),U,9)="" ... S UNTS =UNTS-LUNT ,LUNT=$S(U NTS>LUNT:L UNT,1:UNTS ) Q | |
| 449 | ||
| 450 | MODIFY the acceptabl e format o f the UNIT S field (# 399.0304, 54) so tha t it’s for mat can be “99999999 999.999”. | |
| 451 | Change the field def inition fo r the UNIT S field FR OM: | |
| 452 | 399.0304,5 4 UNITS 1;8 N UMBER | |
| 453 | ||
| 454 | INPUT TRANSFORM: K:+X'=X! (X>9999999 999)!(X<0) !(X?.E1"." 9N.N) X | |
| 455 | LAST E DITED: APR 20, 2017 | |
| 456 | HELP-P ROMPT: Enter th e number o f units, a number be tween 1 | |
| 457 | and 9999 999999 wit h up to 9 decimal di gits. | |
| 458 | DESCRI PTION: Enter th e number o f units of the | |
| 459 | non-pres cription m edication administer ed. | |
| 460 | ||
| 461 | TECHNI CAL DESCR: Enter th e number o f units of the | |
| 462 | non-pres cription m edication administer ed. | |
| 463 | TO: | |
| 464 | 399.0304,5 4 UNITS 1;8 N UMBER | |
| 465 | ||
| 466 | INPUT TRANSFORM: K:+X'=X!( X>99999999 999)!(X<0) !((X[".")& | |
| 467 | (X'?1.11N 1"."1.3N)) X | |
| 468 | LAST E DITED: APR 20, 2017 | |
| 469 | HELP-P ROMPT: Enter a number bet ween 0 and 999999999 9 with | |
| 470 | up to 3 decimal di gits. | |
| 471 | DESCRI PTION: Enter th e number o f units of the | |
| 472 | non-pres cription m edication administer ed. | |
| 473 | ||
| 474 | TECHNI CAL DESCR: The numb er entered must be g reater tha n zero | |
| 475 | and have a format of 9999999 9999 and u p to 3 | |
| 476 | decimal digits. | |
| 477 | ||
| 478 | NOTES: XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER | |
| 479 | TRIGGERE D by the N DC field o f the PROC EDURES | |
| 480 | sub-fiel d of the B ILL/CLAIMS File | |
| 481 | ||
| 482 | The FORMAT CODE of I NS-16 and PRF-23 for the 837 T ransmissio n (in the IB FORM FI ELD CONTEN T file [#3 64.7], ent ries 939 a nd 1949) needs to b e changed remove the decimal p oint “.” f rom the ou tput forma tter. | |
| 483 | To modify INS-16 for the 837 T ransmissio n (in the IB FORM FI ELD CONTEN T file [#3 64.7], ent ry 1949) the follow ing change is to tak e place to remove th e decimal point “.” from the o utput form atter. To do this t he FORMAT CODE neede d to chang e: | |
| 484 | ||
| 485 | FROM: | |
| 486 | ||
| 487 | PIECE 16 Nationa l Drug Uni t Count 364 .6[2236] 3 64.7[1949] 364.5[5] | |
| 488 | Length=1 5 | |
| 489 | Max L ines=0 | |
| 490 | >Consta nt Value: "" | |
| 491 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("INPT",Z )) Q:'Z I $P(IBXSAV E(“INPT”, | |
| 492 | Z),U,1 2)'="" S I BXDATA(Z)= $P(IBXSAVE ("INPT",Z) ,U,12) | |
| 493 | TO: | |
| 494 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("INPT",Z )) Q:'Z I $P(IBXSAV E("INPT", | |
| 495 | Z),U,1 2)'="" S I BXDATA(Z)= +$TR($J($P (IBXSAVE(" INPT",Z),U ,12),11,3) ," .") | |
| 496 | ||
| 497 | To modify PRF-23 for the 837 T ransmissio n (in the IB FORM FI ELD CONTEN T file [#3 64.7], ent ry 939) t he followi ng change is to take place to remove the decimal p oint “.” f rom the ou tput forma tter. To do this th e FORMAT C ODE needed to change : | |
| 498 | ||
| 499 | FROM: | |
| 500 | PIECE 23 Natio nal Drug U nit Count 364.6[977] 364.7[93 9] 364.5[ 5] | |
| 501 | Length=1 5 | |
| 502 | Max L ines=0 | |
| 503 | >Consta nt Value: "" | |
| 504 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("OUTPT", Z)) Q:'Z I $P(IBXSA VE("OUTPT" ,Z), | |
| 505 | U,16)' ="" S IBXD ATA(Z)=$P( IBXSAVE("O UTPT",Z),U ,16) | |
| 506 | ||
| 507 | TO: | |
| 508 | >K IBXD ATA N Z S Z=0 F S Z =$O(IBXSAV E("OUTPT", Z)) Q:'Z I | |
| 509 | $P(IBX SAVE("OUTP T",Z),U,16 )'="" S IB XDATA(Z)=+ $TR($J($P( IBXSAVE("O UTPT",Z), | |
| 510 | U,16), 11,3)," ." ) | |
| 511 | ||
| 512 | CREATE the New ^IBY5 77PR Pre-I nstall Rou tine | |
| 513 | Routines | |
| 514 | Activities | |
| 515 | Routine Na me | |
| 516 | IBY577PR | |
| 517 | Enhancemen t Category | |
| 518 | New | |
| 519 | Modify | |
| 520 | Delete | |
| 521 | No Change | |
| 522 | RTM | |
| 523 | ||
| 524 | Related Op tions | |
| 525 | None | |
| 526 | Related Ro utines | |
| 527 | Routines “ Called By” | |
| 528 | Routines “ Called” | |
| 529 | ||
| 530 | ||
| 531 | ||
| 532 | ||
| 533 | Data Dicti onary (DD) Reference s | |
| 534 | IB DATA EL EMENT DEFI NITION Fil e [#364.7] | |
| 535 | Related Pr otocols | |
| 536 | None | |
| 537 | Related In tegration Control Re gistration s (ICRs) | |
| 538 | None | |
| 539 | Data Passi ng | |
| 540 | Input | |
| 541 | Output Re ference | |
| 542 | Both | |
| 543 | Global Re ference | |
| 544 | Local | |
| 545 | Input Attr ibute Name and Defin ition | |
| 546 | Name: | |
| 547 | Definition : | |
| 548 | Output Att ribute Nam e and Defi nition | |
| 549 | Name: | |
| 550 | Definition : | |
| 551 | Current Lo gic | |
| 552 | N/A | |
| 553 | Modified L ogic (Chan ges are in bold) | |
| 554 | IBY577PR ; ALB/VD - P re-Install ation for IB patch 5 77 ; 4/06/ 17 4:33pm ;;2.0;INTE GRATED BIL LING;**577 **;21-MAR- 94;Build 1 19 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ; ; d elete all output for matter (O. F.) data e lements in cluded in build D DE LOF Q ;INC 3508(Y) ; function t o determin e if entry in IB ERR OR file (3 50.8) shou ld be incl uded in th e build ; Y - ien to file N DA TA,ENTRY,L N,OK,TAG S OK=0,ENTR Y=U_$P($G( ^IBE(350.8 ,Y,0)),U,3 )_U F LN=2 :1 S TAG=" ENT3508+"_ LN,DATA=$P ($T(@TAG), ";;",2) Q: DATA="" I $F(DATA,E NTRY) S OK =1 Q Q OK ;INCLUDE(F ILE,Y) ; f unction to determine if O.F. e ntry shoul d be inclu ded in the build ; F ILE=5,6,7 indicating file 364. x ; Y=ien to file NE W OK,LN,TA G,DATA S O K=0 F LN=2 :1 S TAG=" ENT"_FILE_ "+"_LN,DAT A=$P($T(@T AG),";;",2 ) Q:DATA=" " I $F(DA TA,U_Y_U) S OK=1 Q Q OK ; ;Del ete edited entries t o insure c lean insta ll of new entries ;D elete obso lete entri es.DELOF ; Delete included O F entries NEW FILE,D IK,LN,TAG, TAGLN,DATA ,PCE,DA,Y F FILE=5,6 ,7 S DIK=" ^IBA(364." _FILE_"," D . F TAG= "ENT"_FILE ,"DEL"_FIL E D .. F L N=2:1 S TA GLN=TAG_"+ "_LN,DATA= $P($T(@TAG LN),";;",2 ) Q:DATA=" " D ... F PCE=2:1 S DA=$P(DAT A,U,PCE) Q :'DA I $D (^IBA("364 ."_FILE,DA ,0)) D ^DI K Q ; ; Ex ample for ENT5, ENT6 , ENT7, DE L5, DEL6, and DEL7: ;;^195^254 ^259^269^3 24^325^ ; Note: Must have begi nning and ending up- carat ; ;- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ; 364.5 e ntries mod ified: ;EN T5 ; OF en tries in f ile 364.5 to be incl uded ; ;; ; ;------- ---------- ---------- ---------- ---------- ---------- ---------- ---- ; 364 .6 entries modified: ;ENT6 ; O .F. entrie s in file 364.6 to b e included ; ;; ; ;- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ; 364.7 e ntries mod ified: ; ; 939 - P RF.23 ; 941 - PRF. 25 ; 1949 - INS.16 ; 1950 - IN S.17 ;ENT7 ; O.F. en tries in f ile 364.7 to be incl uded ; ;;^ 939^941^19 49^1950^ ; ;-------- ---------- ---------- ---------- ---------- ---------- ---------- --- ; 364. 5 entries deleted: ; DEL5 ; remove O.F . entries in file 36 4.5 (not r e-added) ; ;; ; ;--- ---------- ---------- ---------- ---------- ---------- ---------- -------- ; 364.6 ent ries delet ed: ; ;DEL 6 ; rem ove O.F. e ntries in file 364.6 (not re-a dded) ; ;; ; ;------ ---------- ---------- ---------- ---------- ---------- ---------- ----- ; 36 4.7 entrie s deleted: ; ;DEL7 ; remove O.F. entr ies in fil e 364.7 (n ot re-adde d) ; ;; ; ;--------- ---------- ---------- ---------- ---------- ---------- ---------- --ENT3508 ; Add New IB Error C odes to Fi le 350.8 ; ;;^IB360^ ; |
Araxis Merge (but not the data content of this report) is Copyright © 1993-2016 Araxis Ltd (www.araxis.com). All rights reserved.