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/XUMFI.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.0 KB
RevLine 
[613]1XUMFI ;CIOFO-SF/RAM - Master File Interface ;8/14/06
2 ;;8.0;KERNEL;**206,217,218,335,261,369**;Jul 10, 1995;Build 27
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 XUMFP to initialize the PARAM array.
9 ; See XUMFP 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^XUMFI0,BUILD,LLNK,SEND,EXIT
22 ;
23 ;
24 Q
25 ;
26BUILD ; -- build message
27 ;
28 I MFK D MFK Q
29 ;
30 Q:ERROR
31 ;
32 N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI,MFN,EDT,CODE,MFE
33 ;
34 I QUERY D QRD Q:MFQ
35 ;
36 D MFI
37 ;
38 I GROUP D GROUP Q
39 ;
40 D MFE,ZZZ
41 ;
42 Q
43 ;
44MFK ; -- master file acknowledgement
45 ;
46 N X
47 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
48 S ^TMP(MTYP,$J,CNT)=X
49 S CNT=CNT+1
50 ;
51 Q
52 ;
53QRD ; -- query definition segment
54 ;
55 I TYPE>10 D
56 .S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
57 .S CNT=CNT+1
58 ;
59 Q:ERROR
60 ;
61 N QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
62 ;
63 S QDT=$G(^TMP("XUMF MFS",$J,"PARAM","QDT"))
64 S QFC=$G(^TMP("XUMF MFS",$J,"PARAM","QFC"))
65 S QP=$G(^TMP("XUMF MFS",$J,"PARAM","QP"))
66 S QID=$G(^TMP("XUMF MFS",$J,"PARAM","QID"))
67 S ZDRT=$G(^TMP("XUMF MFS",$J,"PARAM","DRT"))
68 S ZDRDT=$G(^TMP("XUMF MFS",$J,"PARAM","DRDT"))
69 S QLR=$G(^TMP("XUMF MFS",$J,"PARAM","QLR"))
70 S WHO=$G(^TMP("XUMF MFS",$J,"PARAM","WHO"))
71 S WHAT=$G(^TMP("XUMF MFS",$J,"PARAM","WHAT"))
72 S WDDC=$G(^TMP("XUMF MFS",$J,"PARAM","WDDC"))
73 S WDCVQ=$G(^TMP("XUMF MFS",$J,"PARAM","WDCVQ"))
74 S QRL=$G(^TMP("XUMF MFS",$J,"PARAM","QRL"))
75 S QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
76 S QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
77 S ^TMP(MTYP,$J,CNT)=QRD
78 S CNT=CNT+1
79 ;
80 Q
81 ;
82MFI ; master file identifier segment
83 ;
84 Q:ERROR
85 ;
86 N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
87 ;
88 S ID=$G(^TMP("XUMF MFS",$J,"PARAM","MFI"))
89 S APP=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
90 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","FLEV"))
91 S ENDT=$G(^TMP("XUMF MFS",$J,"PARAM","ENDT"))
92 S EFFDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFIEDT"))
93 S RESP=$G(^TMP("XUMF MFS",$J,"PARAM","RLC"))
94 S:APP="" APP="MFS" S:EVENT="" EVENT="REP" S:RESP="" RESP="NE"
95 S:ENDT="" ENDT=$$NOW^XLFDT S:EFFDT="" EFFDT=$$NOW^XLFDT
96 S MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
97 I $E(MFI)="-" S ERROR=MFI Q
98 S ^TMP(MTYP,$J,CNT)=MFI
99 S CNT=CNT+1
100 ;
101 Q
102 ;
103MFE ; master file entry segment
104 ;
105 Q:ERROR
106 ;
107 N EVENT,MFN,EDT,CODE,MFE
108 ;
109 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))
110 S MFN=$G(^TMP("XUMF MFS",$J,"PARAM","MFNCID"))
111 S EDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))
112 S CODE=$G(^TMP("XUMF MFS",$J,"PARAM","PKV"))
113 S:EDT="" EDT=$$NOW^XLFDT S:EVENT="" EVENT="MAD"
114 S MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
115 I $E(MFE)="-" S ERROR=MFE Q
116 S ^TMP(MTYP,$J,CNT)=MFE
117 S CNT=CNT+1
118 ;
119 Q
120 ;
121ZZZ ; [Z...] segment
122 ;
123 Q:ERROR
124 ;
125 N SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
126 N SEQ0,SEQ9,CNT1,CNT2,NODE,XXX
127 ;
128 S SEG="",SEQ=0
129 F S SEG=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG)) Q:SEG="" D
130 .S ZZZ=SEG
131 .F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
132 ..;
133 ..S SEQ1=$P(SEQ,"."),SEQ2=$P(SEQ,".",2)
134 ..S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
135 ..;
136 ..I SEQ3 D SUBCOMP Q
137 ..;
138 ..S FLD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
139 ..;
140 ..I 'FLD D
141 ...S FILE=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
142 ...S IENS=$G(^TMP("XUMF MFS",$J,"PARAM","IENS",SEG,SEQ))
143 ...S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
144 ...S ZDTYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
145 ...I $P(ZDTYP,U,3)[":" S FIELD=FIELD_$P(ZDTYP,U,3)
146 ...S VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
147 ...S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
148 ..I FLD D
149 ...S ZDTYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FLD))
150 ...I $P(ZDTYP,U,3)[":" S FLD=FLD_$P(ZDTYP,U,3)
151 ...S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
152 ...S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
153 ..;
154 ..S ZZZ(SEQ)=VALUE
155 .;
156 .S X=0
157 .F S X=$O(ZZZ(X)) Q:'X D
158 ..S SEQ1=$P(X,"."),SEQ2=+$P(X,".",2)
159 ..S XXX(SEQ1,SEQ2)=ZZZ(X)
160 .K ZZZ
161 .M ZZZ=XXX
162 .;
163 .K NODE
164 .S (SEQ,SEQ0,SEQ9,SEQ1,CNT1,CNT2)=0,NODE=""
165 .F S SEQ1=$O(ZZZ(SEQ1)) Q:'SEQ1 D
166 ..S SEQ2=0,VALUE=$G(ZZZ(SEQ1,SEQ2))
167 ..F S SEQ2=$O(ZZZ(SEQ1,SEQ2)) Q:'SEQ2 D
168 ...S $P(VALUE,HLCS,SEQ2)=ZZZ(SEQ1,SEQ2)
169 ..S NODE(CNT1)=$G(NODE(CNT1))
170 ..I NODE(CNT1)'="",$L(NODE(CNT1)_VALUE)>200 D
171 ...S CNT1=CNT1+1,SEQ9=SEQ0+SEQ9
172 ..S SEQ=$S('CNT1:SEQ1,1:SEQ1-SEQ9)
173 ..S $P(NODE(CNT1),HLFS,SEQ)=VALUE
174 ..S SEQ0=SEQ-1
175 .;
176 .S NODE=SEG_HLFS_$G(NODE(0)) K NODE(0)
177 .;
178 .M ^TMP(MTYP,$J,CNT)=NODE
179 .S CNT=CNT+1
180 .;
181 .I $D(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5)) D
182 ..S X=0 F S X=$O(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5,X)) Q:'X D
183 ...S IENS=$G(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5,X))
184 ...S VALUE=$$GET1^DIQ(9.818,IENS,.01),$P(NODE,HLFS,6)=VALUE
185 ...S VALUE=$$GET1^DIQ(9.818,IENS,2),$P(NODE,HLFS,7)=VALUE
186 ...S ^TMP(MTYP,$J,CNT)=NODE
187 ...S CNT=CNT+1
188 ;
189 Q
190 ;
191SUBCOMP ; -- subcomponents
192 ;
193 N A,YYY
194 ;
195 M A=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS")
196 S YYY=""
197 ;
198 S SEQ3=0
199 F S SEQ3=$O(A(SEQ3)) Q:'SEQ3 D
200 .S FLD=$O(A(SEQ3,0))
201 .S ZDTYP=$G(A(SEQ3,FLD))
202 .I $P(ZDTYP,U,3)[":" S FLD=FLD_$P(ZDTYP,U,3)
203 .S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
204 .S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLSCS,1)
205 .S $P(YYY,HLSCS,SEQ3)=VALUE
206 ;
207 S ZZZ(SEQ)=YYY
208 ;
209 Q
210 ;
211GROUP ; -- query group records
212 ;
213 Q:ERROR
214 ;
215 S IEN=0
216 F S IEN=$O(^TMP("XUMF MFS",$J,"PARAM","IEN",IEN)) Q:'IEN D
217 .K ^TMP("XUMF MFS",$J,"PARAM","PKV")
218 .K ^TMP("XUMF MFS",$J,"PARAM","IENS")
219 .S ^TMP("XUMF MFS",$J,"PARAM","PKV")=^TMP("XUMF MFS",$J,"PARAM",IEN,"PKV")
220 .M ^TMP("XUMF MFS",$J,"PARAM","IENS")=^TMP("XUMF MFS",$J,"PARAM",IEN,"IENS")
221 .D MFE,ZZZ
222 ;
223 Q
224 ;
225SEND ; -- send HL7 message
226 ;
227 I 'MFK,ERROR Q
228 ;
229 S HLP("PRIORITY")="I"
230 ;
231 I 'TYPE D GENERATE^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
232 I TYPE,(TYPE<10) D DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
233 I (TYPE>9),$G(HLMTIENS) D
234 .D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
235 ;
236 ; check for error
237 I ($P($G(HLRESLT),U,3)'="") D Q
238 .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
239 ;
240 ; successful call, message ID returned
241 S ERROR="0^"_$P($G(HLRESLT),U,1)
242 ;
243 Q
244 ;
245EXIT ; -- exit
246 ;
247 D CLEAN^DILF
248 ;
249 K ^TMP("HLS",$J),^TMP("HLA",$J)
250 K ^TMP("XUMF MFS",$J)
251 ;
252 Q
253 ;
254LLNK ; -- dynamic addressing BROADCAST
255 ;
256 Q:TYPE>9
257 ;
258 I $G(^TMP("XUMF MFS",$J,"PARAM","LLNK"))'="" D Q
259 .S HLL("LINKS",1)=^TMP("XUMF MFS",$J,"PARAM","LLNK")
260 ;
261 Q:'$$SERVER()
262 ;
263 Q:TYPE
264 Q:'$G(^TMP("XUMF MFS",$J,"PARAM","BROADCAST"))
265 ;
266 N I,J,LLNK
267 ;
268 S (I,J)=0
269 F S I=$O(^HLCS(870,"C",I)) Q:'I D
270 .S J=$O(^HLCS(870,"C",I,0)) Q:'J
271 .S LLNK=$P($G(^HLCS(870,J,0)),U)
272 .S HLL("LINKS",I)="XUMF MFK^"_LLNK
273 ;
274 Q
275 ;
276SERVER() ; -- servers
277 ;
278 N I
279 ;
280 S I=$$KSP^XUPARAM("INST") Q:'I 0
281 ;
282 Q:I=442 1 ;BP TEST
283 Q:I=12000 1 ;FORUM
284 Q:I=100002 1 ;HEC
285 ;
286 Q 0
287 ;
Note: See TracBrowser for help on using the repository browser.