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/XUMFH4.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: 5.8 KB
Line 
1XUMFH4 ;CIOFO-SF/RAM - FORUM IMF handler ;06/28/00
2 ;;8.0;KERNEL;**217,218**;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
9 N HDT,KEY,MID,VALUE,XREF,PARAM,ROOT,SEG
10 N HLSCS,SFAC
11 ;
12 D INIT,PROCESS,BG,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)
20 ;
21 S (ERROR,CNT,TYPE)=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 S SFAC=$P(HLNODE,HLFS,4)
37 ;
38 Q
39 ;
40MSA ; -- MSA segment
41 ;
42 N CODE
43 ;
44 S CODE=$P(HLNODE,HLFS,2)
45 ;
46 I CODE="AE"!(CODE="AR") D
47 .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
48 .D EM("MSA segement error/reject message")
49 ;
50 Q
51 ;
52MFI ; -- MFI segment
53 ;
54 Q:ERROR
55 Q:$G(IFN)
56 ;
57 I $P(HLNODE,HLFS,2)="" D Q
58 .S ERROR="1^MFI segment missing Master File Identifier"
59 .D EM(ERROR,.ERR)
60 .S ERROR=ERROR_U_$G(ERR)
61 S IFN=$$MFI^XUMFP($P(HLNODE,HLFS,2))
62 I 'IFN D Q
63 .S ERROR="1^IFN in MFI could not be resolved"
64 .D EM(ERROR,.ERR)
65 .S ERROR=ERROR_U_$G(ERR)
66 ;
67 Q
68 ;
69MFE ; -- MFE segment
70 ;
71 Q:ERROR
72 Q:$G(IEN)
73 ;
74 S KEY=$P(HLNODE,HLFS,5)
75 ;
76 I $E(KEY,1,3)'=$E(SFAC,1,3) D Q
77 .S ERROR="1^sending facility not authorized to edit this entry"
78 .D EM(ERROR)
79 ;
80 S XREF=$P(KEY,HLCS,3)
81 S:KEY'="" IEN=$$FIND1^DIC(IFN,,"BX",$P(KEY,HLCS),XREF,,"ERR")
82 S IEN=$S(IEN:IEN,$G(ERR)'="":"ERROR",1:"NEW")
83 I IEN="ERROR" D Q
84 .S ERROR="1^MFE segment couldn't resolve IEN"
85 .D EM(ERROR,.ERR)
86 .K ERR
87 D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
88 ;
89 Q
90 ;
91ZIN ; -- VHA Institution segment
92ZFT ; -- VHA Facility Type
93ZZZ ; -- get [Z...] segment(s)
94 ;
95 Q:ERROR
96 ;
97 N FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3
98 ;
99 S PRE=$G(^TMP("XUMF MFS",$J,"PARAM","PRE"))
100 D:PRE'="" @(PRE)
101 ;
102 S XUMF=1
103 ;
104 S SEG=$P(HLNODE,HLFS)
105 S IENS=$S(IEN:IEN,1:"+1")_","
106 S SEQ=0
107 F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
108 .S SEQ1=$P(SEQ,"."),SEQ2=$P(SEQ,".",2)
109 .S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
110 .I SEQ3 D SUBCOMP Q
111 .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
112 .I FIELD=".01" D
113 ..N FDA,IEN1
114 ..S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
115 ..S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
116 ..S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
117 ..S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
118 ..S FDA(IFN,IENS,FIELD)=VALUE
119 ..D UPDATE^DIE("E","FDA","IEN1","ERR")
120 ..I $D(ERR) D
121 ...D EM("update DIE call error message in ZZZ",.ERR)
122 ...K ERR
123 ..I $D(IEN1) S IENS=IEN1(1)_","
124 .I 'FIELD D SUBFILE Q
125 .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
126 .S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
127 .S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
128 .S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
129 .S FDA(IFN,IENS,FIELD)=VALUE
130 ;
131 M FDA=FDA1
132 K FDA1
133 ;
134 D FILE^DIE("E","FDA","ERR")
135 I $D(ERR) D
136 .D EM("file DIE call error message in ZZZ",.ERR)
137 .K ERR
138 ;
139 S POST=$G(^TMP("XUMF MFS",$J,"PARAM","POST"))
140 D:POST'="" @(POST)
141 ;
142 Q
143 ;
144SUBFILE ; -- process subfile record
145 ;
146 N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR
147 ;
148 S IFN=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
149 S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
150 S TYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
151 S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
152 S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
153 S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
154 ;
155 S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT","ZIN",SEQ))
156 S MKEY=$G(^TMP("XUMF MFS",$J,"PARAM","MKEY","ZIN",SEQ))
157 I MULT=SEQ Q:VALUE="" D
158 .N FDA,IEN
159 .S FDA(IFN,"?+1,"_IENS,.01)=VALUE
160 .D UPDATE^DIE("E","FDA","IEN","ERR")
161 .I $D(ERR) D
162 ..D EM("update DIE call error message in SUBFILE",.ERR)
163 ..K ERR
164 .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
165 I 'MULT D
166 .N FDA,IEN
167 .S FDA(IFN,"?+1,"_IENS,.01)=MKEY
168 .D UPDATE^DIE("E","FDA","IEN","ERR")
169 .I $D(ERR) D
170 ..D EM("update DIE call error message in SUBFILE",.ERR)
171 ..K ERR
172 .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
173 .S FDA1(IFN,IENS1,.01)=MKEY
174 I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
175 S FDA1(IFN,IENS1,FIELD)=VALUE
176 ;
177 Q
178 ;
179SUBCOMP ; -- subcomponents
180 ;
181 S SEQ3=0
182 F S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3)) Q:'SEQ3 D
183 .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,0))
184 .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,FIELD))
185 .S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
186 .S VALUE=$P(VALUE,HLCS,SEQ2)
187 .S VALUE=$P(VALUE,HLSCS,SEQ3)
188 .S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
189 .S FDA(IFN,IENS,FIELD)=VALUE
190 ;
191 Q
192 ;
193BG ; -- background job
194 ;
195 Q:ERROR
196 Q:HL("MTN")'="MFN"
197 ;
198 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
199 ;
200 S ZTRTN="BRDCST^XUMFH4"
201 S ZTDESC="XUMF Broadcast IMF address changes"
202 S ZTDTH=$$NOW^XLFDT
203 S ZTSAVE("IEN")=""
204 S ZTIO=""
205 ;
206 D ^%ZTLOAD
207 ;
208 Q
209 ;
210BRDCST ; -- broadcast update
211 ;
212 N PARAM
213 ;
214 K ^TMP("HLS",$J),^TMP("HLA",$J),^TMP("XUMF MFS",$J),PARAM
215 ;
216 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFN",0))
217 S PARAM("BROADCAST")=1
218 D MAIN^XUMFP(4,IEN,0,.PARAM,.ERROR) Q:ERROR
219 D MAIN^XUMFI(4,IEN,0,.PARAM,.ERROR)
220 ;
221 S ZTREQ="@"
222 ;
223 Q
224 ;
225REPLY ; -- master file response
226 ;
227 Q:HL("MTN")="MFK"
228 ;
229 S:(TYPE<10) TYPE=(TYPE+10)
230 ;
231 S IFN=$G(IFN),IEN=$G(IEN)
232 ;
233 D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
234 D MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
235 ;
236 Q
237 ;
238EXIT ; -- cleanup, and quit
239 ;
240 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
241 ;
242 Q
243 ;
244EM(ERROR,ERR) ; -- error message
245 ;
246 N X,XMSUB,XMY,XMTEXT,FLG
247 ;
248 S FLG=0
249 ;
250 D MSG^DIALOG("AM",.X,80,,"ERR")
251 ;
252 S X(.1)="HL7 message ID: "_$G(HL("MID"))
253 S X(.2)="",X(.3)=$G(ERROR),X(.4)=""
254 S XMSUB="IMF HANDLER ERROR MESSAGE"
255 S XMY="G.XUMF INSTITUTION"
256 S XMTEXT="X("
257 ;
258 S X=.9 F S X=$O(X(X)) Q:'X D
259 .I X(X)="" K X(X) Q
260 .I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
261 ;
262 I FLG Q:'$O(X(.9))
263 ;
264 D ^XMD
265 ;
266 Q
267 ;
Note: See TracBrowser for help on using the repository browser.