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/XUMF1H.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1XUMF1H ;ISS/RAM - MFS Handler ;6/27/06 07:50
2 ;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
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,XUMF
10 N QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,XIEN
11 N XUMFSDS,FDA,LIST,ERRCNT,PKV,MKEY,MKEY1,TYP,MFI,IMPLY
12 ;
13 D INIT,PROCESS,REPLY,EXIT
14 ;
15 Q
16 ;
17INIT ; -- initialize
18 ;
19 K ^TMP("DILIST",$J),^TMP("DIERR",$J)
20 K ^TMP("HLS",$J),^TMP("HLA",$J)
21 K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
22 ;
23 S XUMF=1,DUZ(0)="@"
24 ;
25 S (ERROR,CNT,TYPE,ARRAY,EXIT,ERRCNT)=0
26 S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
27 S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2)
28 ;
29 Q
30 ;
31PROCESS ; -- pull message text
32 ;
33 F X HLNEXT Q:HLQUIT'>0 D
34 .Q:$P(HLNODE,HLFS)=""
35 .Q:"^MSH^MSA^QRD^MFI^MFE^ZRT^"'[(U_$P(HLNODE,HLFS)_U)
36 .D @($P(HLNODE,HLFS))
37 I $D(LIST) D LIST
38 I $D(FDA) D UPDATE
39 I $D(IFN) D POST
40 ;
41 Q
42 ;
43MSH ; -- MSH segment
44 ;
45 Q
46 ;
47MSA ; -- MSA segment
48 ;
49 N CODE
50 ;
51 S CODE=$P(HLNODE,HLFS,2)
52 ;
53 I CODE="AE"!(CODE="AR") D
54 .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
55 .D EM^XUMFX(ERROR,.ERR)
56 ;
57 Q
58 ;
59MFI ; -- MFI segment
60 ;
61 Q:ERROR
62 Q:EXIT
63 ;
64 Q
65 ;
66MFE ; -- MFE SEGMENT
67 ;
68 Q:ERROR
69 Q:EXIT
70 ;
71 S PKV=$P(HLNODE,HLFS,5),MFI=$P(PKV,"@")
72 ;
73 I $D(LIST) D LIST K LIST,LISTVUID
74 I $D(FDA) D UPDATE K FDA
75 I $D(IFN),(IFN'=$O(^DIC(4.001,"MFID",MFI,0))) D POST
76 ;
77 K IFN,IEN,PRE,POST,VUID,IMPLY
78 K ^TMP("XUMF IMPLIED LOGIC",$J)
79 ;
80 I MFI="" S ERROR="1^MFI not resolved HLNODE: "_HLNODE Q
81 S IFN=$O(^DIC(4.001,"MFID",MFI,0))
82 I 'IFN S ERROR="1^IFN not resolved HLNODE: "_HLNODE Q
83 ;
84 S VUID=$P($P(PKV,"@",2),HLCS)
85 ;
86 Q:ARRAY
87 ;
88 D MFE^XUMF0(IFN,VUID,.IEN,.ERROR) Q:ERROR
89 ;
90 D MFE0
91 ;
92 ;Implied logic flag - must be set by MFE-Processing Logic field (#4)
93 S IMPLY=+$G(^TMP("XUMF IMPLIED LOGIC",$J))
94 S IMPLY("KILL")=0
95 K ^TMP("XUMF IMPLIED LOGIC",$J)
96 ;
97 I IEN D
98 .; clean multiple flag
99 .K:'$D(XIEN(IFN,IEN)) XIEN
100 .S XIEN(IFN,IEN)=$G(XIEN(IFN,IEN))+1
101 ;
102 Q
103 ;
104ZRT ; -- data segments
105 ;
106 Q:ERROR
107 Q:EXIT
108 ;
109 I $G(ARRAY) D ARRAY Q
110 ;
111 N COL,X,Y,Z,DTYP,IDX,SEQ,DATA,NAME,VUID1,LIST1
112 N FIELD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE,WP
113 ;
114 S NAME=$P(HLNODE,HLFS,2)
115 ;
116 I 'IEN,NAME="Term" D STUB^XUMF0 Q
117 I 'IEN S ERROR="1^IEN not defined IFN: "_IFN_" VUID: "_VUID Q
118 ;
119 D ZRT0 Q:ERROR
120 ;
121 S IENS=IEN_","
122 ;
123 S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0))
124 I 'IDX S ERROR="1^parameter "_NAME_" not defined IFN: "_IFN Q
125 S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0))
126 S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
127 S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)
128 S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14),LIST1=$P(DATA,U,8)
129 S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID1=$P(DATA,U,13)
130 S WP=$P(DATA,U,16)
131 ;
132 I WP D WP Q
133 ;
134 S VALUE=$$UNESC^XUMF0($P(HLNODE,HLFS,3),.HL)
135 S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
136 ;
137 I NAME="Status" D STATUS Q
138 ;
139 I 'SUBFILE D Q
140 .S VALUE=$$VAL^XUMF0(IFN,FIELD,VUID1,VALUE,IENS) Q:VALUE="^"
141 .S FDA(IFN,IENS,FIELD)=VALUE
142 ;
143 N IENS1
144 ;
145 I LIST1 D Q
146 .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
147 .I MKEY=NAME S ZKEY=VALUE ;S:VUID1'="" LISTVUID(SUBFILE)=1
148 .I '$D(ZKEY) S ERROR="1^ZKEY error "_SUBFILE_" VUID: "_VUID Q
149 .I ((ZKEY="")!(ZKEY=$C(34,34))) S LIST(SUBFILE)="" Q
150 .S LIST(SUBFILE,ZKEY,FIELD)=VALUE
151 .I IMPLY D IMPLY
152 ;
153 I CLEAN,$G(XIEN(IFN,IEN))'>1 D
154 .N ROOT,IDX
155 .S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
156 .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
157 ..D
158 ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
159 ;
160 I MKEY=NAME Q:VALUE="" D
161 .N FDA,IEN
162 .
163 .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
164 .S FDA(SUBFILE,"?+1,"_IENS,.01)=VALUE
165 .D UPDATE^DIE(,"FDA","IEN","ERR")
166 .I $D(ERR) D Q
167 ..S ERROR="1^subfile update error SUBFILE#: "_SUBFILE
168 ..D EM(ERROR,.ERR) K ERR
169 .S IENS1=IEN(1)_","_IENS,MKEY(NAME)=IENS1
170 ;
171 I MKEY'="",MKEY'=NAME S IENS1=$G(MKEY(MKEY)) Q:IENS1=""
172 S:MKEY'=NAME VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
173 S:$D(IENS1) FDA(SUBFILE,IENS1,FIELD)=VALUE
174 I IMPLY D IMPLY
175 ;
176 Q
177 ;
178IMPLY ; -- Implied value logic
179 N PREV,ARR
180 S ARR=$S(LIST1:"LIST",1:"FDA")
181 S PREV=$S(LIST1:ZKEY,1:IENS1)
182 I MKEY=NAME D Q
183 .I IMPLY("KILL") K IMPLY("PREV") S IMPLY("KILL")=0
184 .S IMPLY("PREV",PREV)=""
185 S PREV="" F S PREV=$O(IMPLY("PREV",PREV)) Q:PREV="" D
186 .S @ARR@(SUBFILE,PREV,FIELD)=VALUE
187 S IMPLY("KILL")=1
188 Q
189 ;
190LIST ; -- process list
191 ;
192 N SUBFILE,ZKEY,FIELD,VALUE,IENS,CNT
193 ;
194 S IENS=IEN_","
195 ;
196 ;remove non-standard sub-records (not in message)
197 S SUBFILE=0
198 F S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE D
199 .N ROOT,IDX
200 .S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
201 .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
202 ..S VALUE=$$GET1^DIQ(SUBFILE,IDX_","_IENS,.01,"I")
203 ..I '$D(LIST(SUBFILE,VALUE)) D
204 ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
205 ;
206 ;update sub-records
207 S SUBFILE=0
208 F S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE D
209 .S ZKEY="",CNT=0
210 .F S ZKEY=$O(LIST(SUBFILE,ZKEY)) Q:ZKEY="" D
211 ..N IDX,ROOT
212 ..S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
213 ..S IDX=$O(@ROOT@("B",ZKEY,0))
214 ..I $O(@ROOT@("B",ZKEY,IDX)) D DELLIST(IDX)
215 ..I 'IDX D ADDLIST Q
216 ..S FIELD=0
217 ..F S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD D
218 ...N X S X=$$GET1^DIQ(SUBFILE,IDX_","_IENS,FIELD)
219 ...S VALUE=LIST(SUBFILE,ZKEY,FIELD)
220 ...Q:VALUE=X Q:(VALUE=""""&X="")
221 ...S FDA(SUBFILE,IDX_","_IENS,FIELD)=VALUE
222 ;
223 Q
224 ;
225ADDLIST ; -- add new sub-record
226 ;
227 N FDA
228 ;
229 S CNT=$G(CNT)+1
230 S FIELD=0
231 F S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD D
232 .S VALUE=LIST(SUBFILE,ZKEY,FIELD) Q:VALUE=""
233 .S FDA(SUBFILE,"+"_CNT_","_IENS,FIELD)=VALUE
234 ;
235 Q:'$D(FDA)
236 ;
237 D UPDATE^DIE(,"FDA",,"ERR")
238 I $D(ERR) D Q
239 .S ERROR="1^subfile update error SUBFILE#: "_SUBFILE
240 .D EM(ERROR,.ERR) K ERR
241 ;
242 Q
243 ;
244DELLIST(IDX) ; -- delete duplicate
245 ;
246 F S IDX=$O(@ROOT@("B",ZKEY,IDX)) Q:'IDX D
247 .N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
248 ;
249 Q
250 ;
251UPDATE ; -- FileMan update
252 ;
253 Q:ERROR
254 Q:EXIT
255 ;
256 D:$D(FDA) FILE^DIE(,"FDA","ERR")
257 I $D(ERR) D
258 .S ERROR="1^updating error"
259 .D EM(ERROR,.ERR) K ERR
260 ;
261 Q
262 ;
263ARRAY ; -- query data stored in array (not filed)
264 ;
265 S ^TMP("XUMF ARRAY",$J,IFN,VUID,$P(HLNODE,HLFS,2))=$P(HLNODE,HLFS,3)
266 ;
267 Q
268 ;
269ADD ; -- ADD-processing logic
270 ;
271 N X
272 ;
273 S X=$G(^DIC(4.001,+IFN,3)) X:X'="" X
274 ;
275 Q
276 ;
277MFE0 ; -- MFE-processing logic
278 ;
279 N X
280 ;
281 S X=$G(^DIC(4.001,+IFN,4)) X:X'="" X
282 ;
283 Q
284 ;
285ZRT0 ; -- ZRT-processing logic
286 ;
287 N X
288 ;
289 S X=$G(^DIC(4.001,+IFN,5)) X:X'="" X
290 ;
291 Q
292 ;
293POST ; -- post-processing logic
294 ;
295 N X
296 ;
297 S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X
298 ;
299 Q
300 ;
301EXIT ; -- cleanup, and quit
302 ;
303 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
304 ;
305 K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
306 ;
307 Q
308 ;
309REPLY ; -- MFK
310 ;
311 N X,I,I1,I2,CNT
312 ;
313 S CNT=1
314 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
315 S ^TMP("HLA",$J,CNT)=X
316 S CNT=CNT+1
317 ;
318 S I1="",I=0
319 F S I1=$O(^TMP("XUMF ERROR",$J,I1)) Q:'$L(I1) D
320 .S I2="" F S I2=$O(^TMP("XUMF ERROR",$J,I1,I2)) Q:'$L(I2) D
321 ..S X=$G(^(I2))
322 ..Q:'$L(X)
323 ..S I=I+1
324 ..S X="ERR"_HLFS_I_HLFS_$S($O(^TMP("XUMF ERROR",$J,I1))!$O(^TMP("XUMF ERROR",$J,I1,I2)):1,1:0)_HLFS_X
325 ..S ^TMP("HLA",$J,CNT)=X
326 ..S CNT=CNT+1
327 ;
328 D:ERROR EM^XUMF0
329 ;
330 D GENACK^HLMA1($G(HL("EID")),$G(HLMTIENS),$G(HL("EIDS")),"GM",1,.HLRESLT)
331 ;
332 ; check for error
333 ;I ($P($G(HLRESLT),U,3)'="") D Q
334 ;.S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
335 ;
336 ; successful call, message ID returned
337 ;S ERROR="0^"_$P($G(HLRESLT),U,1)
338 ;
339 Q
340 ;
341EM(ERROR,ERR) ; -- error message
342 ;
343 N X,I,Y
344 ;
345 D MSG^DIALOG("AM",.X,80,,"ERR")
346 ;
347 S ERRCNT=ERRCNT+1
348 ;
349 S ^TMP("XUMF ERROR",$J,ERRCNT_".01")=""
350 S ^TMP("XUMF ERROR",$J,ERRCNT_".02")=""
351 S ^TMP("XUMF ERROR",$J,ERRCNT_".03")=$G(ERROR)
352 S ^TMP("XUMF ERROR",$J,ERRCNT_".04")=""
353 S ^TMP("XUMF ERROR",$J,ERRCNT_".05")="VUID: "_$G(VUID)_" IFN: "_$G(IFN)_" IEN: "_IEN
354 S ^TMP("XUMF ERROR",$J,ERRCNT_".06")=""
355 S X=.9 F S X=$O(X(X)) Q:'X D
356 .S ^TMP("XUMF ERROR",$J,ERRCNT_"."_X)=X(X)
357 ;
358 Q
359 ;
360STATUS ;
361 ;
362 I VALUE=$P($$GETSTAT^XTID(IFN,,IEN_","),U) Q
363 ;
364 I SUBFILE="" S ERROR="1^status parameter error" Q
365 ;
366 N FDA
367 S FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT
368 S FDA(SUBFILE,"?+1,"_IENS,.02)=VALUE
369 D UPDATE^DIE(,"FDA",,"ERR")
370 I $D(ERR) D
371 .S ERROR="1^effective date and status error"
372 .D EM(ERROR,.ERR) K ERR
373 ;
374 Q
375 ;
376WP ;
377 ;
378 N X,Y,A,I,CNT,X1,X2,ESC
379 D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)
380 ;
381 S CNT=1
382 S A(CNT)=X(2)
383 S I=0
384 F S I=$O(X(2,I)) Q:'I D
385 .S Y=X(2,I)
386 .I $E(Y,1)=" " D Q
387 ..S A(CNT)=A(CNT)_" "
388 ..Q:$P(Y," ",2)=""
389 ..S CNT=CNT+1
390 ..S A(CNT)=$P(Y," ",2,99)
391 .S X1=$P(Y," ",1)
392 .S X2=$P(Y," ",2,99)
393 .S A(CNT)=A(CNT)_X1_$S(X2="":"",1:" ")
394 .Q:X2=""
395 .S CNT=CNT+1
396 .S A(CNT)=X2
397 ;
398 D UNESCWP^XUMF0(.A,.HL)
399 ;
400 D WP^DIE(IFN,IENS,FIELD,"K","A","ERR")
401 ;
402 I $D(ERR) D
403 .S ERROR="1^wp field error"
404 .D EM(ERROR,.ERR) K ERR
405 ;
406 Q
407 ;
Note: See TracBrowser for help on using the repository browser.