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

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

revised back to 6/30/08 version
File size: 9.1 KB
Line 
1IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99
2 ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-94
3 Q
4 ;
5UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361.1) from return msg
6 ; IBTDA = ien of return message
7 ; Function returns ien of EOB file entry or "" if errors found
8 ; the data. Any errors found are
9 ; stored in array ^TMP("IBCERR-EOB",$J,n) in text format
10 ; n = seq # and are stored with the EOB in a wp field
11 ;
12 N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X,Y,Z,Z0,Z1,IBEOB,IBBAD,IBOK,IB,IBA1,IBIFN,IBFILE
13 K ^TMP($J),^TMP("IBCERR-EOB",$J)
14 ;
15 S (IBBAD,IBEOB)=""
16 S IB0=$G(^IBA(364.2,IBTDA,0))
17 S IBMNUM=+$P(IB0,U)
18 S X=+$G(^IBA(364,+$P(IB0,U,5),0))
19 ;
20 G:$S(IBMNUM=""!(X=""):1,1:$D(^IBM(361.1,"AC",IBMNUM))) UPDQ
21 ;
22 ; Duplicate EOB Check
23 S IBFILE="^IBA(364.2,"_IBTDA_",2)"
24 I $$DUP(IBFILE,X) G UPDQ
25 ;
26 I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2
27 S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0,IBFILE)
28 L -^IBA(364.2,IBTDA,0)
29 ;
30 I IBEOB<0 S IBEOB="" G UPDQ
31 D UPD3611(IBEOB,IBTDA,0)
32 ;
33UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"IBCERR-EOB")
34 K ^TMP($J),^TMP("IBCERR-EOB",$J)
35 D CLEAN^DILF
36 Q +IBEOB
37 ;
38 ;
39 ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below:
40 ; IB0 = raw data received for this record type on the 835 flat file
41 ; IBEGBL = subscript to use in error global
42 ; IBEOB = ien in file 361.1 for this EOB
43 ;
44835(IB0,IBEGBL,IBEOB) ; Store header
45 ;
46 Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB)
47 ;
485(IB0,IBEGBL,IBEOB) ; Record '05'
49 ;
50 N IBOK,IBBULL,DA,DR,DIE,X,Y
51 K IBZDATA
52 S DR=";",IBOK=1
53 S DIE="^IBM(361.1,",DA=IBEOB
54 ;
55 S IBBULL=""
56 I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCEOB00(IBEOB,IB0,.IBBULL,.DR) D ; New insured's name and/or HIC # found
57 . D CHGBULL^IBCEOB3(IBEOB,IBBULL) ;Send a bulletin reporting change
58 ;
59 I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"
60 I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"
61 S DR=$P(DR,";",2,$L(DR,";")-1)
62 I DR'="" D ^DIE S IBOK=$D(Y)=0
63 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data"
64 Q IBOK
65 ;
6610(IB0,IBEGBL,IBEOB) ; Record '10'
67 ;
68 N DA,DR,DIE,X,Y,VAL,IBOK
69 S DIE="^IBM(361.1,",DA=IBEOB
70 S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2,$P(IB0,U,5)="Y":3,$P(IB0,U,6)="Y":4,1:5)_";.21////"_$P(IB0,U,7)
71 S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01////"_$$DOLLAR($P(IB0,U,11))_$S($P(IB0,U,12)'="":";.14///"_$P(IB0,U,12),1:"")
72 S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:"")_";.11///"_($P(IB0,U,14)/10000)_";.12///"_($P(IB0,U,15)/100)
73 I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($P(IB0,U,9)'="":";.09///"_$P(IB0,U,9),1:"")
74 ;
75 D ^DIE
76 S IBOK=($D(Y)=0)
77 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 10 data" G Q10
78 ;
79 ; File ICN in Bill
80 D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IBEOB,0)),U,15),.IBOK)
81 ;
82Q10 Q IBOK
83 ;
8415(IB0,IBEGBL,IBEOB) ; Record '15'
85 ;
86 N A,IBOK
87 ;
88 S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
89 ;
90 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
91 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
92 ;
93 ; For Medicare MRA's only:
94 ; If the Covered Amount is present (15 record, piece 3), then file
95 ; a claim level adjustment with Group code=OA, Reason code=AB3.
96 ;
97 I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
98 . N IB20
99 . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
100 . S IB20=IB20_U_"Covered Amount"
101 . S IBOK=$$20(IB20,IBEGBL,IBEOB)
102 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
103 . K ^TMP($J,20)
104 . Q
105 ;
106Q15 Q IBOK
107 ;
10817(IB0,IBEGBL,IBEOB) ; Record '17'
109 N A,IBOK
110 S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.04;0;1;0^7;25.05;0;1;0^8;25.06;0;1;0^9;25.07;0;1;0"
111 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
112 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 17 data"
113Q17 Q IBOK
114 ;
11520(IB0,IBEGBL,IBEOB) ; Record '20'
116 ;
117 N A,LEVEL,IBGRP,IBDA,IBOK
118 ;
119 S IBGRP=$P(IB0,U,3)
120 I IBGRP'="" S ^TMP($J,20)=IBGRP
121 I IBGRP="" S IBGRP=$G(^TMP($J,20))
122 I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
123 ;
124 S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
125 ;
126 I 'IBDA(1) D ;Needs a new entry at group level
127 . N X,Y,DA,DD,DO,DIC,DLAYGO
128 . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
129 . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
130 . S X=IBGRP
131 . D FILE^DICN K DIC,DO,DD,DLAYGO
132 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
133 . S IBDA(1)=+Y
134 ;
135 I $G(IBDA(1)) D ;Add a new entry at the reason code level
136 . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
137 . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
138 . S X=$P(IB0,U,4)
139 . D FILE^DICN K DIC,DO,DD,DLAYGO
140 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
141 . S IBDA=+Y
142 ;
143 I $G(IBDA) D
144 . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
145 . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
146 . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
147 . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
148 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
149Q20 Q $G(IBOK)
150 ;
15130(IB0,IBEGBL,IBEOB) ; Record '30'
152 ;
153 N IBOK
154 D 30^IBCEOB0(IB0,IBEOB,.IBOK)
155Q30 Q $G(IBOK)
156 ;
15735(IB0,IBEGBL,IBEOB) ; Record '35'
158 ; Moved due to space constraints
159Q35 Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB)
160 ;
16137(IB0,IBEGBL,IBEOB) ; Record '37'
162 ; Moved due to space constraints
163Q37 Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB)
164 ;
16540(IB0,IBEGBL,IBEOB) ; Record '40'
166 ;
167 N IBOK
168 D 40^IBCEOB0(IB0,IBEOB,.IBOK)
169Q40 Q $G(IBOK)
170 ;
17141(IB0,IBEGBL,IBEOB) ; Record '41'
172 ;
173 N IBOK
174 D 41^IBCEOB0(IB0,IBEOB,.IBOK)
175Q41 Q $G(IBOK)
176 ;
17742(IB0,IBEGBL,IBEOB) ; Record '42'
178 ;
179 N IBOK
180 D 42^IBCEOB0(IB0,IBEOB,.IBOK)
181Q42 Q $G(IBOK)
182 ;
18345(IB0,IBEGBL,IBEOB) ; Record '45'
184 ;
185 N IBOK
186 D 45^IBCEOB0(IB0,IBEOB,.IBOK)
187 Q $G(IBOK)
188 ;
189DOLLAR(X) ; Convert value in X to dollar format XXX.XX
190 Q $S(+X:$J(X/100,$L(+X),2),1:0)
191 ;
192ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE) ; Add stub record to file 361.1
193 ; X = the ien of the referenced bill in file 399
194 ; IBTBILL = ien of transmitted bill (optional)
195 ; IBBATCH = ien of batch # the transmitted bill was in (optional)
196 ; IBMNUM = the message # from which this record originally came
197 ; IBAR = 1 only if called from AR
198 ; IBFILE = array reference of raw EOB data
199 ;
200 N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS
201 F L +^IBM(361.1,0):10 Q:$T
202 ;
203 ; default proper review status
204 S BS=$P($G(^DGCR(399,X,0)),U,13) ; bill status
205 S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0)
206 S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1
207 S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"")
208 S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)
209 D FILE^DICN
210 L -^IBM(361.1,0)
211 Q +Y
212 ;
213UPD3611(IBEOB,IBTDA,IBAR) ; From flat file 835 format, add EOB record
214 ; IBEOB = the ien of the entry in file 361.1 being updated
215 ; IBTDA = the ien in the source file
216 ; IBAR = 1 if being called from AR
217 N IBA1,IBFILE,IBEGBL,Z,IBREC,Q
218 S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^TMP("_$J_",""RCDP-EOB"","_IBTDA_")")
219 S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB")
220 I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR")),IBEGBL,IBEOB) Q
221 S IBA1=0
222 F S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1 S IB0=$S('$G(IBAR):$P($G(^(IBA1,0)),"##RAW DATA: ",2),1:$G(@IBFILE@(IBA1,0))) I IB0'="" D
223 . S IBREC=+IB0
224 . I IBREC'=37 K ^TMP($J,37)
225 . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)",Q=IBREC_"^IBCEOB" I $T(@Q)'="" X IB S:'IBOK ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)=$S('$G(IBAR):" ##RAW DATA: ",1:"")_IB0
226 ;
227 Q
228 ;
229ERRUPD(IBEOB,IBEGBL) ; Update error text in entry, if needed
230 D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","")
231 Q
232 ;
233 ;
234DUP(IBARRAY,IBIFN) ; Duplicate Check
235 ; This function determines if the EOB data already exists in file
236 ; 361.1 by comparing the checksums of the raw 835 data.
237 ;
238 ; IBARRAY = Literal array reference where the raw 835 data exists.
239 ; The data exists at @IBARRAY@(n,0), where n is the seq#.
240 ; For example, IBARRAY = "^IBA(364.2,IBIEN,2)"
241 ;
242 ; IBIFN = the bill # (ptr to 399). The checksums of the EOB's on
243 ; file for this bill will be compared to the checksum of the
244 ; 835 raw data in the IBARRAY reference.
245 ;
246 ; This function returns 0 if the entry is not found (no duplicate),
247 ; Otherwise, the IEN of the entry in file 361.1 is returned if this
248 ; is a duplicate EOB.
249 ;
250 NEW DUP,IBEOB,CHKSUM1,CHKSUM2
251 S DUP=0,IBIFN=+$G(IBIFN)
252 I $G(IBARRAY)=""!'IBIFN G DUPX
253 I '$D(^IBM(361.1,"B",IBIFN)) G DUPX ; no EOB's on file yet
254 S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY) ; checksum of current EOB
255 I 'CHKSUM1 G DUPX ; must be able to be calculated
256 S IBEOB=0
257 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D Q:DUP
258 . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5) ; checksum of old EOB
259 . I 'CHKSUM2 Q
260 . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q ; comparison
261 . Q
262DUPX ;
263 Q DUP
264 ;
Note: See TracBrowser for help on using the repository browser.