source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU2.m@ 1274

Last change on this file since 1274 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1IBCEU2 ;ALB/TMP - EDI UTILITIES FOR AUTO ADD OF CODES ON BILL ;20-OCT-99
2 ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5AUTOCK(IBIFN,IBQUIET) ; Auto add any codes necessary based on data
6 ; existing on bill, if needed.
7 ; IBQUIET - optional parameter - equals 1 to suppress screen display
8 ;
9 N IBCOBN,IBFL,DIE,DA,DR
10 S DR="",IBCOBN=$$COBN^IBCEF(IBIFN)
11 ;
12 ;Look for prior payments value codes A1, A2 and occur code 24, if needed
13 ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN,$G(IBQUIET))
14 ;
15 ;Look for occur codes A1,B1,C1 for subscriber date of birth, if needed
16 D SUBDOB(IBIFN,IBCOBN,$G(IBQUIET))
17 ;
18 ; If outpatient bill and no discharge status, add code 01 as default
19 I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 D
20 . ;Default discharge status for outpt UB to '01'
21 . D F^IBCEF("N-PATIENT STATUS","IBZ",,IBIFN)
22 . I IBZ="" D
23 .. 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
24 .. I Z S DR=DR_$S(DR'="":";",1:"")_"162////"_Z
25 . ; Default admit source to 2
26 . D F^IBCEF("N-SOURCE OF ADMISSION","IBZ",,IBIFN)
27 . I IBZ="" S DR=DR_$S(DR'="":";",1:"")_"159///2"
28 ;
29 ; If inpatient bill and no 01 or 02 value code, add 01 value code with
30 ; the highest value of all 101 entries
31 I $$INPAT^IBCEF(IBIFN,1) D
32 . N IBTOB,IBND0,IBFL,IBOK,Z,Z0,IBAMT,DIC,DR,DIE,DA,DO,DD,DLAYGO,X,Y
33 . S IBND0=$G(^DGCR(399,IBIFN,0)),IBTOB=$P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)
34 . I IBTOB'="11",IBTOB'="18",IBTOB'="21" Q
35 . S IBOK=0
36 . D F^IBCEF("N-VALUE CODES",,,IBIFN)
37 . 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
38 . Q:IBOK
39 . S Z=0,IBAMT=0
40 . 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)
41 . I IBAMT D
42 .. S DA(1)=IBIFN,DLAYGO=399.047,DIC(0)="L",DIC="^DGCR(399,"_DA(1)_",""CV"",",DIC("DR")=".02////"_IBAMT
43 .. 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
44 .. I X D FILE^DICN
45 .. K DIC,DO,DD,DLAYGO
46 I DR'="" S DA=IBIFN,DIE="^DGCR(399," D ^DIE
47 Q
48 ;
49PRPAY(IBIFN,IBCOBN,IBQUIET) ; Output value cd A1 or A2 for prior payments, if needed
50 ; IBIFN = ien of bill in file 399
51 ; IBCOBN = the COB sequence number for bill (2=secondary, 3=tertiary)
52 ; IBQUIET = 1 to suppress screen display
53 ;
54 N IBNEED,IBNEED24,IB24,IBV,IBVN,DIC,DA,DLAYGO,DD,DO,Z,Z0
55 S (IBCT,IBNEED)=0,IBNEED24=1,(IB24(24),IB24("A1"),IB24("A2"))=0
56 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
57 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
58 F Z="A1","A2" I $D(^DGCR(399,IBIFN,"I"_$P(Z,"A",2)+1)),IB24(Z) D
59 . I '$D(^DGCR(399,IBIFN,"CV","B",+IB24(Z))) S IBNEED(Z)="",IBNEED=IBNEED+1 Q
60 . 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)
61 ;
62 I $D(^DGCR(399,IBIFN,"OC","B",+IB24(24))) S IBNEED24=0
63 I 'IBNEED24,'IBNEED Q
64 I IBNEED D
65 . N IBZ,IBXDATA
66 . D F^IBCEF("N-OTH INSURANCE PRIOR PAYMENT","IBZ",,IBIFN) Q:'$O(IBZ(0)) ;No prior payment data found
67 . 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
68 ;
69 I IBNEED24 D
70 . N Z1,IBZ,IBXDATA
71 . ; Get primary's EOB data if possible - find EOB reject date
72 . D F^IBCEF("N-EOB ENTRIES","IBZ",,IBIFN)
73 . Q:'$O(IBZ(1,0)) ;EOB entry not found for primary insurance
74 . S (IB24,Z)=""
75 . 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
76 . Q:'IB24
77 . W:'$G(IBQUIET) !,"Adding occurrence code 24 and primary insurance rejection date to bill"
78 . S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""OC"",",X=IB24(24),DLAYGO=399.041
79 . S DIC("P")=$$GETSPEC^IBEFUNC(399,41),DIC(0)="L",DIC("DR")=".02////"_IB24
80 . D FILE^DICN K DO,DD,DIC,DLAYGO
81 ;
82 I IBNEED D
83 . W:'$G(IBQUIET) !!,"Adding value code",$S(IBCT=2:"s A1 and A2",1:$O(IBVN("")))," for reporting of bill's prior payments"
84 . ; Adding codes to bill
85 . F Z="A1","A2" I $D(IBVN(Z)) D
86 .. S DA(1)=IBIFN,DIC="^DGCR(399,"_IBIFN_",""VC"",",X=IB24(Z),DLAYGO=399.047
87 .. S DIC("P")=$$GETSPEC^IBEFUNC(399,47),DIC(0)="L",DIC("DR")=".02////"_+$P(IBNEED(Z),U,2)
88 .. D FILE^DICN K DO,DD,DIC,DLAYGO
89 ;
90 Q
91 ;
92SUBDOB(IBIFN,IBCOBN,IBQUIET) ; Add occurrence codes A1,B1,C1 as needed for subscriber DOB
93 ; IBIFN = ien of bill in file 399
94 ; IBQUIET = 1 to suppress screen display
95 ;
96 N IBZ,Z,Z0,IBVOC,DR
97 S (IBVOC("A1"),IBVOC("B1"),IBVOC("C1"))=0
98 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
99 F Z=1,2,3 I $D(^DGCR(399,IBIFN,"I"_Z)) D
100 . N IBZ1,IBZ2,IBOC,DIC,DA,DLAYGO,DO,DD,X,Y
101 . S IBOC=$E("ABC",Z)_"1"
102 . Q:'IBVOC(IBOC)
103 . Q:$D(^DGCR(399,IBIFN,"OC","B",IBVOC(IBOC))) ;Already there
104 . I '$D(IBZ) D
105 .. D F^IBCEF("N-CURR INSURED DEMOGRAPHICS","IBZ1",,IBIFN)
106 .. D F^IBCEF("N-OTH INSURED DEMOGRAPHICS","IBZ2",,IBIFN)
107 .. I IBCOBN=1 S IBZ(1)=+$G(IBZ1),IBZ(2)=+$G(IBZ2(1)),IBZ(3)=+$G(IBZ2(2)) Q
108 .. I IBCOBN=2 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ1),IBZ(3)=+$G(IBZ2(2)) Q
109 .. I IBCOBN=3 S IBZ(1)=+$G(IBZ2(1)),IBZ(2)=+$G(IBZ2(2)),IBZ(3)=+$G(IBZ1)
110 . Q:'$G(IBZ(Z))!$D(^DGCR(399,IBIFN,"OC","B",IBOC(IBOC)))
111 . W:'$G(IBQUIET) !,"Adding occurrence code '"_IBOC_"' for "_$P("primary^secondary^tertiary",U,Z)_" insurance subscriber's date of birth"
112 . 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)
113 . D FILE^DICN K DO,DD
114 Q
115 ;
116COMBO(IBXDATA,IBXTRA,IBINST) ; Determine the bundled/unbundled codes - add
117 ; line items where needed to line item array IBXDATA(line #)
118 ; Update referenced line in COB entries returned in IBXDATA
119 ; IBXTR = array input with bundled/unbundled procedures
120 ; ("ALL",original line~original procedure~service date,
121 ; new procedure)=COB seq #^sequence # of adjustment in
122 ; IBXDATA(n,"COB",COB seq #,adj#)
123 ; IBINST = 1 if institutional claim, 0 if professional
124 N Z,Z0,Z1
125 S Z="" F S Z=$O(IBXTRA("ALL",Z)) Q:Z="" S Z0=$O(IBXTRA("ALL",Z,"")) D
126 . ; Unbundled procs will have multiple entries for the combination of
127 . ; line~original procedure~service date - one for every new procedure
128 . ; Bundled ones will have multiple entries for the same original
129 . ; procedure~service date combination
130 . ;
131 . 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
132 . ; Must be bundled
133 . S IBXTRA("B",Z0_"~"_$P(Z,"~",3),$P(Z,"~",1,2))=IBXTRA("ALL",Z,Z0)
134 K IBXTRA("ALL")
135 ;
136 ; UNBUNDLED
137 I $D(IBXTRA("U")) D ; Add a new entry to IBXDATA for each new proc
138 . S Z="" F S Z=$O(IBXTRA("U",Z)) Q:Z="" S Z0="" F S Z0=$O(IBXTRA("U",Z,Z0)) Q:Z0="" D
139 .. ; Z0 = the new procedure, +Z = the original line to reference
140 .. S Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z)
141 .. 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
142 .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=Z0
143 ;
144 ; BUNDLED
145 I $D(IBXTRA("B")) D ; Add a new entry to IBXDATA for the new proc
146 . N PROC1
147 . S Z0="" F S Z0=$O(IBXTRA("B",Z0)) Q:Z0="" S PROC1="",Z=$O(IBXTRA("B",Z0,"")) Q:Z="" D
148 .. ; $P(Z0,"~",1) = the new procedure, +Z = the original line to reference
149 .. I 'PROC1 N ZP S PROC1=1,Z1=+$O(IBXDATA(""),-1)+1,IBXDATA(Z1)=IBXDATA(+Z),ZP=$P(Z0,"~") D
150 ... 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
151 .. I $G(IBINST) S $P(IBXDATA(Z1),U,3)=0,$P(IBXDATA(Z1),U,5,6)="0^0",$P(IBXDATA(Z1),U,2)=ZP
152 .. 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
153 ;
154 Q
155 ;
156MCRPT(DFN,IBDT) ; Determine if patient has MCRWNR insurance or if they
157 ; are at least 65 yrs old, so should be MCR eligible as of IBDT (or DT)
158 ; DFN = ien of patient
159 N MCR,DOB,Z
160 I '$G(IBDT) S IBDT=DT
161 S (MCR,Z)=0
162 F S Z=$O(^DPT(2,DFN,2.312,Z)) Q:'Z I $$MCRWNR^IBEFUNC(+$P($G(^(Z,0)),U)) S MCR=1 Q
163 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
164 Q MCR
165 ;
Note: See TracBrowser for help on using the repository browser.