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

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

initial load of WorldVistAEHR
File size: 7.1 KB
Line 
1XUMFXH ;ISS/RAM - MFS Handler ;06/28/00
2 ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
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,ERR,XIEN
11 N XUMFSDS
12 ;
13 D INIT,PROCESS,REPLY^XUMFXACK(ERROR),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)=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^RDF^RDT^"'[(U_$P(HLNODE,HLFS)_U)
36 .D @($P(HLNODE,HLFS))
37 ;
38 Q
39 ;
40MSH ; -- MSH segment
41 ;
42 Q
43 ;
44MSA ; -- MSA segment
45 ;
46 N CODE
47 ;
48 S CODE=$P(HLNODE,HLFS,2)
49 ;
50 I CODE="AE"!(CODE="AR") D
51 .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
52 .D EM^XUMFX(ERROR,.ERR)
53 ;
54 Q
55 ;
56MFI ; -- MFI segment
57 ;
58 Q:ERROR
59 Q:EXIT
60 ;
61 K IFN,ARRAY,MFI
62 ;
63 I $P(HLNODE,HLFS,2)="" D Q
64 .S ERROR="1^MFI segment missing Master File Identifier HLNODE: "_HLNODE
65 .D EM^XUMFX(ERROR,.ERR)
66 ;
67 S MFI=$P(HLNODE,HLFS,2),IFN=MFI
68 S:'IFN IFN=$O(^DIC(4.001,"MFI",$P(MFI,HLCS,2),0))
69 S IFN=$S(IFN:IFN,MFI="ZMF":4.001,1:0)
70 I 'IFN D Q
71 .S ERROR="1^IFN in MFI could not be resolved HLNODE: "_HLNODE
72 .D EM^XUMFX(ERROR,.ERR)
73 ;
74 ;sds flag=1; 1H is history record (use alt key for owning record)
75 S XUMFSDS=$S($P(MFI,HLCS,3)="SDS":1,1:0)
76 I XUMFSDS,MFI["History" S XUMFSDS="1H"
77 ;
78 S ARRAY=$S($G(ARRAY):1,$P(HLNODE,HLFS,3)="TEMP":1,1:0)
79 ;
80 Q
81 ;
82MFE ; -- MFE segment
83 ;
84 Q:ERROR
85 Q:EXIT
86 ;
87 K IEN
88 ;
89 N PRE,POST
90 ;
91 S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
92 ;
93 S PRE=$P($G(^DIC(4.001,+IFN,"MFE")),U,16)
94 I PRE'="" D Q:$G(EXIT)
95 .S PRE=PRE_"^XUMFXR"
96 .D @(PRE)
97 ;
98 D MFE^XUMFX(IFN,KEY,HLCS,.IEN,.ERROR) Q:ERROR
99 ;
100 S POST=$P($G(^DIC(4.001,+IFN,"MFE")),U,17)
101 I POST'="" D Q:$G(EXIT)
102 .S POST=POST_"^XUMFXR"
103 .D @(POST)
104 ;
105 I 'IEN D Q
106 .S ERROR="1^IEN not resolved in MFE File #: "_IFN_" HLNODE: "_HLNODE
107 .D EM^XUMFX(ERROR,.ERR)
108 .K ERR
109 ;
110 ; clean multiple flag
111 K:'$D(XIEN(IEN)) XIEN
112 S XIEN(IEN)=$G(XIEN(IEN))+1
113 ;
114 Q
115 ;
116RDF ; -- table row definition
117 ;
118 Q:ERROR
119 Q:EXIT
120 ;
121 I $G(ARRAY) D ARRAY Q
122 ;
123 N COL,X,Y,Z,DTYP,IDX,SEQ,VUID,DATA,NAME
124 ;
125 K ^TMP("XUMF MFS",$J,"PARAM","SEQ")
126 K ^TMP("XUMF MFS",$J,"PARAM","MULT")
127 K ^TMP("XUMF MFS",$J,"PARAM","IENS")
128 ;
129 K XXX,YYY
130 ;
131 D SEGPRSE^XUMFXHL7("HLNODE","XXX")
132 S NUMBER=XXX(1)
133 D SEQPRSE^XUMFXHL7("XXX(2)","COL") K XXX
134 I $O(COL(99999),-1)'=NUMBER D Q
135 .S ERROR="1^RDF number of columns error"
136 .D EM^XUMFX("RDF segment columns don't match number",.ERROR)
137 ;
138 ;S NUMBER=$P(HLNODE,HLFS,2)
139 ;S DATA=$P(HLNODE,HLFS,3)
140 ;
141 ;S CNT=0,Y=0
142 ;F SEQ=1:1:NUMBER D
143 ;.S Y=Y+1
144 ;.S Z=$P(DATA,HLREP,Y)
145 ;.I Y=$L(DATA,HLREP) D
146 ;..S CNT=$O(HLNODE(CNT))
147 ;..S DATA=$G(HLNODE(+CNT))
148 ;..S Z=Z_$P(DATA,HLREP)
149 ;..S Y=1
150 ;.S COL(SEQ)=Z
151 ;
152 S SEQ=0
153 F S SEQ=$O(COL(SEQ)) Q:'SEQ D
154 .S NAME=COL(SEQ,1),TYP=COL(SEQ,2) Q:NAME=""
155 .;S NAME=$P(COL(SEQ),HLCS) Q:NAME=""
156 .S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0)) Q:'IDX
157 .S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)) Q:DATA=""
158 .S YYY(NAME,SEQ)=""
159 .;
160 .;N FLD,TYP,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
161 .;S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
162 .N FLD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
163 .S FLD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4)
164 .S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14)
165 .S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID=$P(DATA,U,13)
166 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID")=VUID
167 .;
168 .I 'SUBFILE D Q
169 ..S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
170 .;
171 .; -- multiple field
172 .;
173 .I $P(DATA,U,6)'="" D ;.01 is a field
174 ..S XXX(SEQ)=$P(DATA,U,6)
175 .;
176 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
177 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")=FLD
178 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")=TYP
179 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"REPEAT")=REPEAT
180 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")=CLEAN
181 .S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE")=TIMEZONE
182 ;
183 S SEQ=0
184 F S SEQ=$O(XXX(SEQ)) Q:'SEQ D
185 .S X=XXX(SEQ),Y=$O(YYY(X,0))
186 .S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=Y
187 ;
188 Q
189 ;
190RDT ; -- table row data
191 ;
192 Q:ERROR
193 Q:EXIT
194 ;
195 K XXX
196 D SEGPRSE^XUMFXHL7("HLNODE","XXX")
197 I $O(XXX(99999),-1)'=NUMBER D Q
198 .S ERROR="1^RDF/RDT number of columns error"
199 .D EM^XUMFX("RDF/RDT segment columns don't match number",.ERROR)
200 ;
201 I $G(ARRAY) D ARRAY Q
202 ;
203 Q:'IEN
204 ;
205 N FDA,IENS,FIELD,ERR,PRE,POST,MULT,FDA1,SEQ,VUID,TIMEZONE
206 ;
207 S PRE=$P($G(^DIC(4.001,+IFN,0)),U,4)
208 I PRE'="" D
209 .S PRE=PRE_"^XUMFR"
210 .D @(PRE)
211 ;
212 S IENS=IEN_","
213 S SEQ=0
214 F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ D
215 .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
216 .S VUID=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID"))
217 .S TIMEZONE=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE"))
218 .I 'FIELD D SUBFILE Q
219 .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FIELD))
220 .S VALUE=$$VALUE()
221 .S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
222 .S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,IENS) Q:VALUE="^"
223 .S FDA(IFN,IENS,FIELD)=VALUE
224 ;
225 M FDA=FDA1
226 ;
227 D:$D(FDA) FILE^DIE(,"FDA","ERR")
228 I $D(ERR) D
229 .S ERROR="1^updating error"
230 .D EM^XUMFX("file DIE call error message in RDT",.ERR)
231 .K ERR
232 ;
233 S POST=$P($G(^DIC(4.001,+IFN,0)),U,5)
234 I POST'="" D
235 .S POST=POST_"^XUMFR"
236 .D @(POST)
237 ;
238 Q
239 ;
240SUBFILE ; -- process subfile record
241 ;
242 N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR,REPEAT,CLEAN
243 ;
244 S IFN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
245 S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
246 S TYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
247 S REPEAT=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"REPEAT")
248 S CLEAN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")
249 ;
250 I CLEAN,$G(XIEN(IEN))'>1 D
251 .N ROOT,IDX
252 .S ROOT=$$ROOT^DILFD(IFN,","_IENS,1)
253 .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
254 ..D
255 ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
256 ;
257 S VALUE=$$VALUE()
258 S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
259 ;
260 S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ))
261 ;
262 I MULT=SEQ Q:VALUE="" D
263 .N FDA,IEN
264 .S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
265 .S FDA(IFN,"?+1,"_IENS,.01)=VALUE
266 .D UPDATE^DIE(,"FDA","IEN","ERR")
267 .I $D(ERR) D Q
268 ..S ERROR="1^subfile update error SUBFILE#: "_IFN
269 ..D EM^XUMFX("update DIE call error message in SUBFILE",.ERR)
270 ..K ERR
271 .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
272 ;
273 I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
274 S:MULT'=SEQ VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
275 S:$D(IENS1) FDA1(IFN,IENS1,FIELD)=VALUE
276 ;
277 Q
278 ;
279VALUE() ; -- handle HL7 continuation nodes
280 ;
281 Q:'$O(HLNODE(0)) $P(HLNODE,HLFS,SEQ+1)
282 ;
283 N COL
284 ;
285 D SEGPRSE^XUMFXHL7("HLNODE","COL")
286 ;
287 Q COL(SEQ)
288 ;
289ARRAY ; -- query data stored in array (not filed)
290 ;
291 N X S X=KEY S X=$S($P(X,HLCS)'="":$P(X,HLCS),1:$P(X,HLCS,4)) Q:X=""
292 ;
293 M ^TMP("XUMF ARRAY",$J,IFN,X)=HLNODE
294 ;
295 Q
296 ;
297EXIT ; -- cleanup, and quit
298 ;
299 ; post processing logic
300 S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X
301 ;
302 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
303 ;
304 K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
305 ;
306 Q
307 ;
Note: See TracBrowser for help on using the repository browser.