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

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

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1IBCNEHL2 ;DAOU/ALA - HL7 Process Incoming RPI Msgs (cont.) ;26-JUN-2002 ; Compiled December 16, 2004 15:29:37
2 ;;2.0;INTEGRATED BILLING;**300,345**;21-MAR-94;Build 28
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This pgm will process the indiv segments of the
7 ; incoming IIV response msgs.
8 ;
9 ; * Each of these tags are called by IBCNEHL1.
10 ;
11 ; This routine is based on IBCNEHLP which was introduced with patch 184, and subsequently
12 ; patched with patches 252 and 271. IBCNEHLP is obsolete and deleted with patch 300.
13 ;
14 ; Variables
15 ; SEG = HL7 Seg Name
16 ; MSGID = Original Msg Control ID
17 ; ACK = Acknowledgment (AA=Accepted, AE=Error)
18 ; ERTXT = Error Msg Text
19 ; ERFLG = Error quit flag
20 ; ERACT = Error Action
21 ; ERCON = Error Condition
22 ; RIEN = Response Record IEN
23 ; IBSEG = Array of the segment
24 ;
25 Q ; No direct calls
26 ;
27MSA(ERACT,ERCON,ERROR,ERTXT,IBSEG,MGRP,RIEN,TRACE) ; Process the MSA seg
28 ;
29 ; Input:
30 ; IBSEG,MGRP
31 ;
32 ; Output:
33 ; ERACT,ERCON,ERROR,ERTXT,RIEN,TRACE,ACK
34 ;
35 D MSA^IBCNEHL4
36 Q
37 ;
38CTD(ERROR,IBSEG,RIEN) ; Process the CTD seg
39 ;
40 ; Input:
41 ; IBSEG,RIEN
42 ;
43 ; Output:
44 ; ERROR
45 ;
46 N CTNAME,CTQUAL,CTNUM,CTQIEN,D1,DA,DATA,DIC,DILN,DISYS,DLAYGO,FFL,FLD,IENS,II,RSUPDT,X,Y
47 ;
48 ; Parse out data from seg
49 S CTNAME=$G(IBSEG(3)),CTQUAL=$P($G(IBSEG(6)),$E(HLECH),9),CTNUM=$P($G(IBSEG(6)),$E(HLECH))
50 I $TR(CTNAME," ")="" S CTNAME="NOT SPECIFIED"
51 S CTQIEN=$$FIND1^DIC(365.021,"","X",CTQUAL)
52 I CTNAME[$E(HLECH) S CTNAME=$$DECHL7($$FMNAME^HLFNC(CTNAME,HLECH))
53 S CTNAME=$E(CTNAME,1,32)
54 ;
55 ; Look up contact person
56 S DA(1)=RIEN,DIC="^IBCN(365,"_DA(1)_",3,",DIC(0)="LZ",DLAYGO=365.03
57 I '$D(^IBCN(365,DA(1),3,0)) S ^IBCN(365,DA(1),3,0)="^365.03^^"
58 S X=CTNAME D ^DIC
59 S DA=+Y,DATA=^IBCN(365,DA(1),3,DA,0),FLD=2,FFL=0
60 ;
61 ; Check if contact already has this communication qualifier on file
62 F II=2,4,6 I $P(DATA,U,II)=CTQIEN S FLD=II,FFL=1 Q
63 I 'FFL F II=2,4,6 I $P(DATA,U,II)="" S FLD=II Q
64 ;
65 S IENS=$$IENS^DILF(.DA)
66 S RSUPDT(365.03,IENS,".0"_(FLD+1))=CTNUM
67 S RSUPDT(365.03,IENS,".0"_FLD)=CTQIEN
68 D FILE^DIE("I","RSUPDT","ERROR")
69CTDX ;
70 Q
71 ;
72PID(ERFLG,ERROR,IBSEG,RIEN) ; Process the PID seg
73 ;
74 ; Input:
75 ; IBSEG,RIEN
76 ;
77 ; Output:
78 ; ERFLG,ERROR
79 ;
80 D PID^IBCNEHL4
81 Q
82 ;
83GT1(ERROR,IBSEG,RIEN,SUBID) ; Process the GT1 Guarantor seg
84 ;
85 ; Input:
86 ; IBSEG,RIEN
87 ;
88 ; Output:
89 ; ERROR,SUBID
90 ;
91 D GT1^IBCNEHL4
92 Q
93 ;
94IN1(ERROR,IBSEG,RIEN,SUBID) ; Process the IN1 Insurance seg
95 ;
96 ; Input:
97 ; IBSEG,RIEN,SUBID,ACK
98 ;
99 ; Output:
100 ; ERROR
101 ;
102 N COB,EFFDT,EXPDT,GNAME,GNUMB,MBRID,PAYRID,PYRNM,RSUPDT,SRVDT
103 N PYLEDT,CERDT,RELTN
104 ;
105 ; Austin sending responses with an error indicator will populate IBSEG(3) w/
106 ;9 zeros in order to send the HL7 required field when the payer does not
107 ;send a value for this field
108 S MBRID=$$DECHL7($G(IBSEG(3))) I ACK="AE",($TR(MBRID,0)="") S MBRID=""
109 S PAYRID=$G(IBSEG(4)),PYRNM=$G(IBSEG(5))
110 S GNAME=$$DECHL7($G(IBSEG(10))),GNUMB=$$DECHL7($G(IBSEG(9)))
111 S EFFDT=$G(IBSEG(13)),EXPDT=$G(IBSEG(14))
112 S COB=$G(IBSEG(23)),SRVDT=$G(IBSEG(27))
113 S PYLEDT=$G(IBSEG(30)),RELTN=$G(IBSEG(18))
114 ;
115 ; Relationship codes sent through the HL7 msg are X12 codes
116 ; X12 codes from the interface "01"=spouse, "18"=self "21"=unknown, "34"=other adult
117 S RELTN=$S(RELTN="01":"02",RELTN="18":"01",RELTN="21":"09",1:"")
118 S EFFDT=$$FMDATE^HLFNC(EFFDT),EXPDT=$$FMDATE^HLFNC(EXPDT)
119 S SRVDT=$$FMDATE^HLFNC(SRVDT),PYLEDT=$$FMDATE^HLFNC(PYLEDT)
120 ;
121 S RSUPDT(365,RIEN_",",1.05)=$S($G(SUBID)'="":SUBID,1:MBRID)
122 S RSUPDT(365,RIEN_",",1.07)=GNUMB
123 S RSUPDT(365,RIEN_",",1.06)=GNAME,RSUPDT(365,RIEN_",",1.11)=EFFDT
124 S RSUPDT(365,RIEN_",",1.12)=EXPDT,RSUPDT(365,RIEN_",",1.1)=SRVDT
125 S RSUPDT(365,RIEN_",",1.19)=PYLEDT
126 S RSUPDT(365,RIEN_",",1.13)=COB,RSUPDT(365,RIEN_",",1.18)=MBRID
127 S RSUPDT(365,RIEN_",",1.09)=RELTN
128 D FILE^DIE("I","RSUPDT","ERROR")
129IN1X ;
130 Q
131 ;
132IN3(ERROR,IBSEG,RIEN) ; Process IN3 Addt'l Insurance - Cert Seg
133 ;
134 ; Input:
135 ; IBSEG,RIEN
136 ;
137 ; Output:
138 ; ERROR
139 ;
140 N CRDT,RSUPDT
141 ;
142 S CRDT=$G(IBSEG(7))
143 S CRDT=$$FMDATE^HLFNC(CRDT)
144 S RSUPDT(365,RIEN_",",1.17)=CRDT
145 D FILE^DIE("I","RSUPDT","ERROR")
146IN3X ;
147 Q
148 ;
149ZEB(EBDA,ERROR,IBSEG,RIEN) ; Process the ZEB Elig/Benefit seg
150 ;
151 ; Input:
152 ; IBSEG,IIVSTAT,RIEN
153 ;
154 ; Output:
155 ; EBDA,ERROR
156 ;
157 N D1,DA,DIC,DILN,DISYS,DLAYGO,EBN,IENS,II,MSG,RSUPDT,SUBJECT,X,XMY,Y,MA
158 ;
159 ; Set a default IIV Status value of # ("V")
160 I IIVSTAT="" D
161 . I IBSEG(7)'="IIV Eligibility Determination" S IIVSTAT="V" Q
162 . I $F("_1_6_V_","_"_IBSEG(3)_"_") S IIVSTAT=IBSEG(3) Q
163 . ; Unknown code received from the EC
164 . S SUBJECT="IIV: Invalid Eligibility Status flag"
165 . S MSG(1)="An invalid Eligibility Status flag '"_$G(IBSEG(3))_"' was received for site "_$P($$SITE^VASITE,"^",3)_","
166 . S MSG(2)="trace number "_$G(TRACE,"unknown")_" and message control id "_$G(MSGID,"unknown")_"."
167 . S MSG(3)="It has been interpreted as an ambiguous response in VistA."
168 . S XMY("FSCECADMIN@mail.va.gov")=""
169 . D MSG^IBCNEUT5("",SUBJECT,"MSG(",,.XMY)
170 . S IIVSTAT="V"
171 ;
172 ; Process the ZEB
173 S EBN=$G(IBSEG(2))
174 S DA(1)=RIEN,DIC="^IBCN(365,"_DA(1)_",2,",DIC(0)="L",DLAYGO=365.02
175 I '$D(^IBCN(365,DA(1),2,0)) S ^IBCN(365,DA(1),2,0)="^365.02^^"
176 S X=EBN D ^DIC
177 S DA=+Y,EBDA=DA
178 ;
179 S IENS=$$IENS^DILF(.DA)
180 ;
181 ; decode plan description ZEB segment
182 S IBSEG(7)=$$DECHL7($G(IBSEG(7)))
183 F II=2:1:7 S RSUPDT(365.02,IENS,".0"_II)=$G(IBSEG(II+1))
184 S MA=$G(IBSEG(9)) I $TR(MA," ","")'="" S MA=$J(MA,0,2)
185 S RSUPDT(365.02,IENS,".08")=MA ; Monetary amt
186 S RSUPDT(365.02,IENS,".09")=$G(IBSEG(10)) ; Percent
187 S RSUPDT(365.02,IENS,".1")=$G(IBSEG(11)) ; Quantity Qual.
188 F II=11:1:13 S RSUPDT(365.02,IENS,"."_II)=$G(IBSEG(II+1))
189 D FILE^DIE("E","RSUPDT","ERROR")
190ZEBX ;
191 Q
192 ;
193NTE(EBDA,IBSEG,RIEN) ; Process NTE Notes seg
194 ;
195 ; Input:
196 ; EBDA,IBSEG,RIEN
197 ;
198 ; Output:
199 ; ERROR
200 ;
201 N DA,IENS,NOTES
202 I $G(EBDA)="" Q
203 S NOTES(1)=$$DECHL7($G(IBSEG(4)))
204 S DA(1)=RIEN,DA=EBDA
205 S IENS=$$IENS^DILF(.DA)
206 D WP^DIE(365.02,IENS,2,"A","NOTES","ERROR")
207NTEX ;
208 Q
209 ;
210DECHL7(STR,HLSEP,ECHARS) ; Decode HL7 escape seqs in data fields
211 ;
212 ; Input:
213 ; STR = Field data possible containing HL7 escape seqs for encoding chars
214 ; HLSEP (opt) = HL7 Field sep. char - assumes HLFS if not passed
215 ; ECHARS (opt) = HL7 encoding chars being used, assumes HL("ECH") if not passed
216 ;
217 ; Output Values
218 ; Fn returns string w/converted escape seqs
219 ;
220 N ESC,PAT,REPL,ECODE,PCE
221 ; Initialize opt. params.
222 I $G(HLSEP)="" S HLSEP=HLFS
223 I $G(ECHARS)="" S ECHARS=HL("ECH")
224 ;
225 S ESC=$E(ECHARS,3) ; Escape char.
226 ; Check for escape seqs, quit if not
227 I STR'[ESC G DECHL7X
228 ; Replace ^ w/{sp} (if any) to prevent filing problems
229 S ECHARS=$TR(ECHARS,"^"," ")
230 ;
231 ; Array of rep. chars
232 S REPL("F")=$TR(HLSEP,"^"," ") ;Field Sep
233 S REPL("S")=$E(ECHARS) ;Comp Sep
234 S REPL("R")=$E(ECHARS,2) ;Rep. sep
235 ; Temp. replace w/ASC 26, until after other ESC are stripped
236 S REPL("E")=$C(26) ;Esc. sep
237 S REPL("T")=$E(ECHARS,4) ;Subcomp. sep
238 ;
239 ; Translate out escape seqs left->right
240 F PCE=1:1:($L(STR,ESC)-1)\2 D
241 . ; Ignore empty esc. or unrec. esc. seq.
242 . S ECODE=$P(STR,ESC,2) I ECODE="" S ECODE="XXXX"
243 . I $D(REPL(ECODE))'>0 S STR=$P(STR,ESC)_$C(26)_$P(STR,ESC,2)_$C(26)_$P(STR,ESC,3,99999) Q
244 . ; Else, replace esc. seq. w/ char.
245 . S STR=$P(STR,ESC)_$G(REPL(ECODE))_$P(STR,ESC,3,99999)
246 ;
247 ;Replace the decoded ESC chars that were actually sent
248 S STR=$TR(STR,$C(26),ESC)
249 ;
250DECHL7X ; Exit w/return values
251 Q STR
Note: See TracBrowser for help on using the repository browser.