source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMFH.m@ 1713

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1XUMFH ;CIOFO-SF/RAM - Master File HL7 Msg Handler ;11/16/05
2 ;;8.0;KERNEL;**206,209,217,218,262,335,261,390,369,416**;Jul 10, 1995;Build 5
3 ;
4 ; This routine handles Master File HL7 messages.
5 ;
6MAIN ; -- entry point
7 ;
8 N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
9 N HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD
10 N QID,WHAT,WHO,HLSCS,CDSYS,ERRCNT,IDX98
11 ;
12 D INIT,PROCESS,REPLY,EXIT
13 ;
14 Q
15 ;
16INIT ; -- initialize
17 ;
18 K ^TMP("DILIST",$J),^TMP("DIERR",$J)
19 K ^TMP("HLS",$J),^TMP("HLA",$J),^TMP("XUMF ERROR",$J)
20 ;
21 S (ERROR,CNT,TYPE,ARRAY,ERRCNT)=0
22 S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
23 ;
24 Q
25 ;
26PROCESS ; -- pull message text
27 ;
28 F X HLNEXT Q:HLQUIT'>0 D
29 .Q:$P(HLNODE,HLFS)=""
30 .D @($P(HLNODE,HLFS))
31 ;
32 Q
33 ;
34MSH ; -- MSH segment
35 ;
36 Q
37 ;
38MSA ; -- MSA segment
39 ;
40 N CODE
41 ;
42 S CODE=$P(HLNODE,HLFS,2)
43 ;
44 I CODE="AE"!(CODE="AR") D
45 .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
46 .D EM(ERROR,.ERR)
47 ;
48 Q
49 ;
50QRD ; -- QRD segment
51 ;
52 Q:ERROR
53 ;
54 S QRD="QRD,QDT,QFC,QP,QID,DRT,DRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL"
55 ;
56 F I=2:1:13 S PARAM($P(QRD,",",I))=$P(HLNODE,HLFS,I)
57 S QID=$P(HLNODE,HLFS,5)
58 S WHO=$P(HLNODE,HLFS,9)
59 I WHO="" D Q
60 .S ERROR="1^QRD segment has null missing WHO parameter"
61 .D EM(ERROR,.ERR)
62 S WHAT=$P(HLNODE,HLFS,10)
63 I WHAT="" D Q
64 .S ERROR="1^QRD segment has null missing WHAT parameter"
65 .D EM(ERROR,.ERR)
66 ;
67 S ARRAY=$S(QID["ARRAY":1,1:0)
68 S ALL=$S(WHO["ALL":1,1:0)
69 S GROUP=$S(ALL:1,(WHO["IEN"):1,1:0)
70 ;
71 S:ARRAY TYPE=$S(GROUP:7,1:3)
72 S:'ARRAY TYPE=$S(GROUP:5,1:1)
73 S:HL("MTN")="MFR" TYPE=TYPE+10
74 ;
75 S IFN=+WHAT
76 S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
77 S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
78 S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
79 S:$L(XREF)>1 PARAM("CDSYS")=XREF
80 ;
81 K:ARRAY ^TMP("XUMF ARRAY",$J)
82 ;
83 Q
84 ;
85MFI ; -- MFI segment
86 ;
87 Q:ERROR
88 Q:$G(IFN)
89 ;
90 I $P(HLNODE,HLFS,2)="" D Q
91 .S ERROR="1^MFI segment missing Master File Identifier"
92 .D EM(ERROR,.ERR)
93 S IFN=$$MFI^XUMFP($P(HLNODE,HLFS,2))
94 I 'IFN D Q
95 .S ERROR="1^IFN in MFI could not be resolved"
96 .D EM(ERROR,.ERR)
97 ;
98 Q
99 ;
100MFE ; -- MFE segment
101 ;
102 Q:ERROR
103 ;Q:$G(IEN)
104 ;
105 S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
106 ;
107 I $P(KEY,HLCS)="" D Q
108 .D EM("MFE segment NULL key "_$E(HLNODE,1,80),.ERR)
109 .
110 S XREF=$P(KEY,HLCS,3)
111 S CDSYS=$S($L(XREF)>1:XREF,1:"")
112 ;
113 S IEN=$S(CDSYS'="":$$IEN^XUMF(IFN,CDSYS,$P(KEY,HLCS)),1:$$FIND1^DIC(IFN,,"BX",$P(KEY,HLCS),XREF,,"ERR"))
114 S IEN=$S(IEN:IEN,KEY["ALL":"ALL",$G(ERR)'="":"ERROR",1:"NEW")
115 I IEN="ERROR" D Q
116 .D EM("MFE segment couldn't resolve IEN",.ERR)
117 .K ERR
118 D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
119 ;
120 Q
121 ;
122ZL7 ; -- Generic Master File
123ZIN ; -- VHA Institution segment
124ZFT ; -- VHA Facility Type segment
125LOC ; -- Location Identification segment
126ZZZ ; -- get [Z...] segment(s)
127 ;
128 Q:ERROR
129 Q:IEN="ERROR"
130 ;
131 I $G(ARRAY) D ARRAY Q
132 ;
133 N FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3,XUMFSEQ
134 ;
135 D SEGPRSE^XUMFXHL7("HLNODE","XUMFSEQ")
136 ;
137 I IFN=4,CDSYS'="",XUMFSEQ(2)'="",'$D(^DIC(4,"D",XUMFSEQ(2),IEN)) D Q
138 .D EM("Coding system/station number mismatch - record "_KEY_" not updated",.ERR)
139 ;
140 S PRE=$G(^TMP("XUMF MFS",$J,"PARAM","PRE"))
141 D:PRE'="" @(PRE)
142 ;
143 S XUMF=7
144 ;
145 S SEG=$P(HLNODE,HLFS)
146 S IENS=$S(IEN:IEN,1:"+1")_","
147 S SEQ=0
148 F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
149 .I IFN=4,SEQ=17 D NPI^XUMF Q
150 .S SEQ1=$P(SEQ,"."),SEQ2=$P(SEQ,".",2)
151 .S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
152 .I SEQ3 D SUBCOMP Q
153 .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
154 .I FIELD=".01" D
155 ..N FDA,IEN1
156 ..S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
157 ..;S VALUE=$$VALUE()
158 ..S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
159 ..S:SEQ2 VALUE=$$VAL2()
160 ..S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
161 ..S FDA(IFN,IENS,FIELD)=VALUE
162 ..D UPDATE^DIE("E","FDA","IEN1","ERR")
163 ..I $D(ERR) D
164 ...D EM("Update DIE - error message",.ERR)
165 ...K ERR
166 ..;NEW RECORD
167 ..I $D(IEN1) D
168 ...S IENS=IEN1(1)_","
169 ...D CDSYS^XUMF(CDSYS,$P(KEY,HLCS),IEN1(1))
170 .I 'FIELD D SUBFILE Q
171 .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
172 .;S VALUE=$$VALUE()
173 .S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
174 .S:SEQ2 VALUE=$$VAL2()
175 .S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
176 .S FDA(IFN,IENS,FIELD)=VALUE
177 ;
178 M FDA=FDA1
179 ;
180 D FILE^DIE("E","FDA","ERR")
181 I $D(ERR) D
182 .D EM("File DIE -- error message",.ERR)
183 .K ERR
184 ;
185 S POST=$G(^TMP("XUMF MFS",$J,"PARAM","POST"))
186 D:POST'="" @(POST)
187 ;
188 K IEN
189 ;
190 Q
191 ;
192SUBFILE ; -- process subfile record
193 ;
194 N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR
195 ;
196 S IFN=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
197 S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
198 S TYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
199 ;S VALUE=$$VALUE()
200 S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
201 S:SEQ2 VALUE=$$VAL2()
202 S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
203 ;
204 S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEG,SEQ))
205 S MKEY=$G(^TMP("XUMF MFS",$J,"PARAM","MKEY",SEG,SEQ))
206 I MULT=SEQ Q:VALUE="" D
207 .N FDA,IEN
208 .S FDA(IFN,"?+1,"_IENS,.01)=VALUE
209 .D UPDATE^DIE("E","FDA","IEN","ERR")
210 .I $D(ERR) D
211 ..D EM("update DIE call error message in SUBFILE",.ERR)
212 ..K ERR
213 .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
214 I 'MULT D
215 .N FDA,IEN
216 .S FDA(IFN,"?+1,"_IENS,.01)=MKEY
217 .D UPDATE^DIE("E","FDA","IEN","ERR")
218 .I $D(ERR) D
219 ..D EM("update DIE call error message in SUBFILE",.ERR)
220 ..K ERR
221 .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
222 .S FDA1(IFN,IENS1,.01)=MKEY
223 I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
224 S FDA1(IFN,IENS1,FIELD)=VALUE
225 ;
226 Q
227 ;
228VALUE() ; -- parse segment
229 ;
230 ;Q
231 ;
232 ;N COL
233 ;
234 ;D SEGPRSE^XUMFXHL7("HLNODE","COL")
235 ;
236 ;Q:SEQ2 COL($P(SEQ,"."))
237 ;
238 ;Q COL(SEQ)
239 ;
240 ;
241VAL2() ; -- parse component
242 ;
243 N XXX
244 ;
245 D SEQPRSE^XUMFXHL7("VALUE","XXX")
246 ;
247 Q XXX(1,SEQ2)
248 ;
249 ;
250SUBCOMP ; -- subcomponents
251 ;
252 S SEQ3=0
253 F S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3)) Q:'SEQ3 D
254 .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,0))
255 .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,FIELD))
256 .;S VALUE=$$VALUE()
257 .S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
258 .S VALUE=$$VAL2()
259 .S VALUE=$P(VALUE,HLSCS,SEQ3)
260 .S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
261 .S FDA(IFN,IENS,FIELD)=VALUE
262 ;
263 Q
264 ;
265ARRAY ; -- query data stored in array (not filed)
266 ;
267 I $P($G(KEY),HLCS)="" D Q
268 .D EM("Null KEY found in the following segment: "_$E(HLNODE,1,80),.ERR)
269 .S ERROR=ERROR_U_$G(ERR)
270 ;
271 I $G(IFN)=9.8 D Q
272 .S IDX98=$G(IDX98)+1
273 .S ^TMP("XUMF ARRAY",$J,IDX98)=HLNODE
274 ;
275 M ^TMP("XUMF ARRAY",$J,$P(KEY,HLCS))=HLNODE
276 ;
277 Q
278 ;
279REPLY ; -- master file response
280 ;
281 Q:HL("MTN")="MFR"
282 Q:HL("MTN")="MFK"
283 Q:HL("MTN")="ACK"
284 ;
285 S:(TYPE<10) TYPE=(TYPE+10)
286 ;
287 I HL("MTN")="MFQ" D
288 .S IFN=+$G(WHAT) I 'IFN D Q
289 ..S ERROR="1^REPLY MFQ couldn't resolve IFN"
290 ..D EM(ERROR,.ERR)
291 .S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
292 .S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
293 .S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
294 ;
295 S IFN=$G(IFN),IEN=$G(IEN)
296 ;
297 D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
298 D MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
299 ;
300 Q
301 ;
302EXIT ; -- cleanup, and quit
303 ;
304 I $D(^TMP("XUMF ERROR",$J)) D EM1 K ^TMP("XUMF ERROR",$J)
305 ;
306 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
307 ;
308 Q
309 ;
310EM(ERROR,ERR) ; -- error message
311 ;
312 D EM^XUMFHM(ERROR,.ERR)
313 ;
314 Q
315 ;
316 ;
317 ;N X,I,Y,XMTEXT,FLG
318 ;
319 ;S FLG=0
320 ;
321 ;D MSG^DIALOG("AM",.X,80,,"ERR")
322 ;
323 ;S X(.02)="",X(.03)=$G(ERROR),X(.04)=""
324 ;
325 ;S X=.9 F S X=$O(X(X)) Q:'X D
326 ;.I X(X)="" K X(X) Q
327 ;.I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
328 ;.I X(X)["ASSOCIATION" S FLG=1 K X(X) Q
329 ;.I X(X)["INSTITUTION" S FLG=1 K X(X) Q
330 ;.I X(X)["The entry does not exist." S FLG=1 K X(X) Q
331 ;.I X(X)["already exists." S FLG=1 K X(X) Q
332 ;
333 ;I FLG Q:'$O(X(.9))
334 ;
335 ;S ERRCNT=ERRCNT+1
336 ;
337 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".01")=""
338 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".02")=""
339 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".03")=$G(ERROR)
340 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".04")=""
341 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".05")="KEY: "_$G(KEY)_" IFN: "_$G(IFN)_" IEN: "_$G(IEN)
342 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".06")=""
343 ;S X=.9 F S X=$O(X(X)) Q:'X D
344 ;.S ^TMP("XUMF ERROR",$J,ERRCNT_"."_X)=X(X)
345 ;
346 ;Q
347 ;
348EM1 ;
349 ;
350 D EM1^XUMFHM
351 ;
352 Q
353 ;
354 ;N XMY,XMSUB
355 ;
356 ;S ^TMP("XUMF ERROR",$J,.1)="HL7 message ID: "_$G(HL("MID"))
357 ;S XMY("G.XUMF ERROR")="",XMSUB="MFS ERROR"
358 ;S XMTEXT="^TMP(""XUMF ERROR"",$J,"
359 ;
360 ;D ^XMD
361 ;
362 ;Q
363 ;
Note: See TracBrowser for help on using the repository browser.