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

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

initial load of WorldVistAEHR
File size: 9.4 KB
Line 
1IBCNEHL3 ;DAOU/ALA - HL7 Process Incoming RPI Continued ;03-JUL-2002 ; Compiled June 2, 2005 14:20:19
2 ;;2.0;INTEGRATED BILLING;**300**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This is a continuation of IBCNEHL1 which processes an incoming
7 ; RPI IIV message.
8 ;
9 ; This routine is based on IBCNEHLS which was introduced with patch 184, and subsequently
10 ; patched with patch 271. IBCNEHLS is obsolete and deleted with patch 300.
11 ;
12 Q ; no direct calls allow
13 ;
14ERROR(TQN,ERACT,ERCON,TRCN) ; Entry point
15 ; Input: TQN - IEN for IIV Transmission Queue (#365.1), required
16 ; ERACT - Error Action Code (#365.14), required
17 ; ERCON - Error Condition Code (#365.17), required
18 ; TRCN - Trace # from IIV Response (#365)
19 ;
20 ; IIVSTAT - IIV status transmitted by EC
21 ; Note: MAP(IIVSTAT) = IIV STATUS IEN
22 N MSG,ERDESC,ERIEN,XMY,DA,DIE,DR
23 ;
24 I $G(TQN)="" G ERRORX
25 ;
26 ; Scenarios:
27 ; #1 - If error message = "Resubmission Allowed" OR "Please Resubmit
28 ; Original Transaction" - set TQ
29 ; Fut Trans Dt to T + Comm Failure Days and Status to "Hold"
30 I ERACT="R"!(ERACT="P") D G ERRORX
31 . I $P($G(^IBCN(365.1,TQN,0)),U,9)="" D Q ; first time payer asked us to resubmit
32 . . ; Update IIV TQ fields: "Hold" (4), IIV Site Param Comm Failure Days
33 . . D UPDATE(TQN,4,+$P($G(^IBE(350.9,1,51)),U,5),ERACT)
34 . . ;
35 . ; payer asked us to resubmit for the 2nd time for this inquiry
36 . ; Update IIV TQ fields: "Response Received" (3), n/a ("")
37 . D UPDATE(TQN,3,"",ERACT,ERCON)
38 . ; clear future transmission date so it won't display in the buffer
39 . S DA=TQN,DIE="^IBCN(365.1,",DR=".09///@" D ^DIE
40 ;
41 ; #2 - If error message = "Please Wait 30 Days and Resubmit" - set TQ
42 ; Fut Trans Dt to T + 30 and Status to "Hold"
43 I ERACT="W" D G ERRORX
44 . ; Update IIV TQ fields: "Hold" (4), 30
45 . D UPDATE(TQN,4,30,ERACT)
46 ;
47 ; #3 - If error message = "Please Wait 10 Days and Resubmit" - set TQ
48 ; Fut Trans Dt to T + 10 and Status to "Hold"
49 I ERACT="X" D G ERRORX
50 . ; Update IIV TQ fields: "Hold" (4), 10
51 . D UPDATE(TQN,4,10,ERACT)
52 ;
53 ; #4 - If error message = "Resubmission Not Allowed" or
54 ; "Do not resubmit ...." OR "Please correct and resubmit"
55 ; - set TQ Status to "Response Received"
56 ; If we receive error txt, treat as an "N"
57 I ERACT="" S ERACT="N"
58 I ERACT="N"!(ERACT="Y")!(ERACT="S")!(ERACT="C") D G ERRORX
59 . ; Update IIV TQ fields: "Response Received" (3), n/a ("")
60 . D UPDATE(TQN,3,"",ERACT,ERCON)
61 ;
62 ; #5 - Error message is unfamiliar - new Error Action Code
63 ; *** Currently processed in IBCNEHL1 ***
64 ;
65ERRORX ; ERROR exit pt
66 Q
67 ;
68UPDATE(TQN,TSTS,TDAYS,ERACT,ERCON) ; Update Transmission Queue (#365.1)
69 ; Update/Create Buffer information as necessary
70 ; * If unsolicited error or negative Verification response do not
71 ; update TQ entry. However, create a new Buffer entry.
72 ; Input Variables
73 ; ERACT,ERCON,IIVSTAT,TDAYS,TQN,TSTS
74 ;
75 ; Output Variables
76 ; IIVSTAT (updated)
77 ;
78 ; Init optional param
79 S ERCON=$G(ERCON)
80 ;
81 ; Init vars
82 N D,D0,DA,DFN,DI,DIC,DIE,DQ,DR,FTDT,IBDATA,IBIEN,IBQFL,IBSTS,IBSYM
83 N INSIEN,RSTYPE,SYMBOL,TQDATA,X
84 ;
85 ; If no ZEB segment received, set IIVSTAT to "V"
86 I $TR(IIVSTAT," ")="" S IIVSTAT="V"
87 ;
88 S TQDATA=$G(^IBCN(365.1,TQN,0))
89 I TQDATA="" G UPDATX
90 ;
91 ; Ins Buffer IEN
92 S IBIEN=$P(TQDATA,U,5)
93 S IBQFL=$P(TQDATA,U,11)
94 S RSTYPE=$P($G(^IBCN(365,RIEN,0)),U,10)
95 ;
96 ; If unsolicited error or negative Identification response DON'T
97 ; update TQ entry or Buffer (includes not creating a new buffer)
98 I RSTYPE="U",(IBQFL="I") G UPDATX
99 ;
100 I RSTYPE="U" S IBIEN="" ; makes sure a new buffer is created
101 ;
102 ; Ins Buffer processing
103 I IBIEN'="" D
104 . ; Ins Buf data
105 . S IBDATA=$G(^IBA(355.33,+IBIEN,0))
106 . S IBSTS=$P(IBDATA,U,4) ; Status
107 . S IBSYM=$P(IBDATA,U,12) ; Symbol
108 . ; If IB status is (A)ccepted or (R)ejected or IB symbol is "*"
109 . ; (verified) or IB symbol is "-" (denied), update TQ status to
110 . ; Resp Rec'd (3) and DON'T update the Ins Buffer symbol
111 . I IBSTS="A"!(IBSTS="R")!(IBSYM=8)!(IBSYM=9) S TSTS=3 Q
112 . ; If TQ status is "Hold", update buffer symbol to "?" (10)
113 . I TSTS=4 D BUFF^IBCNEUT2(IBIEN,10) Q ; Set buffer symbol to "?"
114 . ; If TQ status is "Response Received", update buffer symbol to "-" (9) for Error
115 . ; Action Codes ('N','Y','S') & Action Codes ('P','R', if 2nd time payer sent that code)
116 . I TSTS=3,(ERACT="N"!(ERACT="Y")!(ERACT="S")!(ERACT="C")!(ERACT="P")!(ERACT="R")) D Q
117 .. S SYMBOL=MAP(IIVSTAT)
118 .. D BUFF^IBCNEUT2(IBIEN,SYMBOL) ; Set buffer symbol to EC value
119 .. D IIVPROC(IBIEN) ; Set IIV process date & IIV status
120 . ; If TQ status is "Response Received", update buffer symbol to "!" (12 = B9) for new Error Action Code
121 . I TSTS=3,",W,X,R,P,C,N,Y,S,"'[(","_ERACT_",") D BUFF^IBCNEUT2(IBIEN,22) Q
122 ;
123 ; Non-Ins Buffer processing, create entry only for Verification queries
124 I IBIEN="",IBQFL="V" D
125 . ; Determine Patient DFN
126 . S DFN=$P(TQDATA,U,2)
127 . ; Determine Patient Ins record IEN
128 . S INSIEN=$P(TQDATA,U,13) ; If INSIEN="" avoids TQ update
129 . ; If ERACT="C" symbol is passed by EC
130 . I ERACT="C" S SYMBOL=MAP(IIVSTAT) D BUF Q
131 . ; Resubmission Not Allowed or Do Not Resubmit ...
132 . I ERACT="N"!(ERACT="Y")!(ERACT="S") S SYMBOL=MAP(IIVSTAT) D BUF Q
133 . ; An unknown error action - generate a '#'
134 . I ",W,X,R,P,C,N,Y,S,"'[(","_ERACT_",") S SYMBOL=22 D BUF Q
135 ;
136 I RSTYPE="U" G UPDATX ; finished creating new buffer
137 ;
138 ; Update TQ record - Status
139 D SST^IBCNEUT2(TQN,TSTS)
140 ;
141 ; If TQ Status = "Hold", update TQ record - Future Transmission Date
142 I TSTS=4,+$G(TDAYS) D
143 . S FTDT=$$FMADD^XLFDT($$DT^XLFDT,TDAYS)
144 . S DIE="^IBCN(365.1,",DA=TQN,DR=".09///^S X=FTDT"
145 . D ^DIE
146 I TSTS=4,$P(TQDATA,U,8) D
147 . S DIE="^IBCN(365.1,",DA=TQN,DR=".08///0"
148 . D ^DIE
149 ;
150UPDATX ; UPDATE exit point
151 Q
152 ;
153PCK ; Payer Check
154 ; Find the associated Response IEN
155 ;
156 ; Input Variables
157 ; MSGID
158 ;
159 ; Output Variables
160 ; RIEN,ERFLG
161 ;
162 N BUFF,DA,DFN,DIE,DR,IEN,IERN,IN1DATA,MDTM,QFL,PAYR,PIEN,PP
163 N PRDATA,PRIEN,RSIEN,X
164 N NOPAYER,TQIEN
165 ;
166 K ^TMP("IBCNEMID",$J)
167 D FIND^DIC(365,"","","P",MSGID,"","B","","","^TMP(""IBCNEMID"",$J)")
168 ;
169 S PP=0,QFL=0,(RIEN,PIEN)=""
170 S NOPAYER=$$FIND1^DIC(365.12,,"X","~NO PAYER"),TQIEN=$O(^IBCN(365.1,"C",MSGID,""))
171 F S PP=$O(^TMP("IBCNEMID",$J,"DILIST",PP)) Q:'PP D Q:QFL
172 . S PRIEN=$P(^TMP("IBCNEMID",$J,"DILIST",PP,0),U,1)
173 . ;
174 . ; If this is a response w/o an IN1 segment
175 . ; Get payer IEN from TQ as original response shell will change for
176 . ; ~NO PAYER if a payer response is received
177 . S IN1DATA=$$GIN1()
178 . I IN1DATA="",PRIEN'="",TQIEN'="" D
179 .. S QFL=1,PIEN=$P(^IBCN(365.1,TQIEN,0),U,3)
180 . ;
181 . I 'PIEN D PFN(IN1DATA) I 'PIEN S QFL=1 Q
182 . ;
183 . ; If message id/payer found & Response (#365) status is NOT
184 . ; 'Response Received' update the existing response entry (set RIEN)
185 . I $P(^IBCN(365,PRIEN,0),U,3)=PIEN,($P(^IBCN(365,PRIEN,0),U,6)'=3) D Q
186 .. S RIEN=PRIEN,QFL=1
187 ..;
188 ..; If message id/payer found & Response (#365) status equals
189 . ; 'Response Received', RIEN is still null so that this tag knows
190 . ; to create a new unsolicited response entry
191 . ;
192 . ; If payer response received to ~NO PAYER, update IIV Response file
193 . ; w/ responding payer
194 . I RIEN="" S PRDATA=$G(^IBCN(365,PRIEN,0)) I $P(PRDATA,U,3)=NOPAYER,$P(PRDATA,U,6)'=3,$P(PRDATA,U,10)="O" D Q
195 .. S RIEN=PRIEN,QFL=1
196 .. S DIE="^IBCN(365,",DA=RIEN,DR=".03///^S X=PIEN" D ^DIE
197 ;
198 ; If message id/payer not found or unsolicited response, create new response entry
199 I RIEN="" D Q:ERFLG
200 . I $G(PRIEN)'="" D
201 .. S PRDATA=$G(^IBCN(365,PRIEN,0))
202 .. S DFN=$P(PRDATA,U,2),IEN=$P(PRDATA,U,5),MDTM=$P(PRDATA,U,8)
203 . ;
204 . I PIEN="" D Q:ERFLG
205 .. S IN1DATA=$$GIN1()
206 .. I IN1DATA]"" D PFN(IN1DATA) I 'PIEN S PIEN="",QFL=1
207 . S PAYR=PIEN,(RSTYPE,BUFF)=""
208 . D RESP^IBCNEDEQ
209 . S RIEN=RSIEN
210 ;
211 ; If no payer in response file, set it
212 I $G(PIEN)'="",$G(RIEN)'="",$P($G(^IBCN(365,PIEN,0)),U,3)="" D
213 . S DIE="^IBCN(365,",DA=RIEN,DR=".03///^S X=PIEN" D ^DIE
214 Q
215 ;
216BUF ; Create Buffer Record if Doesn't Exist
217 ;
218 ; Input Variables
219 ; RIEN,RSTYPE,TQN
220 ;
221 ; Output Variables
222 ; ERROR,SYMBOL is killed,TQIEN and IRIEN may be reset
223 ;
224 N BUFF,IBFDA,UP
225 I $G(RSTYPE)="U" S (TQIEN,IRIEN)=""
226 D RP^IBCNEBF(RIEN,1)
227 S BUFF=+IBFDA
228 S UP(365,RIEN_",",.04)=+IBFDA
229 I RSTYPE="O" S UP(365.1,TQN_",",.05)=+IBFDA
230 D FILE^DIE("I","UP","ERROR")
231 K SYMBOL
232 Q
233 ;
234IIVPROC(BUFF) ; Set IIV Processed Date to current dt/tm & IIV stat (aka SYMBOL)
235 ; Input Variables
236 ; BUFF
237 ;
238 ; Output Variables
239 ; SYMBOL
240 ;
241 N IDUZ,UP
242 S UP(355.33,BUFF_",",.15)=$$NOW^XLFDT()
243 ; Set IDUZ to the specific, non-human user.
244 S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV")
245 D FILE^DIE("I","UP","ERROR")
246 ; set the symbol of the buffer entry
247 D BUFF^IBCNEUT2(BUFF,SYMBOL) ; reset symbol to appropriate value
248 Q
249 ;
250PFN(IN1DATA) ; Find Payer from HL7 msg
251 ;
252 ; Input Variables
253 ; IN1DATA, TRACE
254 ;
255 ; Output Variables
256 ; ERFLG,ERROR,PIEN
257 ;
258 N IERN,PAYRID
259 S PAYRID=$$CLNSTR^IBCNEHLU($P($P(IN1DATA,HLFS,4),$E(HL("ECH"))),HL("ECH"),$E(HL("ECH")))
260 S PIEN=+$$FIND1^DIC(365.12,"","MX",PAYRID)
261 I PIEN=0 D Q
262 . S ERFLG=1,IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
263 . S ERROR("DIERR",IERN,"TEXT",1)="National Id: "_PAYRID_" not found in Payer Table"
264 . S ERROR("DIERR",IERN,"TEXT",2)="for Trace Number: "_TRACE
265 Q
266 ;
267GIN1() ;Get IN1 segment
268 ;
269 ; Input Variables
270 ; HCT
271 ;
272 ; Returns value of SEGMT
273 ;
274 N IPCT,SEGMT
275 S IPCT=HCT,SEGMT=""
276 F S IPCT=$O(^TMP($J,"IBCNEHLI",IPCT)) Q:IPCT="" D
277 . I $E(^TMP($J,"IBCNEHLI",IPCT,0),1,3)="IN1" S SEGMT=^TMP($J,"IBCNEHLI",IPCT,0)
278 Q SEGMT
Note: See TracBrowser for help on using the repository browser.