- IBCEU2 ;ALB/TMP - EDI UTILITIES FOR AUTO ADD OF CODES ON BILL ;20-OCT-99
- ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- AUTOCK(IBIFN,IBQUIET) ; Auto add any codes necessary based on data
- ; existing on bill, if needed.
- ; IBQUIET - optional parameter - equals 1 to suppress screen display
- ;
- N IBCOBN,IBFL,DIE,DA,DR
- S DR="",IBCOBN=$$COBN^IBCEF(IBIFN)
- ;
- ;Look for prior payments value codes A1, A2 and occur code 24, if needed
- ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN,$G(IBQUIET))
- ;
- ;Look for occur codes A1,B1,C1 for subscriber date of birth, if needed
- D SUBDOB(IBIFN,IBCOBN,$G(IBQUIET))
- ;
- ; If outpatient bill and no discharge status, add code 01 as default
- I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 D
- . ;Default discharge status for outpt UB to '01'
- . D F^IBCEF("N-PATIENT STATUS","IBZ",,IBIFN)
- . I IBZ="" D
- .. N Z S Z=0 F S Z=$O(^DGCR(399.1,"C","01",Z)) Q:'Z I $P($G(^DGCR(399.1,Z,0)),U,6) Q
- .. I Z S DR=DR_$S(DR'="":";",1:"")_"162////"_Z
- . ; Default admit source to 2
- . D F^IBCEF("N-SOURCE OF ADMISSION","IBZ",,IBIFN)
- . I IBZ="" S DR=DR_$S(DR'="":";",1:"")_"159///2"
- ;
- ; If inpatient bill and no 01 or 02 value code, add 01 value code with
- ; the highest value of all 101 entries
- I $$INPAT^IBCEF(IBIFN,1) D
- . N IBTOB,IBND0,IBFL,IBOK,Z,Z0,IBAMT,DIC,DR,DIE,DA,DO,DD,DLAYGO,X,Y
- . S IBND0=$G(^DGCR(399,IBIFN,0)),IBTOB=$P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)
- . I IBTOB'="11",IBTOB'="18",IBTOB'="21" Q
- . S IBOK=0
- . D F^IBCEF("N-VALUE CODES",,,IBIFN)
- . S Z=0 F S Z=$O(IBFL(39,Z)) Q:'Z I $P(IBFL(39,Z),U)="01"!($P(IBFL(39,Z),U)="02") S IBOK=1 Q
- . Q:IBOK
- . S Z=0,IBAMT=0
- . F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$P($G(^DGCR(399.2,+$G(^DGCR(399,IBIFN,"RC",Z,0)),0)),U) I Z0=101,IBAMT<$P($G(^DGCR(399,IBIFN,"RC",Z,0)),U,2) S IBAMT=$P(^(0),U,2)
- . I IBAMT D
- .. S DA(1)=IBIFN,DLAYGO=399.047,DIC(0)="L",DIC="^DGCR(399,"_DA(1)_",""CV"",",DIC("DR")=".02////"_IBAMT
- .. S X=0 F S X=$O(^DGCR(399.1,"C","01",X)) Q:'X I $P($G(^DGCR(399.1,X,0)),U,11) Q
- .. I X D FILE^DICN
- .. K DIC,DO,DD,DLAYGO
- I DR'="" S DA=IBIFN,DIE="^DGCR(399," D ^DIE
- Q
- ;
- PRPAY(IBIFN,IBCOBN,IBQUIET) ; Output value cd A1 or A2 for prior payments, if needed
- ; IBIFN = ien of bill in file 399
- ; IBCOBN = the COB sequence number for bill (2=secondary, 3=tertiary)
- ; IBQUIET = 1 to suppress screen display
- ;
- N IBNEED,IBNEED24,IB24,IBV,IBVN,DIC,DA,DLAYGO,DD,DO,Z,Z0
- S (IBCT,IBNEED)=0,IBNEED24=1,(IB24(24),IB24("A1"),IB24("A2"))=0
- S Z=0 F S Z=$O(^DGCR(399.1,"C1",24,Z)) Q:'Z I $P($G(^DGCR(399.1,Z,0)),U,4) S IB24(24)=Z Q ;Occurrence code 24
- F Z0="A1","A2" S Z=0 F S Z=$O(^DGCR(399.1,"C1",Z0,Z)) Q:'Z I $P($G(^DGCR(399.1,Z,0)),U,11) S IB24(Z0)=Z Q ;Value codes A1 and A2
- F Z="A1","A2" I $D(^DGCR(399,IBIFN,"I"_$P(Z,"A",2)+1)),IB24(Z) D
- . I '$D(^DGCR(399,IBIFN,"CV","B",+IB24(Z))) S IBNEED(Z)="",IBNEED=IBNEED+1 Q
- . S Z0=0 F S Z0=$O(^DGCR(399,IBIFN,"CV","B",+IB24(Z),Z0)) Q:'Z0 S IBV(Z)=$G(^DGCR(399,IBIFN,"CV",Z0,0)) I Z="A1" S IBNEED24=$S($P(IBV(Z),U,2):0,1:1)
- ;
- I $D(^DGCR(399,IBIFN,"OC","B",+IB24(24))) S IBNEED24=0
- I 'IBNEED24,'IBNEED Q
- I IBNEED D
- . N IBZ,IBXDATA
- . D F^IBCEF("N-OTH INSURANCE PRIOR PAYMENT","IBZ",,IBIFN) Q:'$O(IBZ(0)) ;No prior payment data found
- . F Z="A1","A2" I $D(IBNEED(Z)) S Z0=$TR(Z,"A"),IBNEED(Z)=$G(IBZ(Z0)) S:IBNEED(Z) IBCT=IBCT+1,IBVN(Z)="" I Z="A1",$P(IBNEED(Z),U,2) S IBNEED24=0
- ;
- I IBNEED24 D
- . N Z1,IBZ,IBXDATA
- . ; Get primary's EOB data if possible - find EOB reject date
- . D F^IBCEF("N-EOB ENTRIES","IBZ",,IBIFN)
- . Q:'$O(IBZ(1,0)) ;EOB entry not found for primary insurance
- . S (IB24,Z)=""
- . F S Z=$O(IBZ(1,Z),-1) Q:'Z S Z0=$G(^IBM(361.1,+IBZ(1,Z),0)),Z1=+$G(^(1)) I 'Z1 S IB24=$P(Z0,U,6)\1 Q:IB24
- . Q:'IB24
- . W:'$G(IBQUIET) !,"Adding occurrence code 24 and primary insurance rejection date to bill"
- . S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""OC"",",X=IB24(24),DLAYGO=399.041
- . S DIC("P")=$$GETSPEC^IBEFUNC(399,41),DIC(0)="L",DIC("DR")=".02////"_IB24
- . D FILE^DICN K DO,DD,DIC,DLAYGO
- ;
- I IBNEED D
- . W:'$G(IBQUIET) !!,"Adding value code",$S(IBCT=2:"s A1 and A2",1:$O(IBVN("")))," for reporting of bill's prior payments"
- . ; Adding codes to bill
- . F Z="A1","A2" I $D(IBVN(Z)) D
- .. S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""VC"",",X=IB24(Z),DLAYGO=399.047
- .. S DIC("P")=$$GETSPEC^IBEFUNC(399,47),DIC(0)="L",DIC("DR")=".02////"_+$P(IBNEED(Z),U,2)
- .. D FILE^DICN K DO,DD,DIC,DLAYGO
- ;
- Q
- ;
- SUBDOB(IBIFN,IBCOBN,IBQUIET) ; Add occurrence codes A1,B1,C1 as needed for subscriber DOB
- ; IBIFN = ien of bill in file 399
- ; IBQUIET = 1 to suppress screen display
- ;
- N IBZ,Z,Z0,IBVOC,DR
- S (IBVOC("A1"),IBVOC("B1"),IBVOC("C1"))=0
- F Z0="A1","B1","C1" S Z=0 F S Z=$O(^DGCR(399.1,"C1",Z0,Z)) Q:'Z I $P($G(^DGCR(399.1,Z,0)),U,4) S IBVOC(Z0)=Z Q ;Occurrence codes A1, B1, C1
- F Z=1,2,3 I $D(^DGCR(399,IBIFN,"I"_Z)) D
- . N IBZ1,IBZ2,IBOC,DIC,DA,DLAYGO,DO,DD,X,Y
- . S IBOC=$E("ABC",Z)_"1"
- . Q:'IBVOC(IBOC)
- . Q:$D(^DGCR(399,IBIFN,"OC","B",IBVOC(IBOC))) ;Already there
- . I '$D(IBZ) D
- .. D F^IBCEF("N-CURR INSURED DEMOGRAPHICS","IBZ1",,IBIFN)
- .. D F^IBCEF("N-OTH INSURED DEMOGRAPHICS","IBZ2",,IBIFN)
- .. I IBCOBN=1 S IBZ(1)=+$G(IBZ1),IBZ(2)=+$G(IBZ2(1)),IBZ(3)=+$G(IBZ2(2)) Q
- .. I IBCOBN=2 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ1),IBZ(3)=+$G(IBZ2(2)) Q
- .. I IBCOBN=3 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ2(2)),IBZ(3)=+$G(IBZ1)
- . Q:'$G(IBZ(Z))!$D(^DGCR(399,IBIFN,"OC","B",IBOC(IBOC)))
- . W:'$G(IBQUIET) !,"Adding occurrence code '"_IBOC_"' for "_$P("primary^secondary^tertiary",U,Z)_" insurance subscriber's date of birth"
- . S DIC="^DGCR(399,"_IBIFN_",""OC"",",DA(1)=IBIFN,DLAYGO=399.041,DIC(0)="L",DIC("P")=$$GETSPEC^IBEFUNC(399,41),X=IBVOC(IBOC),DIC("DR")=".02////"_IBZ(Z)
- . D FILE^DICN K DO,DD
- Q
- ;
- COMBO(IBXDATA,IBXTRA,IBINST) ; Determine the bundled/unbundled codes - add
- ; line items where needed to line item array IBXDATA(line #)
- ; Update referenced line in COB entries returned in IBXDATA
- ; IBXTR = array input with bundled/unbundled procedures
- ; ("ALL",original line~original procedure~service date,
- ; new procedure)=COB seq #^sequence # of adjustment in
- ; IBXDATA(n,"COB",COB seq #,adj#)
- ; IBINST = 1 if institutional claim, 0 if professional
- N Z,Z0,Z1
- S Z="" F S Z=$O(IBXTRA("ALL",Z)) Q:Z="" S Z0=$O(IBXTRA("ALL",Z,"")) D
- . ; Unbundled procs will have multiple entries for the combination of
- . ; line~original procedure~service date - one for every new procedure
- . ; Bundled ones will have multiple entries for the same original
- . ; procedure~service date combination
- . ;
- . I $O(IBXTRA("ALL",Z,Z0))'="" S Z0="" F S Z0=$O(IBXTRA("ALL",Z,Z0)) Q:Z0="" S IBXTRA("U",Z,Z0)=IBXTRA("ALL",Z,Z0) Q
- . ; Must be bundled
- . S IBXTRA("B",Z0_"~"_$P(Z,"~",3),$P(Z,"~",1,2))=IBXTRA("ALL",Z,Z0)
- K IBXTRA("ALL")
- ;
- ; UNBUNDLED
- I $D(IBXTRA("U")) D ; Add a new entry to IBXDATA for each new proc
- . S Z="" F S Z=$O(IBXTRA("U",Z)) Q:Z="" S Z0="" F S Z0=$O(IBXTRA("U",Z,Z0)) Q:Z0="" D
- .. ; Z0 = the new procedure, +Z = the original line to reference
- .. S Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z)
- .. I '$G(IBINST) S $P(IBXDATA(Z1),U,8)=0,$P(IBXDATA(Z1),U,5)=Z0,$P(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$P(IBXTRA("U",Z,Z0),U,2)),U)=Z1
- .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=Z0
- ;
- ; BUNDLED
- I $D(IBXTRA("B")) D ; Add a new entry to IBXDATA for the new proc
- . N PROC1
- . S Z0="" F S Z0=$O(IBXTRA("B",Z0)) Q:Z0="" S PROC1="",Z=$O(IBXTRA("B",Z0,"")) Q:Z="" D
- .. ; $P(Z0,"~",1) = the new procedure, +Z = the original line to reference
- .. I 'PROC1 N ZP S PROC1=1,Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z),ZP=$P(Z0,"~") D
- ... I '$G(IBINST) S $P(IBXDATA(Z1),U,8)=0,$P(IBXDATA(Z1),U,5)=ZP,$P(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$P(IBXTRA("U",Z,Z0),U,2)),U)=Z1
- .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=ZP
- .. S $P(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$P(IBXTRA("U",Z,Z0),U,2)),U)=Z1 ;Update original line with reference to the new procedure line
- ;
- Q
- ;
- MCRPT(DFN,IBDT) ; Determine if patient has MCRWNR insurance or if they
- ; are at least 65 yrs old, so should be MCR eligible as of IBDT (or DT)
- ; DFN = ien of patient
- N MCR,DOB,Z
- I '$G(IBDT) S IBDT=DT
- S (MCR,Z)=0
- F S Z=$O(^DPT(2,DFN,2.312,Z)) Q:'Z I $$MCRWNR^IBEFUNC(+$P($G(^(Z,0)),U)) S MCR=1 Q
- I 'MCR S DOB=+$P($G(^DPT(DFN,0)),U,3) I DOB,$E(DT,1,3)-$E(DOB,1,3)-($E(DT,4,7)<$E(DOB,4,7)) S MCR=1
- Q MCR
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEU2 8662 printed Feb 18, 2025@23:38:57 Page 2
- IBCEU2 ;ALB/TMP - EDI UTILITIES FOR AUTO ADD OF CODES ON BILL ;20-OCT-99
- +1 ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- AUTOCK(IBIFN,IBQUIET) ; Auto add any codes necessary based on data
- +1 ; existing on bill, if needed.
- +2 ; IBQUIET - optional parameter - equals 1 to suppress screen display
- +3 ;
- +4 NEW IBCOBN,IBFL,DIE,DA,DR
- +5 SET DR=""
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- +6 ;
- +7 ;Look for prior payments value codes A1, A2 and occur code 24, if needed
- +8 ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN,$G(IBQUIET))
- +9 ;
- +10 ;Look for occur codes A1,B1,C1 for subscriber date of birth, if needed
- +11 DO SUBDOB(IBIFN,IBCOBN,$GET(IBQUIET))
- +12 ;
- +13 ; If outpatient bill and no discharge status, add code 01 as default
- +14 IF '$$INPAT^IBCEF(IBIFN,1)
- IF $$FT^IBCEF(IBIFN)=3
- Begin DoDot:1
- +15 ;Default discharge status for outpt UB to '01'
- +16 DO F^IBCEF("N-PATIENT STATUS","IBZ",,IBIFN)
- +17 IF IBZ=""
- Begin DoDot:2
- +18 NEW Z
- SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399.1,"C","01",Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^DGCR(399.1,Z,0)),U,6)
- QUIT
- +19 IF Z
- SET DR=DR_$SELECT(DR'="":";",1:"")_"162////"_Z
- End DoDot:2
- +20 ; Default admit source to 2
- +21 DO F^IBCEF("N-SOURCE OF ADMISSION","IBZ",,IBIFN)
- +22 IF IBZ=""
- SET DR=DR_$SELECT(DR'="":";",1:"")_"159///2"
- End DoDot:1
- +23 ;
- +24 ; If inpatient bill and no 01 or 02 value code, add 01 value code with
- +25 ; the highest value of all 101 entries
- +26 IF $$INPAT^IBCEF(IBIFN,1)
- Begin DoDot:1
- +27 NEW IBTOB,IBND0,IBFL,IBOK,Z,Z0,IBAMT,DIC,DR,DIE,DA,DO,DD,DLAYGO,X,Y
- +28 SET IBND0=$GET(^DGCR(399,IBIFN,0))
- SET IBTOB=$PIECE(IBND0,U,24)_$PIECE($GET(^DGCR(399.1,+$PIECE(IBND0,U,25),0)),U,2)
- +29 IF IBTOB'="11"
- IF IBTOB'="18"
- IF IBTOB'="21"
- QUIT
- +30 SET IBOK=0
- +31 DO F^IBCEF("N-VALUE CODES",,,IBIFN)
- +32 SET Z=0
- FOR
- SET Z=$ORDER(IBFL(39,Z))
- if 'Z
- QUIT
- IF $PIECE(IBFL(39,Z),U)="01"!($PIECE(IBFL(39,Z),U)="02")
- SET IBOK=1
- QUIT
- +33 if IBOK
- QUIT
- +34 SET Z=0
- SET IBAMT=0
- +35 FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"RC",Z))
- if 'Z
- QUIT
- SET Z0=$PIECE($GET(^DGCR(399.2,+$GET(^DGCR(399,IBIFN,"RC",Z,0)),0)),U)
- IF Z0=101
- IF IBAMT<$PIECE($GET(^DGCR(399,IBIFN,"RC",Z,0)),U,2)
- SET IBAMT=$PIECE(^(0),U,2)
- +36 IF IBAMT
- Begin DoDot:2
- +37 SET DA(1)=IBIFN
- SET DLAYGO=399.047
- SET DIC(0)="L"
- SET DIC="^DGCR(399,"_DA(1)_",""CV"","
- SET DIC("DR")=".02////"_IBAMT
- +38 SET X=0
- FOR
- SET X=$ORDER(^DGCR(399.1,"C","01",X))
- if 'X
- QUIT
- IF $PIECE($GET(^DGCR(399.1,X,0)),U,11)
- QUIT
- +39 IF X
- DO FILE^DICN
- +40 KILL DIC,DO,DD,DLAYGO
- End DoDot:2
- End DoDot:1
- +41 IF DR'=""
- SET DA=IBIFN
- SET DIE="^DGCR(399,"
- DO ^DIE
- +42 QUIT
- +43 ;
- PRPAY(IBIFN,IBCOBN,IBQUIET) ; Output value cd A1 or A2 for prior payments, if needed
- +1 ; IBIFN = ien of bill in file 399
- +2 ; IBCOBN = the COB sequence number for bill (2=secondary, 3=tertiary)
- +3 ; IBQUIET = 1 to suppress screen display
- +4 ;
- +5 NEW IBNEED,IBNEED24,IB24,IBV,IBVN,DIC,DA,DLAYGO,DD,DO,Z,Z0
- +6 SET (IBCT,IBNEED)=0
- SET IBNEED24=1
- SET (IB24(24),IB24("A1"),IB24("A2"))=0
- +7 ;Occurrence code 24
- SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399.1,"C1",24,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^DGCR(399.1,Z,0)),U,4)
- SET IB24(24)=Z
- QUIT
- +8 ;Value codes A1 and A2
- FOR Z0="A1","A2"
- SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399.1,"C1",Z0,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^DGCR(399.1,Z,0)),U,11)
- SET IB24(Z0)=Z
- QUIT
- +9 FOR Z="A1","A2"
- IF $DATA(^DGCR(399,IBIFN,"I"_$PIECE(Z,"A",2)+1))
- IF IB24(Z)
- Begin DoDot:1
- +10 IF '$DATA(^DGCR(399,IBIFN,"CV","B",+IB24(Z)))
- SET IBNEED(Z)=""
- SET IBNEED=IBNEED+1
- QUIT
- +11 SET Z0=0
- FOR
- SET Z0=$ORDER(^DGCR(399,IBIFN,"CV","B",+IB24(Z),Z0))
- if 'Z0
- QUIT
- SET IBV(Z)=$GET(^DGCR(399,IBIFN,"CV",Z0,0))
- IF Z="A1"
- SET IBNEED24=$SELECT($PIECE(IBV(Z),U,2):0,1:1)
- End DoDot:1
- +12 ;
- +13 IF $DATA(^DGCR(399,IBIFN,"OC","B",+IB24(24)))
- SET IBNEED24=0
- +14 IF 'IBNEED24
- IF 'IBNEED
- QUIT
- +15 IF IBNEED
- Begin DoDot:1
- +16 NEW IBZ,IBXDATA
- +17 ;No prior payment data found
- DO F^IBCEF("N-OTH INSURANCE PRIOR PAYMENT","IBZ",,IBIFN)
- if '$ORDER(IBZ(0))
- QUIT
- +18 FOR Z="A1","A2"
- IF $DATA(IBNEED(Z))
- SET Z0=$TRANSLATE(Z,"A")
- SET IBNEED(Z)=$GET(IBZ(Z0))
- if IBNEED(Z)
- SET IBCT=IBCT+1
- SET IBVN(Z)=""
- IF Z="A1"
- IF $PIECE(IBNEED(Z),U,2)
- SET IBNEED24=0
- End DoDot:1
- +19 ;
- +20 IF IBNEED24
- Begin DoDot:1
- +21 NEW Z1,IBZ,IBXDATA
- +22 ; Get primary's EOB data if possible - find EOB reject date
- +23 DO F^IBCEF("N-EOB ENTRIES","IBZ",,IBIFN)
- +24 ;EOB entry not found for primary insurance
- if '$ORDER(IBZ(1,0))
- QUIT
- +25 SET (IB24,Z)=""
- +26 FOR
- SET Z=$ORDER(IBZ(1,Z),-1)
- if 'Z
- QUIT
- SET Z0=$GET(^IBM(361.1,+IBZ(1,Z),0))
- SET Z1=+$GET(^(1))
- IF 'Z1
- SET IB24=$PIECE(Z0,U,6)\1
- if IB24
- QUIT
- +27 if 'IB24
- QUIT
- +28 if '$GET(IBQUIET)
- WRITE !,"Adding occurrence code 24 and primary insurance rejection date to bill"
- +29 SET DA(1)=IBIFN
- SET DIC="^DGCR(399,"_IBIFN_",""OC"","
- SET X=IB24(24)
- SET DLAYGO=399.041
- +30 SET DIC("P")=$$GETSPEC^IBEFUNC(399,41)
- SET DIC(0)="L"
- SET DIC("DR")=".02////"_IB24
- +31 DO FILE^DICN
- KILL DO,DD,DIC,DLAYGO
- End DoDot:1
- +32 ;
- +33 IF IBNEED
- Begin DoDot:1
- +34 if '$GET(IBQUIET)
- WRITE !!,"Adding value code",$SELECT(IBCT=2:"s A1 and A2",1:$ORDER(IBVN("")))," for reporting of bill's prior payments"
- +35 ; Adding codes to bill
- +36 FOR Z="A1","A2"
- IF $DATA(IBVN(Z))
- Begin DoDot:2
- +37 SET DA(1)=IBIFN
- SET DIC="^DGCR(399,"_IBIFN_",""VC"","
- SET X=IB24(Z)
- SET DLAYGO=399.047
- +38 SET DIC("P")=$$GETSPEC^IBEFUNC(399,47)
- SET DIC(0)="L"
- SET DIC("DR")=".02////"_+$PIECE(IBNEED(Z),U,2)
- +39 DO FILE^DICN
- KILL DO,DD,DIC,DLAYGO
- End DoDot:2
- End DoDot:1
- +40 ;
- +41 QUIT
- +42 ;
- SUBDOB(IBIFN,IBCOBN,IBQUIET) ; Add occurrence codes A1,B1,C1 as needed for subscriber DOB
- +1 ; IBIFN = ien of bill in file 399
- +2 ; IBQUIET = 1 to suppress screen display
- +3 ;
- +4 NEW IBZ,Z,Z0,IBVOC,DR
- +5 SET (IBVOC("A1"),IBVOC("B1"),IBVOC("C1"))=0
- +6 ;Occurrence codes A1, B1, C1
- FOR Z0="A1","B1","C1"
- SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399.1,"C1",Z0,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^DGCR(399.1,Z,0)),U,4)
- SET IBVOC(Z0)=Z
- QUIT
- +7 FOR Z=1,2,3
- IF $DATA(^DGCR(399,IBIFN,"I"_Z))
- Begin DoDot:1
- +8 NEW IBZ1,IBZ2,IBOC,DIC,DA,DLAYGO,DO,DD,X,Y
- +9 SET IBOC=$EXTRACT("ABC",Z)_"1"
- +10 if 'IBVOC(IBOC)
- QUIT
- +11 ;Already there
- if $DATA(^DGCR(399,IBIFN,"OC","B",IBVOC(IBOC)))
- QUIT
- +12 IF '$DATA(IBZ)
- Begin DoDot:2
- +13 DO F^IBCEF("N-CURR INSURED DEMOGRAPHICS","IBZ1",,IBIFN)
- +14 DO F^IBCEF("N-OTH INSURED DEMOGRAPHICS","IBZ2",,IBIFN)
- +15 IF IBCOBN=1
- SET IBZ(1)=+$GET(IBZ1)
- SET IBZ(2)=+$GET(IBZ2(1))
- SET IBZ(3)=+$GET(IBZ2(2))
- QUIT
- +16 IF IBCOBN=2
- SET IBZ(1)=+$GET(IBZ2(1))
- SET IBZ(2)=+$GET(IBZ1)
- SET IBZ(3)=+$GET(IBZ2(2))
- QUIT
- +17 IF IBCOBN=3
- SET IBZ(1)=+$GET(IBZ2(1))
- SET IBZ(2)=+$GET(IBZ2(2))
- SET IBZ(3)=+$GET(IBZ1)
- End DoDot:2
- +18 if '$GET(IBZ(Z))!$DATA(^DGCR(399,IBIFN,"OC","B",IBOC(IBOC)))
- QUIT
- +19 if '$GET(IBQUIET)
- WRITE !,"Adding occurrence code '"_IBOC_"' for "_$PIECE("primary^secondary^tertiary",U,Z)_" insurance subscriber's date of birth"
- +20 SET DIC="^DGCR(399,"_IBIFN_",""OC"","
- SET DA(1)=IBIFN
- SET DLAYGO=399.041
- SET DIC(0)="L"
- SET DIC("P")=$$GETSPEC^IBEFUNC(399,41)
- SET X=IBVOC(IBOC)
- SET DIC("DR")=".02////"_IBZ(Z)
- +21 DO FILE^DICN
- KILL DO,DD
- End DoDot:1
- +22 QUIT
- +23 ;
- COMBO(IBXDATA,IBXTRA,IBINST) ; Determine the bundled/unbundled codes - add
- +1 ; line items where needed to line item array IBXDATA(line #)
- +2 ; Update referenced line in COB entries returned in IBXDATA
- +3 ; IBXTR = array input with bundled/unbundled procedures
- +4 ; ("ALL",original line~original procedure~service date,
- +5 ; new procedure)=COB seq #^sequence # of adjustment in
- +6 ; IBXDATA(n,"COB",COB seq #,adj#)
- +7 ; IBINST = 1 if institutional claim, 0 if professional
- +8 NEW Z,Z0,Z1
- +9 SET Z=""
- FOR
- SET Z=$ORDER(IBXTRA("ALL",Z))
- if Z=""
- QUIT
- SET Z0=$ORDER(IBXTRA("ALL",Z,""))
- Begin DoDot:1
- +10 ; Unbundled procs will have multiple entries for the combination of
- +11 ; line~original procedure~service date - one for every new procedure
- +12 ; Bundled ones will have multiple entries for the same original
- +13 ; procedure~service date combination
- +14 ;
- +15 IF $ORDER(IBXTRA("ALL",Z,Z0))'=""
- SET Z0=""
- FOR
- SET Z0=$ORDER(IBXTRA("ALL",Z,Z0))
- if Z0=""
- QUIT
- SET IBXTRA("U",Z,Z0)=IBXTRA("ALL",Z,Z0)
- QUIT
- +16 ; Must be bundled
- +17 SET IBXTRA("B",Z0_"~"_$PIECE(Z,"~",3),$PIECE(Z,"~",1,2))=IBXTRA("ALL",Z,Z0)
- End DoDot:1
- +18 KILL IBXTRA("ALL")
- +19 ;
- +20 ; UNBUNDLED
- +21 ; Add a new entry to IBXDATA for each new proc
- IF $DATA(IBXTRA("U"))
- Begin DoDot:1
- +22 SET Z=""
- FOR
- SET Z=$ORDER(IBXTRA("U",Z))
- if Z=""
- QUIT
- SET Z0=""
- FOR
- SET Z0=$ORDER(IBXTRA("U",Z,Z0))
- if Z0=""
- QUIT
- Begin DoDot:2
- +23 ; Z0 = the new procedure, +Z = the original line to reference
- +24 SET Z1=+$ORDER(IBXDATA(""),-1)+1
- SET IBXDATA(Z1)=IBXDATA(+Z)
- +25 IF '$GET(IBINST)
- SET $PIECE(IBXDATA(Z1),U,8)=0
- SET $PIECE(IBXDATA(Z1),U,5)=Z0
- SET $PIECE(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$PIECE(IBXTRA("U",Z,Z0),U,2)),U)=Z1
- +26 IF $GET(IBINST)
- SET $PIECE(IBXDATA(Z1),U,3)=0
- SET $PIECE(IBXDATA(Z1),U,5,6)="0^0"
- SET $PIECE(IBXDATA(Z1),U,2)=Z0
- End DoDot:2
- End DoDot:1
- +27 ;
- +28 ; BUNDLED
- +29 ; Add a new entry to IBXDATA for the new proc
- IF $DATA(IBXTRA("B"))
- Begin DoDot:1
- +30 NEW PROC1
- +31 SET Z0=""
- FOR
- SET Z0=$ORDER(IBXTRA("B",Z0))
- if Z0=""
- QUIT
- SET PROC1=""
- SET Z=$ORDER(IBXTRA("B",Z0,""))
- if Z=""
- QUIT
- Begin DoDot:2
- +32 ; $P(Z0,"~",1) = the new procedure, +Z = the original line to reference
- +33 IF 'PROC1
- NEW ZP
- SET PROC1=1
- SET Z1=+$ORDER(IBXDATA(""),-1)+1
- SET IBXDATA(Z1)=IBXDATA(+Z)
- SET ZP=$PIECE(Z0,"~")
- Begin DoDot:3
- +34 IF '$GET(IBINST)
- SET $PIECE(IBXDATA(Z1),U,8)=0
- SET $PIECE(IBXDATA(Z1),U,5)=ZP
- SET $PIECE(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$PIECE(IBXTRA("U",Z,Z0),U,2)),U)=Z1
- End DoDot:3
- +35 IF $GET(IBINST)
- SET $PIECE(IBXDATA(Z1),U,3)=0
- SET $PIECE(IBXDATA(Z1),U,5,6)="0^0"
- SET $PIECE(IBXDATA(Z1),U,2)=ZP
- +36 ;Update original line with reference to the new procedure line
- SET $PIECE(IBXDATA(+Z,"COB",+IBXTRA("U",Z,Z0),$PIECE(IBXTRA("U",Z,Z0),U,2)),U)=Z1
- End DoDot:2
- End DoDot:1
- +37 ;
- +38 QUIT
- +39 ;
- MCRPT(DFN,IBDT) ; Determine if patient has MCRWNR insurance or if they
- +1 ; are at least 65 yrs old, so should be MCR eligible as of IBDT (or DT)
- +2 ; DFN = ien of patient
- +3 NEW MCR,DOB,Z
- +4 IF '$GET(IBDT)
- SET IBDT=DT
- +5 SET (MCR,Z)=0
- +6 FOR
- SET Z=$ORDER(^DPT(2,DFN,2.312,Z))
- if 'Z
- QUIT
- IF $$MCRWNR^IBEFUNC(+$PIECE($GET(^(Z,0)),U))
- SET MCR=1
- QUIT
- +7 IF 'MCR
- SET DOB=+$PIECE($GET(^DPT(DFN,0)),U,3)
- IF DOB
- IF $EXTRACT(DT,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(DOB,4,7))
- SET MCR=1
- +8 QUIT MCR
- +9 ;