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/XUMFXI.m@ 1724

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1XUMFXI ;ISS/RAM - MFS build message ;06/28/00
2 ;;8.0;KERNEL;**299,382**;Jul 10, 1995
3 ;
4 ; This routine is the Master File Server HL7 message builder API.
5 ; The routine will generate messages for both trigger events and
6 ; queries.
7 ;
8 ; Use the routine XUMFXP to initialize the PARAM array.
9 ; See XUMFXP for a full description of the parameters.
10 ;
11 ; use of $O(^HLCS(870,"C",institution_ptr)) supported by IA# 3550
12 ;
13MAIN(IFN,IEN,TYPE,PARAM,ERROR) ; -- entry point
14 ;
15 ;
16 N HLFS,HLCS,HLRESLT,QUERY,UPDATE,ALL,CNT,ROOT,PROTOCOL,MFR,MFQ,MTYP,I
17 N ARRAY,GROUP,MFK,CDSYS,J,HLSCS
18 ;
19 M ^TMP("XUMF MFS",$J,"PARAM")=PARAM K PARAM
20 ;
21 D INIT,BUILD,LLNK,SEND,EXIT
22 ;
23 ;
24 Q
25 ;
26INIT ; -- initialize
27 ;
28 K ^TMP("DILIST",$J),^TMP("DIERR",$J)
29 K ^TMP("HLS",$J),^TMP("HLA",$J)
30 ;
31 S IEN=$G(IEN),IFN=$G(IFN)
32 S TYPE=$G(TYPE),ERROR=$G(ERROR),CNT=1
33 S UPDATE=$S(TYPE#2:0,1:1)
34 S QUERY='UPDATE
35 S GROUP=$S(UPDATE:0,TYPE[5:1,TYPE[7:1,1:0)
36 S ARRAY=$S(UPDATE:0,TYPE[3:1,TYPE[7:1,1:0)
37 S ALL=$S(IEN["ALL":1,1:0)
38 S PROTOCOL=$G(^TMP("XUMF MFS",$J,"PARAM","PROTOCOL"))
39 S MFR=$S(UPDATE:0,TYPE>10:1,1:0)
40 S MFQ=$S(UPDATE:0,'MFR:1,1:0)
41 S MFK=$S(TYPE=10:1,1:0)
42 S MTYP=$S(MFR:"HLA",MFK:"HLA",1:"HLS")
43 ;
44 ; -- get variables from HL7 package
45 I $O(HL(""))="" D INIT^HLFNC2(PROTOCOL,.HL)
46 I $O(HL(""))="" S ERROR="1^"_$P(HL,"^",2) Q
47 S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
48 ;
49 Q:ERROR
50 Q:MFK
51 ;
52 ; -- check parameters
53 I 'QUERY,'UPDATE S ERROR="1^invalid message type" Q
54 I 'IFN S ERROR="1^invalid file number" Q
55 I 'IEN,'ALL,'MFK S ERROR="1^invalid IEN" Q
56 I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
57 I UPDATE,'IEN S ERROR="1^update message requires an IEN" Q
58 ;
59 ; -- get root of file
60 S ROOT=$$ROOT^DILFD(IFN,,1)
61 ;
62 ; -- if IEN array input, merge with param
63 I 'ALL,'IEN,$O(IEN(0)) M ^TMP("XUMF MFS",$J,"PARAM","IEN")=IEN
64 ;
65 ; -- if CDSYS and ALL get entries
66 S CDSYS=$G(^TMP("XUMF MFS",$J,"PARAM","CDSYS"))
67 I ALL,CDSYS'="" D
68 .S I=0 F S I=$O(@ROOT@("XUMFIDX",CDSYS,I)) Q:'I D
69 ..S J=$O(@ROOT@("XUMFIDX",CDSYS,I,0))
70 ..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
71 ;
72 ; -- get ALL file 'national' entries
73 I ALL,'$D(^TMP("XUMF MFS",$J,"PARAM","IEN")) D
74 .S I=0 F S I=$O(@ROOT@("AVUID",I)) Q:'I D
75 ..S J=$O(@ROOT@("AVUID",I,0))
76 ..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
77 ;
78 Q
79 ;
80BUILD ; -- build message
81 ;
82 I MFK D MFK Q
83 ;
84 Q:ERROR
85 ;
86 N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI,MFN,EDT,CODE,MFE
87 ;
88 I QUERY D QRD Q:MFQ
89 ;
90 D MFI
91 ;
92 I GROUP D GROUP Q
93 ;
94 D MFE,RDT
95 ;
96 Q
97 ;
98MFK ; -- master file acknowledgement
99 ;
100 N X,I,I1,I2
101 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
102 S ^TMP(MTYP,$J,CNT)=X
103 S CNT=CNT+1
104 ;
105 S I1="",I=0
106 F S I1=$O(^TMP("XUMF ERROR",$J,I1)) Q:'$L(I1) D
107 .S I2="" F S I2=$O(^TMP("XUMF ERROR",$J,I1,I2)) Q:'$L(I2) D
108 ..S X=$G(^(I2))
109 ..Q:'$L(X)
110 ..S I=I+1
111 ..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
112 ..S ^TMP(MTYP,$J,CNT)=X
113 ..S CNT=CNT+1
114 ;
115 Q
116 ;
117QRD ; -- query definition segment
118 ;
119 I TYPE>10 D
120 .S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
121 .S CNT=CNT+1
122 ;
123 Q:ERROR
124 ;
125 N QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
126 ;
127 S QDT=$G(^TMP("XUMF MFS",$J,"PARAM","QDT"))
128 S QFC=$G(^TMP("XUMF MFS",$J,"PARAM","QFC"))
129 S QP=$G(^TMP("XUMF MFS",$J,"PARAM","QP"))
130 S QID=$G(^TMP("XUMF MFS",$J,"PARAM","QID"))
131 S ZDRT=$G(^TMP("XUMF MFS",$J,"PARAM","DRT"))
132 S ZDRDT=$G(^TMP("XUMF MFS",$J,"PARAM","DRDT"))
133 S QLR=$G(^TMP("XUMF MFS",$J,"PARAM","QLR"))
134 S WHO=$G(^TMP("XUMF MFS",$J,"PARAM","WHO"))
135 S WHAT=$G(^TMP("XUMF MFS",$J,"PARAM","WHAT"))
136 S WDDC=$G(^TMP("XUMF MFS",$J,"PARAM","WDDC"))
137 S WDCVQ=$G(^TMP("XUMF MFS",$J,"PARAM","WDCVQ"))
138 S QRL=$G(^TMP("XUMF MFS",$J,"PARAM","QRL"))
139 S QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
140 S QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
141 S ^TMP(MTYP,$J,CNT)=QRD
142 S CNT=CNT+1
143 ;
144 Q
145 ;
146MFI ; master file identifier segment
147 ;
148 Q:ERROR
149 ;
150 N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
151 ;
152 S ID=$G(^TMP("XUMF MFS",$J,"PARAM","MFI"))
153 S APP=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
154 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","FLEV"))
155 S ENDT=$G(^TMP("XUMF MFS",$J,"PARAM","ENDT"))
156 S EFFDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFIEDT"))
157 S RESP=$G(^TMP("XUMF MFS",$J,"PARAM","RLC"))
158 S:APP="" APP="MFS" S:EVENT="" EVENT="REP" S:RESP="" RESP="NE"
159 S:ENDT="" ENDT=$$NOW^XLFDT S:EFFDT="" EFFDT=$$NOW^XLFDT
160 S MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
161 I $E(MFI)="-" S ERROR=MFI Q
162 S ^TMP(MTYP,$J,CNT)=MFI
163 S CNT=CNT+1
164 ;
165 Q
166 ;
167MFE ; master file entry segment
168 ;
169 Q:ERROR
170 ;
171 N EVENT,MFN,EDT,CODE,MFE
172 ;
173 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))
174 S MFN=$G(^TMP("XUMF MFS",$J,"PARAM","MFNCID"))
175 S EDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))
176 S CODE=$G(^TMP("XUMF MFS",$J,"PARAM","PKV"))
177 S:EDT="" EDT=$$NOW^XLFDT S:EVENT="" EVENT="MAD"
178 S MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
179 I $E(MFE)="-" S ERROR=MFE Q
180 S ^TMP(MTYP,$J,CNT)=MFE
181 S CNT=CNT+1
182 ;
183 Q
184 ;
185RDT ; table row definition/data segment
186 ;
187 Q:ERROR
188 ;
189 N SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
190 N SEQ0,SEQ9,CNT1,CNT2,NODE,XXX,LKUP
191 ;
192 S SEQ=0
193 F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ D
194 .;
195 .S FLD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
196 .;
197 .I 'FLD D
198 ..S FILE=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
199 ..S IENS=$G(^TMP("XUMF MFS",$J,"PARAM","IENS",SEQ))
200 ..S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
201 ..S ZDTYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
202 ..S LKUP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"LKUP"))
203 ..I LKUP S FIELD=FIELD_":"_LKUP
204 ..S VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
205 ..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
206 .I FLD D
207 ..S ZDTYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD))
208 ..S LKUP=$P(ZDTYP,U,2),ZDTYP=$P(ZDTYP,U)
209 ..I LKUP S FLD=FLD_":"_LKUP
210 ..S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
211 ..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
212 .;
213 .S ZZZ(SEQ)=VALUE
214 ;
215 K NODE
216 S (SEQ,SEQ0,SEQ9,SEQ1,CNT1)=0,NODE(0)=""
217 F S SEQ1=$O(ZZZ(SEQ1)) Q:'SEQ1 D
218 .S VALUE=ZZZ(SEQ1)
219 .I $L(NODE(CNT1)_VALUE)>200 D
220 ..S CNT1=CNT1+1,SEQ9=SEQ0+SEQ9
221 .S SEQ=$S('CNT1:SEQ1,1:SEQ1-SEQ9)
222 .S $P(NODE(CNT1),HLFS,SEQ)=VALUE
223 .S SEQ0=SEQ-1
224 ;
225 S NODE="RDT"_HLFS_$G(NODE(0)) K NODE(0)
226 ;
227 M ^TMP(MTYP,$J,CNT)=^TMP("XUMF MFS",$J,"PARAM","RDF")
228 S CNT=CNT+1
229 M ^TMP(MTYP,$J,CNT)=NODE
230 S CNT=CNT+1
231 ;
232 Q
233 ;
234GROUP ; -- query group records
235 ;
236 Q:ERROR
237 ;
238 S IEN=0
239 F S IEN=$O(^TMP("XUMF MFS",$J,"PARAM","IEN",IEN)) Q:'IEN D
240 .K ^TMP("XUMF MFS",$J,"PARAM","PKV")
241 .K ^TMP("XUMF MFS",$J,"PARAM","IENS")
242 .S ^TMP("XUMF MFS",$J,"PARAM","PKV")=^TMP("XUMF MFS",$J,"PARAM",IEN,"PKV")
243 .M ^TMP("XUMF MFS",$J,"PARAM","IENS")=^TMP("XUMF MFS",$J,"PARAM",IEN,"IENS")
244 .D MFE,RDT
245 ;
246 Q
247 ;
248SEND ; -- send HL7 message
249 ;
250 I 'MFK,ERROR Q
251 ;
252 S HLP("PRIORITY")="I"
253 ;
254 I 'TYPE D GENERATE^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
255 I TYPE,(TYPE<10) D DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
256 I (TYPE>9) D GENACK^HLMA1($G(HL("EID")),$G(HLMTIENS),$G(HL("EIDS")),"GM",1,.HLRESLT)
257 ;
258 ; check for error
259 I ($P($G(HLRESLT),U,3)'="") D Q
260 .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
261 ;
262 ; successful call, message ID returned
263 S ERROR="0^"_$P($G(HLRESLT),U,1)
264 ;
265 Q
266 ;
267EXIT ; -- exit
268 ;
269 D CLEAN^DILF
270 ;
271 K ^TMP("HLS",$J),^TMP("HLA",$J)
272 K ^TMP("XUMF MFS",$J)
273 ;
274 Q
275 ;
276LLNK ; -- dynamic addressing BROADCAST
277 ;
278 Q:TYPE>9
279 ;
280 I $G(^TMP("XUMF MFS",$J,"PARAM","LLNK"))'="" D Q
281 .S HLL("LINKS",1)=^TMP("XUMF MFS",$J,"PARAM","LLNK")
282 ;
283 Q:'$$SERVER()
284 ;
285 Q:TYPE
286 Q:'$G(^TMP("XUMF MFS",$J,"PARAM","BROADCAST"))
287 ;
288 N I,J,LLNK
289 ;
290 S (I,J)=0
291 F S I=$O(^HLCS(870,"C",I)) Q:'I D
292 .S J=$O(^HLCS(870,"C",I,0)) Q:'J
293 .S LLNK=$P($G(^HLCS(870,J,0)),U)
294 .S HLL("LINKS",I)="XUMF MFS^"_LLNK
295 ;
296 Q
297 ;
298SERVER() ; -- servers
299 ;
300 N I
301 ;
302 S I=$$KSP^XUPARAM("INST") Q:'I 0
303 ;
304 Q:I=662 1 ;VAB
305 Q:I=442 1 ;BP TEST
306 Q:I=12000 1 ;FORUM
307 Q:I=100002 1 ;HEC
308 ;
309 Q 0
310 ;
Note: See TracBrowser for help on using the repository browser.