Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEU2

IBCEU2.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. AUTOCK(IBIFN,IBQUIET) ; Auto add any codes necessary based on data
  1. ; existing on bill, if needed.
  1. ; IBQUIET - optional parameter - equals 1 to suppress screen display
  1. ;
  1. N IBCOBN,IBFL,DIE,DA,DR
  1. S DR="",IBCOBN=$$COBN^IBCEF(IBIFN)
  1. ;
  1. ;Look for prior payments value codes A1, A2 and occur code 24, if needed
  1. ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN,$G(IBQUIET))
  1. ;
  1. ;Look for occur codes A1,B1,C1 for subscriber date of birth, if needed
  1. D SUBDOB(IBIFN,IBCOBN,$G(IBQUIET))
  1. ;
  1. ; If outpatient bill and no discharge status, add code 01 as default
  1. I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 D
  1. . ;Default discharge status for outpt UB to '01'
  1. . D F^IBCEF("N-PATIENT STATUS","IBZ",,IBIFN)
  1. . I IBZ="" D
  1. .. 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
  1. .. I Z S DR=DR_$S(DR'="":";",1:"")_"162////"_Z
  1. . ; Default admit source to 2
  1. . D F^IBCEF("N-SOURCE OF ADMISSION","IBZ",,IBIFN)
  1. . I IBZ="" S DR=DR_$S(DR'="":";",1:"")_"159///2"
  1. ;
  1. ; If inpatient bill and no 01 or 02 value code, add 01 value code with
  1. ; the highest value of all 101 entries
  1. I $$INPAT^IBCEF(IBIFN,1) D
  1. . N IBTOB,IBND0,IBFL,IBOK,Z,Z0,IBAMT,DIC,DR,DIE,DA,DO,DD,DLAYGO,X,Y
  1. . S IBND0=$G(^DGCR(399,IBIFN,0)),IBTOB=$P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)
  1. . I IBTOB'="11",IBTOB'="18",IBTOB'="21" Q
  1. . S IBOK=0
  1. . D F^IBCEF("N-VALUE CODES",,,IBIFN)
  1. . 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
  1. . Q:IBOK
  1. . S Z=0,IBAMT=0
  1. . 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)
  1. . I IBAMT D
  1. .. S DA(1)=IBIFN,DLAYGO=399.047,DIC(0)="L",DIC="^DGCR(399,"_DA(1)_",""CV"",",DIC("DR")=".02////"_IBAMT
  1. .. 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
  1. .. I X D FILE^DICN
  1. .. K DIC,DO,DD,DLAYGO
  1. I DR'="" S DA=IBIFN,DIE="^DGCR(399," D ^DIE
  1. Q
  1. ;
  1. PRPAY(IBIFN,IBCOBN,IBQUIET) ; Output value cd A1 or A2 for prior payments, if needed
  1. ; IBIFN = ien of bill in file 399
  1. ; IBCOBN = the COB sequence number for bill (2=secondary, 3=tertiary)
  1. ; IBQUIET = 1 to suppress screen display
  1. ;
  1. N IBNEED,IBNEED24,IB24,IBV,IBVN,DIC,DA,DLAYGO,DD,DO,Z,Z0
  1. S (IBCT,IBNEED)=0,IBNEED24=1,(IB24(24),IB24("A1"),IB24("A2"))=0
  1. 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
  1. 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
  1. F Z="A1","A2" I $D(^DGCR(399,IBIFN,"I"_$P(Z,"A",2)+1)),IB24(Z) D
  1. . I '$D(^DGCR(399,IBIFN,"CV","B",+IB24(Z))) S IBNEED(Z)="",IBNEED=IBNEED+1 Q
  1. . 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)
  1. ;
  1. I $D(^DGCR(399,IBIFN,"OC","B",+IB24(24))) S IBNEED24=0
  1. I 'IBNEED24,'IBNEED Q
  1. I IBNEED D
  1. . N IBZ,IBXDATA
  1. . D F^IBCEF("N-OTH INSURANCE PRIOR PAYMENT","IBZ",,IBIFN) Q:'$O(IBZ(0)) ;No prior payment data found
  1. . 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
  1. ;
  1. I IBNEED24 D
  1. . N Z1,IBZ,IBXDATA
  1. . ; Get primary's EOB data if possible - find EOB reject date
  1. . D F^IBCEF("N-EOB ENTRIES","IBZ",,IBIFN)
  1. . Q:'$O(IBZ(1,0)) ;EOB entry not found for primary insurance
  1. . S (IB24,Z)=""
  1. . 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
  1. . Q:'IB24
  1. . W:'$G(IBQUIET) !,"Adding occurrence code 24 and primary insurance rejection date to bill"
  1. . S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""OC"",",X=IB24(24),DLAYGO=399.041
  1. . S DIC("P")=$$GETSPEC^IBEFUNC(399,41),DIC(0)="L",DIC("DR")=".02////"_IB24
  1. . D FILE^DICN K DO,DD,DIC,DLAYGO
  1. ;
  1. I IBNEED D
  1. . W:'$G(IBQUIET) !!,"Adding value code",$S(IBCT=2:"s A1 and A2",1:$O(IBVN("")))," for reporting of bill's prior payments"
  1. . ; Adding codes to bill
  1. . F Z="A1","A2" I $D(IBVN(Z)) D
  1. .. S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""VC"",",X=IB24(Z),DLAYGO=399.047
  1. .. S DIC("P")=$$GETSPEC^IBEFUNC(399,47),DIC(0)="L",DIC("DR")=".02////"_+$P(IBNEED(Z),U,2)
  1. .. D FILE^DICN K DO,DD,DIC,DLAYGO
  1. ;
  1. Q
  1. ;
  1. SUBDOB(IBIFN,IBCOBN,IBQUIET) ; Add occurrence codes A1,B1,C1 as needed for subscriber DOB
  1. ; IBIFN = ien of bill in file 399
  1. ; IBQUIET = 1 to suppress screen display
  1. ;
  1. N IBZ,Z,Z0,IBVOC,DR
  1. S (IBVOC("A1"),IBVOC("B1"),IBVOC("C1"))=0
  1. 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
  1. F Z=1,2,3 I $D(^DGCR(399,IBIFN,"I"_Z)) D
  1. . N IBZ1,IBZ2,IBOC,DIC,DA,DLAYGO,DO,DD,X,Y
  1. . S IBOC=$E("ABC",Z)_"1"
  1. . Q:'IBVOC(IBOC)
  1. . Q:$D(^DGCR(399,IBIFN,"OC","B",IBVOC(IBOC))) ;Already there
  1. . I '$D(IBZ) D
  1. .. D F^IBCEF("N-CURR INSURED DEMOGRAPHICS","IBZ1",,IBIFN)
  1. .. D F^IBCEF("N-OTH INSURED DEMOGRAPHICS","IBZ2",,IBIFN)
  1. .. I IBCOBN=1 S IBZ(1)=+$G(IBZ1),IBZ(2)=+$G(IBZ2(1)),IBZ(3)=+$G(IBZ2(2)) Q
  1. .. I IBCOBN=2 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ1),IBZ(3)=+$G(IBZ2(2)) Q
  1. .. I IBCOBN=3 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ2(2)),IBZ(3)=+$G(IBZ1)
  1. . Q:'$G(IBZ(Z))!$D(^DGCR(399,IBIFN,"OC","B",IBOC(IBOC)))
  1. . W:'$G(IBQUIET) !,"Adding occurrence code '"_IBOC_"' for "_$P("primary^secondary^tertiary",U,Z)_" insurance subscriber's date of birth"
  1. . 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)
  1. . D FILE^DICN K DO,DD
  1. Q
  1. ;
  1. COMBO(IBXDATA,IBXTRA,IBINST) ; Determine the bundled/unbundled codes - add
  1. ; line items where needed to line item array IBXDATA(line #)
  1. ; Update referenced line in COB entries returned in IBXDATA
  1. ; IBXTR = array input with bundled/unbundled procedures
  1. ; ("ALL",original line~original procedure~service date,
  1. ; new procedure)=COB seq #^sequence # of adjustment in
  1. ; IBXDATA(n,"COB",COB seq #,adj#)
  1. ; IBINST = 1 if institutional claim, 0 if professional
  1. N Z,Z0,Z1
  1. S Z="" F S Z=$O(IBXTRA("ALL",Z)) Q:Z="" S Z0=$O(IBXTRA("ALL",Z,"")) D
  1. . ; Unbundled procs will have multiple entries for the combination of
  1. . ; line~original procedure~service date - one for every new procedure
  1. . ; Bundled ones will have multiple entries for the same original
  1. . ; procedure~service date combination
  1. . ;
  1. . 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
  1. . ; Must be bundled
  1. . S IBXTRA("B",Z0_"~"_$P(Z,"~",3),$P(Z,"~",1,2))=IBXTRA("ALL",Z,Z0)
  1. K IBXTRA("ALL")
  1. ;
  1. ; UNBUNDLED
  1. I $D(IBXTRA("U")) D ; Add a new entry to IBXDATA for each new proc
  1. . S Z="" F S Z=$O(IBXTRA("U",Z)) Q:Z="" S Z0="" F S Z0=$O(IBXTRA("U",Z,Z0)) Q:Z0="" D
  1. .. ; Z0 = the new procedure, +Z = the original line to reference
  1. .. S Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z)
  1. .. 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
  1. .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=Z0
  1. ;
  1. ; BUNDLED
  1. I $D(IBXTRA("B")) D ; Add a new entry to IBXDATA for the new proc
  1. . N PROC1
  1. . S Z0="" F S Z0=$O(IBXTRA("B",Z0)) Q:Z0="" S PROC1="",Z=$O(IBXTRA("B",Z0,"")) Q:Z="" D
  1. .. ; $P(Z0,"~",1) = the new procedure, +Z = the original line to reference
  1. .. I 'PROC1 N ZP S PROC1=1,Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z),ZP=$P(Z0,"~") D
  1. ... 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
  1. .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=ZP
  1. .. 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
  1. ;
  1. Q
  1. ;
  1. 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)
  1. ; DFN = ien of patient
  1. N MCR,DOB,Z
  1. I '$G(IBDT) S IBDT=DT
  1. S (MCR,Z)=0
  1. F S Z=$O(^DPT(2,DFN,2.312,Z)) Q:'Z I $$MCRWNR^IBEFUNC(+$P($G(^(Z,0)),U)) S MCR=1 Q
  1. 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
  1. Q MCR
  1. ;