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/XUMFHPQ.m@ 738

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1XUMFHPQ ;ISS/RAM - MFS param server-side handler ;06/28/00
2 ;;8.0;KERNEL;**299**;Jul 10, 1995
3 ;
4 Q
5 ;
6MAIN ; -- entry point
7 ;
8 N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,TYPE
9 N VALUE,PARAM,ROOT,SEG,HLSCS,MTYP
10 ;
11 D INIT,PROCESS,RESPONSE,SEND,EXIT
12 ;
13 Q
14 ;
15INIT ; -- initialize
16 ;
17 K ^TMP("DILIST",$J),^TMP("DIERR",$J)
18 K ^TMP("HLS",$J),^TMP("HLA",$J)
19 ;
20 S ERROR=0,CNT=1,MTYP="HLA"
21 S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
22 ;
23 Q
24 ;
25PROCESS ; -- pull message text
26 ;
27 F X HLNEXT Q:HLQUIT'>0 D
28 .Q:$P(HLNODE,HLFS)=""
29 .D @($P(HLNODE,HLFS))
30 ;
31 Q
32 ;
33MSH ; -- MSH segment
34 ;
35 Q
36 ;
37MSA ; -- MSA segment
38 ;
39 N CODE
40 ;
41 S CODE=$P(HLNODE,HLFS,2)
42 ;
43 I CODE="AE"!(CODE="AR") D
44 .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
45 .D EM^XUMFHPR(ERROR,.ERR)
46 ;
47 Q
48 ;
49QRD ; -- QRD segment
50 ;
51 Q:ERROR
52 ;
53 N WHO,WHAT
54 ;
55 S WHO=$P(HLNODE,HLFS,9)
56 I WHO="" D Q
57 .S ERROR="1^QRD segment has null missing WHO parameter"
58 .D EM^XUMFHPR(ERROR,.ERR)
59 S WHAT=$P(HLNODE,HLFS,10)
60 I WHAT="" D Q
61 .S ERROR="1^QRD segment has null missing WHAT parameter"
62 .D EM^XUMFHPR(ERROR,.ERR)
63 ;
64 S IFN=+WHAT
65 I IFN'=4.001 S ERROR="1^QRD segment invalid WHAT for protocol" Q
66 ;
67 S IEN=$$FIND1^DIC(4.001,,"B",$P(WHO,HLCS))
68 ;
69 I 'IEN D Q
70 .S ERROR="1^"_$P(WHO,HLCS)_" not a supported master file"
71 ;
72 Q
73 ;
74 ;
75RESPONSE ; -- build MFR
76 ;
77 D INI1,MSA1,QRD1,MFI1,MFE1,ZZZ1,ZZS1
78 ;
79 Q
80 ;
81INI1 ; -- initialize
82 ;
83 Q:ERROR
84 ;
85 D MAIN^XUMFXP(IFN,IEN,11,.PARAM,.ERROR)
86 I $G(ERROR) D
87 .S ERROR="1error INI1 of XUMFHPQ"
88 .D EM^XUMFHPR(ERROR,.ERR)
89 ;
90 Q
91 ;
92MSA1 ; - ACK
93 ;
94 S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
95 S CNT=CNT+1
96 ;
97 Q
98 ;
99QRD1 ; -- query definition segment
100 ;
101 Q:ERROR
102 ;
103 N QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
104 ;
105 S QDT=$G(^TMP("XUMF MFS",$J,"PARAM","QDT"))
106 S QFC=$G(^TMP("XUMF MFS",$J,"PARAM","QFC"))
107 S QP=$G(^TMP("XUMF MFS",$J,"PARAM","QP"))
108 S QID=$G(^TMP("XUMF MFS",$J,"PARAM","QID"))
109 S ZDRT=$G(^TMP("XUMF MFS",$J,"PARAM","DRT"))
110 S ZDRDT=$G(^TMP("XUMF MFS",$J,"PARAM","DRDT"))
111 S QLR=$G(^TMP("XUMF MFS",$J,"PARAM","QLR"))
112 S WHO=$G(^TMP("XUMF MFS",$J,"PARAM","WHO"))
113 S WHAT=$G(^TMP("XUMF MFS",$J,"PARAM","WHAT"))
114 S WDDC=$G(^TMP("XUMF MFS",$J,"PARAM","WDDC"))
115 S WDCVQ=$G(^TMP("XUMF MFS",$J,"PARAM","WDCVQ"))
116 S QRL=$G(^TMP("XUMF MFS",$J,"PARAM","QRL"))
117 S QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
118 S QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
119 S ^TMP(MTYP,$J,CNT)=QRD
120 S CNT=CNT+1
121 ;
122 Q
123 ;
124MFI1 ; master file identifier segment
125 ;
126 Q:ERROR
127 ;
128 N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
129 ;
130 S ID=$G(^TMP("XUMF MFS",$J,"PARAM","MFI"))
131 S APP=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
132 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","FLEV"))
133 S ENDT=$G(^TMP("XUMF MFS",$J,"PARAM","ENDT"))
134 S EFFDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFIEDT"))
135 S RESP=$G(^TMP("XUMF MFS",$J,"PARAM","RLC"))
136 S:APP="" APP="MFS" S:EVENT="" EVENT="REP" S:RESP="" RESP="NE"
137 S:ENDT="" ENDT=$$NOW^XLFDT S:EFFDT="" EFFDT=$$NOW^XLFDT
138 S MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
139 I $E(MFI)="-" S ERROR=MFI Q
140 S ^TMP(MTYP,$J,CNT)=MFI
141 S CNT=CNT+1
142 ;
143 Q
144 ;
145MFE1 ; master file entry segment
146 ;
147 Q:ERROR
148 ;
149 N EVENT,MFN,EDT,CODE,MFE
150 ;
151 S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))
152 S MFN=$G(^TMP("XUMF MFS",$J,"PARAM","MFNCID"))
153 S EDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))
154 S CODE=$G(^TMP("XUMF MFS",$J,"PARAM","PKV"))
155 S:EDT="" EDT=$$NOW^XLFDT S:EVENT="" EVENT="MAD"
156 S MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
157 I $E(MFE)="-" S ERROR=MFE Q
158 S ^TMP(MTYP,$J,CNT)=MFE
159 S CNT=CNT+1
160 ;
161 Q
162 ;
163ZZZ1 ; ZZZ segment
164 ;
165 Q:ERROR
166 ;
167 N NODE,SEQ,VALUE,FIELD
168 ;
169 S NODE=""
170 ;
171 ;zero node
172 F SEQ=1:1:6 D
173 .S FIELD=".0"_SEQ
174 .S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
175 .S $P(NODE,HLFS,SEQ)=VALUE
176 ;
177 ;mfe node
178 F SEQ=1:1:9 D
179 .S FIELD="4."_SEQ
180 .S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
181 .S $P(NODE,HLFS,SEQ+6)=VALUE
182 F SEQ=1,2,4:1:7 D
183 .S FIELD="4.1"_SEQ
184 .S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
185 .S $P(NODE,HLFS,SEQ+15)=VALUE
186 ;
187 S ^TMP(MTYP,$J,CNT)="ZMF"_HLFS_NODE
188 S CNT=CNT+1
189 ;
190 Q
191 ;
192ZZS1 ; - ZZS segment
193 ;
194 Q:ERROR
195 ;
196 N IDX,FLD,VALUE,NODE
197 ;
198 S IDX=0
199 F S IDX=$O(^DIC(4.001,IEN,1,IDX)) Q:'IDX D
200 .S IENS=IDX_","_IEN_",",NODE=""
201 .F I=1:1:9 D
202 ..S FLD=".0"_I
203 ..S VALUE=$$GET1^DIQ(4.011,IENS,FLD)
204 ..S $P(NODE,HLFS,I)=VALUE
205 .;
206 .S NODE="ZZS"_HLFS_NODE
207 .S ^TMP(MTYP,$J,CNT)=NODE
208 .S CNT=CNT+1
209 ;
210 Q
211 ;
212SEND ; -- send HL7 message
213 ;
214 S HLP("PRIORITY")="I"
215 ;
216 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
217 ;
218 ; check for error
219 I ($P($G(HLRESLT),U,3)'="") D Q
220 .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
221 ;
222 ; successful call, message ID returned
223 S ERROR="0^"_$P($G(HLRESLT),U,1)
224 ;
225 Q
226 ;
227EXIT ; -- exit
228 ;
229 D CLEAN^DILF
230 ;
231 K ^TMP("HLS",$J),^TMP("HLA",$J)
232 K ^TMP("XUMF MFS",$J)
233 ;
234 Q
235 ;
Note: See TracBrowser for help on using the repository browser.