source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB1.m@ 1464

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

initial load of WorldVistAEHR

File size: 9.1 KB
Line 
1IBCEOB1 ;ALB/TMP - 835 EDI EOB MSG PROCESSING ;18-FEB-99
2 ;;2.0;INTEGRATED BILLING;**137,135,155,296,356,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6STORE(A,IB0,IBEOB,LEVEL) ;
7 ; A = the string of data to extract and try to store
8 ; each ^ piece is a field to store
9 ; within each ^ piece, there are 5 ';' pieces:
10 ; 1 = piece to extract from the data string;
11 ; 2 = field to update;
12 ; 3 = flag for dollar amt (1=YES);
13 ; 4 = flag for 4-slash stuff without transform (1=YES);
14 ; 5 = flag for numeric/non-dollar amt (1=Yes, 0=No,
15 ; Dn = the field is numeric with 'n' decimal places
16 ; IB0 = the record being processed
17 ; IBEOB = the ien of the EOB entry in file 361.1
18 ; LEVEL = the array that contains the DIE and DA values if stuffing at a
19 ; level other than the top level
20 ;
21 N B,IBPC,IBFLD,DA,DR,DIE,X,Y
22 S DR=";"
23 ;
24 I '$G(LEVEL) S DIE="^IBM(361.1,",DA=IBEOB
25 ;
26 I $G(LEVEL) D
27 . N Q
28 . S DIE=$G(LEVEL("DIE"))
29 . S Q=0 F S Q=$O(LEVEL(Q)) Q:'Q S DA(Q)=LEVEL(Q)
30 . S DA=LEVEL(0)
31 ;
32 I $G(DA) F B=1:1:$L(A,U) D
33 . S IBPC=$P(A,U,B),IBFLD=$P(IBPC,";",2)
34 . I $P(IB0,U,+IBPC)'="",IBFLD D
35 .. N VAL
36 .. ; For dollar amts, add full cents; For numerics, strip leading
37 .. ; 0's; For non-numeric/non-dollar amts, make any ; in data into |
38 .. S VAL=$S($P(IBPC,";",3):$$DOLLAR^IBCEOB($P(IB0,U,+IBPC)),$P(IBPC,";",5):+$P(IB0,U,+IBPC),$P($P(IBPC,";",5),"D",2):$P(IB0,U,+IBPC)/(10**$P($P(IBPC,";",5),"D",2)),1:$TR($P(IB0,U,+IBPC),";","|"))
39 .. I $P(IBPC,";",3),VAL S VAL=$P(VAL,".")_"."_$E($P(VAL,".",2)_"00",1,2)
40 .. S DR=DR_IBFLD_"///"_$S($P(IBPC,";",4):"/",1:"")_VAL_";"
41 ;
42 S DR=$P(DR,";",2,$L(DR,";")-1)
43 I DR'="" D ^DIE
44 Q ($D(Y)=0) ;Successfully stored all the data it was sent if $D(Y)=0
45 ;
46HDR(IB0,IBEGBL,IBEOB) ; Store header data for EOB
47 ; IB0 = the record being processed from the msg
48 ; IBEOB = the ien of the EOB entry in file 361.1
49 ;
50 N IBDT,IBDTP,DA,DR,DIE,X,Y
51 K IBXSAVE("XTRA"),IBZSAVE
52 ;
53 S IBDT=$P(IB0,U,3),IBDT=$E(IBDT,1,4)-1700_$E(IBDT,5,8)_"."_$P(IB0,U,4)
54 S IBDTP=$P(IB0,U,9)
55 I IBDTP S IBDTP=$E(IBDTP,1,4)-1700_$E(IBDTP,5,8)
56 S DR=$S($P(IB0,U,7)'="":".03////"_$P(IB0,U,7)_";",1:"")_".05////"_IBDT_";.04////"_($P(IB0,U,5)="Y")_";.15///"_$$COBN^IBCEF(+$G(^IBM(361.1,IBEOB,0)))_";.07///"_$P(IB0,U,8)_$S(IBDTP:";.06////"_IBDTP,1:"")
57 S DIE="^IBM(361.1,",DA=IBEOB
58 D ^DIE
59 I $D(Y)'=0 D
60 . S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad header data"
61 Q ($D(Y)=0)
62 ;
63FINDLN(IB0,IBEOB,IBZDATA) ; Find the corresponding billed line for the adj
64 ; IB0 = the record being processed
65 ; NOTE: pieces 3,4,16 are already reformatted
66 ; IBEOB = the ien of the EOB entry in file 361.1
67 ; IBZDATA = the array from the output formatter containing line
68 ; items for the bill. This is passed in so this data only has
69 ; to be extracted once for each bill (the first time in, it
70 ; will be undefined)
71 ; OUTPUT = Line # in the original bill that this adjustment relates to
72 ; ^ paid procedure code if different from original procedure OR
73 ; paid rev code if different from original and no proc code
74 ;
75 N IBLN,IBLN1,IBBNDL,OCHG,OCHG2,OPROC,OREVCD,IBIFN,IBXARRAY,IBXARRY
76 N IBXERR,UNITS,UNITS2,UNITS3,IBMOD,Z,Z0,CPT,EOBCHG,IBZVLA,IBAMIN
77 ;
78 S (IBLN,IBLN1)="",IBIFN=+$G(^IBM(361.1,IBEOB,0))
79 S EOBCHG=+$$DOLLAR^IBCEOB($P(IB0,U,15)) ; charges on EOB 40 record
80 ;
81 ; if original procedure exists and is different than the 835 procedure,
82 ; the procedure or revenue code originally billed will be in piece 10
83 ; of the '40' record of the 835 flat file. Otherwise, pc 10 is null.
84 S IBBNDL=$S($P(IB0,U,10)'="":1,1:0)
85 ;
86 ; If this is a split MRA, build array of Vista line#'s from other split MRA's
87 I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$$SPLIT^IBCEMU1(IBEOB) D
88 . N IEN S IEN=0
89 . F S IEN=$O(^IBM(361.1,"B",IBIFN,IEN)) Q:'IEN I IEN'=IBEOB D
90 .. I $P($G(^IBM(361.1,IEN,0)),U,4)'=1 Q ; not an MRA
91 .. I '$$SPLIT^IBCEMU1(IEN) Q ; not a split EOB
92 .. M IBZVLA=^IBM(361.1,IEN,15,"AC")
93 .. Q
94 . Q
95 ;
96 I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D G FINDLNX ; UB-04 format
97 . I '$D(IBZDATA) D F^IBCEF("N-UB-04 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
98 . I $P(IB0,U,22),$D(IBZDATA(+$P(IB0,U,22))) S IBLN=+$P(IB0,U,22)_U_$P(IB0,U,10) Q
99 . ;
100 . S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D Q:IBLN
101 .. ; Quit if processing an MRA and this VistA line# has already been filed
102 .. I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
103 .. ; Quit if split MRA and this VistA line# has already been filed
104 .. I $D(IBZVLA(Z)) Q
105 .. I $G(IBZDATA(Z))="" Q
106 .. S OCHG=$P(IBZDATA(Z),U,3)*$P(IBZDATA(Z),U,4) ; Total charge from bill
107 .. S OCHG2=+$P(IBZDATA(Z),U,5)
108 .. I OCHG'=EOBCHG,OCHG2=EOBCHG S OCHG=OCHG2 ; update OCHG
109 .. ;
110 .. S CPT=$P(IBZDATA(Z),U,2) ; proc from bill
111 .. I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; non-numeric proc
112 .. S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; ext proc code
113 .. S OREVCD=+$P($G(^DGCR(399.2,+IBZDATA(Z),0)),U) ; Rev cd from bill
114 .. ;
115 .. ; if not bundled/unbundled
116 .. I 'IBBNDL D Q
117 ... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) Q ; revenue code
118 ... I OPROC'="",OPROC'=$P(IB0,U,3) Q ; procedure code
119 ... I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) Q ; original units
120 ... I +OCHG'=EOBCHG Q ; original charges
121 ... I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,5,8)),'$$MODMATCH($P($P(IBZDATA(Z),U,9),",",1),$P(IB0,U,5)) Q ; modifiers
122 ... S IBLN=Z
123 ... Q
124 .. ;
125 .. ; if bundled/unbundled
126 .. I IBBNDL D Q
127 ... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) Q ; revenue code
128 ... I OPROC'="",OPROC'=$P(IB0,U,10) Q ; procedure code
129 ... I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) Q ; original units
130 ... I +OCHG'=EOBCHG Q ; original charges
131 ... I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,11,14)),'$$MODMATCH($P($P(IBZDATA(Z),U,9),",",1),$P(IB0,U,11)) Q ; modifiers
132 ... S IBLN=Z_U_$S(OPROC'="":OPROC,1:OREVCD)
133 ... Q
134 .. Q
135 . ; When dealing with Inpatient UB-04's, check for revenue code roll-ups
136 . I 'IBLN,$$INPAT^IBCEF(IBIFN,1) D RCRU^IBCEOB00(.IBZDATA,IB0,.IBLN)
137 . ; If only 1 rev code and charges are the same, assume a match
138 . I 'IBLN,'$P($G(^IBM(361.1,IBEOB,0)),U,4),$O(IBZDATA(""),-1)=$O(IBZDATA("")),+OCHG=EOBCHG S IBLN=+$O(IBZDATA(""))_U_OREVCD
139 ;
140 ; At this point, we can assume the claim is CMS-1500 format
141 I '$D(IBZDATA) D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
142 I $P(IB0,U,22),$D(IBZDATA(+$P(IB0,U,22))) S IBLN=+$P(IB0,U,22)_U_$P(IB0,U,10) G FINDLNX
143 S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D Q:IBLN
144 . ; Quit if processing an MRA and this VistA line# has already been filed
145 . I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
146 . ; Quit if split MRA and this VistA line# has already been filed
147 . I $D(IBZVLA(Z)) Q
148 . S OCHG=$P(IBZDATA(Z),U,8)*$P(IBZDATA(Z),U,9) ; charge from bill
149 . S IBAMIN=""
150 . I $P(IBZDATA(Z),U,12)'="" S IBAMIN=$P(IBZDATA(Z),U,12) ;anesthesia minutes
151 . S UNITS=$S('IBAMIN:$P(IBZDATA(Z),U,9),1:IBAMIN/15)
152 . ; original units from bill or anesthesia minutes calculation
153 . I $P(UNITS,".",2) S UNITS=$FN(UNITS,"",1) ; round to a single decimal place for fractional units
154 . I $P($P(IB0,U,16),".",2) S $P(IB0,U,16)=$FN($P(IB0,U,16),"",1)
155 . S UNITS2=$P(IBZDATA(Z),U,9) ; just the units
156 . ; UNITS3 is the number of anesthesia minutes divided by 10, or nil.
157 . ; Solution to get around the Trailblazers bug for MRAs
158 . S UNITS3=""
159 . I IBAMIN'=0 S UNITS3=IBAMIN/10
160 . ;
161 . S CPT=$P(IBZDATA(Z),U,5) ; proc from bill
162 . I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; non-numeric proc
163 . S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; ext proc code
164 . Q:OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10))
165 . ;
166 . S MODOK=0
167 . I $$DOLLAR^IBCEFG1(OCHG)=+$P(IB0,U,15),UNITS=$P(IB0,U,16)!(UNITS2=$P(IB0,U,16))!(UNITS3=$P(IB0,U,16))!(IBAMIN=$P(IB0,U,16)),$S($P(IB0,U,19):$P(IB0,U,19)=$P(IBZDATA(Z),U),1:1) D
168 .. ;Original procedure/chg/units/date match to get here
169 .. ;Check matching original modifiers
170 .. S MODOK=$$MODMATCH($$MODLST^IBEFUNC2($P(IBZDATA(Z),U,10)),$S('IBBNDL:$P(IB0,U,5,8),1:$P(IB0,U,11,14)))
171 .. I 'MODOK,'IBLN1 S IBLN1=Z_$S(IBBNDL:U_OPROC,1:"")
172 .. Q:'MODOK
173 .. S IBLN=Z_$S(IBBNDL:U_OPROC,1:"")
174 I 'IBLN,IBLN1 S IBLN=IBLN1
175 ;
176FINDLNX ;
177 Q IBLN
178 ;
179MODMATCH(IB,MODLST) ; Match modifiers
180 ; IB = the list of modifiers iens from the bill, comma delimited
181 ; MODLST = the 4 '^' pieces of the reported modifiers
182 ;
183 N MODOK,Q,Z0,IBMOD,MMOD
184 S MODOK=1
185 I $TR(IB,",")'="" F Q=1:1:$L(IB,",") S Z0=$P(IB,",",Q) I Z0'="" S IBMOD(Z0)=$G(IBMOD(Z0))+1
186 I $TR(MODLST,U)="",$O(IBMOD(""))="" G MODQ ; No modifiers used
187 ;
188 ; No match if no VistA modifiers, but there are MRA modifiers
189 I $TR(MODLST,U)'="",$O(IBMOD(""))="" S MODOK=0 G MODQ
190 ;
191 ; Evaluate each MRA modifier
192 F Z0=1:1:4 D
193 . S MMOD=$P(MODLST,U,Z0) Q:MMOD="" ; individual MRA modifier
194 . I '$D(IBMOD(MMOD)) Q ; not in array so just quit
195 . S IBMOD(MMOD)=IBMOD(MMOD)-1 ; decrement array counter
196 . I 'IBMOD(MMOD) KILL IBMOD(MMOD) ; if 0, then kill array entry
197 . Q
198 ;
199 I $O(IBMOD(""))'="" S MODOK=0 ; All submitted mods not matched
200MODQ Q MODOK
201 ;
Note: See TracBrowser for help on using the repository browser.