source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMFQR.m@ 1154

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1XUMFQR ;ISS/RAM - Master File Query Response ;06/28/00
2 ;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
3 ;
4 Q
5 ;
6MAIN ; -- main
7 ;
8 N FIELD1,IDX,IDX1,NAME1,SUBFILE1,DATA1,IEN1,TYP1,MKEY,MKEY1,TYP,VUID,VUID1
9 N MFI,SEQ,NAME,QRD,SEQ,SUBFILE,IEN,CNT,DATA,ERROR
10 ;
11 D INIT,PROCESS,MFR,SEND,EXIT
12 ;
13 Q
14 ;
15INIT ; -- initialize
16 ;
17 K ^TMP("HLA",$J)
18 ;
19 S ERROR=0,CNT=1
20 ;
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 .Q:"^MSH^MSA^QRD^"'[(U_$P(HLNODE,HLFS)_U)
30 .D @($P(HLNODE,HLFS))
31 ;
32 Q
33 ;
34MSH ; -- MSH segment
35 ;
36 Q
37 ;
38QRD ; -- QRD segment
39 ;
40 S MFI=$P(HLNODE,HLFS,10)
41 I MFI="" S ERROR="1^MFI not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
42 S IFN=$O(^DIC(4.001,"MFID",MFI,0))
43 I 'IFN S ERROR="1^IFN not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
44 I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
45 ;
46 ; -- get root of file
47 S ROOT=$$ROOT^DILFD(IFN,,1)
48 ;
49 S QRD=HLNODE
50 ;
51 Q
52 ;
53MFR ; -- response
54 ;
55 D MSA,QRD1,MFI,MFE
56 ;
57 Q
58 ;
59MSA ; -- Acknowledgement
60 ;
61 N X
62 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
63 S ^TMP("HLA",$J,CNT)=X
64 S CNT=CNT+1
65 ;
66 Q
67 ;
68QRD1 ; -- query definition segment
69 ;
70 S ^TMP("HLA",$J,CNT)=QRD
71 S CNT=CNT+1
72 ;
73 Q
74 ;
75MFI ; master file identifier segment
76 ;
77 S ^TMP("HLA",$J,CNT)=$$MFI^XUMFMFI(MFI,"Standard Terminology","MUP",$$NOW^XLFDT,$$NOW^XLFDT,"NE")
78 S CNT=CNT+1
79 ;
80 Q
81 ;
82MFE ; master file entry segment
83 ;
84 S VUID=0 F S VUID=$O(@ROOT@("AMASTERVUID",VUID)) Q:'VUID D
85 .S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0)) Q:'IEN
86 .S ^TMP("HLA",$J,CNT)=$$MFE^XUMFMFE("MUP","",$$NOW^XLFDT,MFI_"@"_VUID)
87 .S CNT=CNT+1
88 .D ZRT
89 ;
90 Q
91 ;
92ZRT ; data segments
93 ;
94 S SEQ=0
95 F S SEQ=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ)) Q:'SEQ D
96 .S IDX=$O(^DIC(4.001,IFN,1,"ASEQ",SEQ,0)) Q:'IDX
97 .S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)),NAME=$P(DATA,U)
98 .S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
99 .S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)
100 .S VUID1=$P(DATA,U,13),WP=$P(DATA,U,16)
101 .;
102 .I NAME="Status" D Q
103 ..S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_(+$P($$GETSTAT^XTID(IFN,,IEN_","),U))
104 ..S CNT=CNT+1
105 .;
106 .I WP D WP Q
107 .;
108 .I SUBFILE D SUBFILE Q
109 .;
110 .S VALUE=$$VALUE(IFN,IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
111 .;
112 .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
113 .S CNT=CNT+1
114 ;
115 Q
116 ;
117SUBFILE ;
118 ;
119 I NAME="Status" D Q
120 .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_+$$GETSTAT^XTID(IFN,,IEN_",")
121 .S CNT=CNT+1
122 ;
123 N ROOT
124 ;
125 S ROOT=$$ROOT^DILFD(SUBFILE,(","_IEN_","),1)
126 ;
127 I MKEY="" S ERROR="1^null lookup column parameter for subfile: "_SUBFILE Q
128 ;
129 S IEN1=0
130 F S IEN1=$O(@ROOT@(IEN1)) Q:'IEN1 D Q:ERROR
131 .;
132 .I $D(^DIC(4.001,IFN,1,IDX,1,"ASEQ1")) D SUBREC Q
133 .;
134 .S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD,VUID1,TYP) ;Q:VALUE=""
135 .;
136 .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_VALUE
137 .S CNT=CNT+1
138 ;
139 Q
140 ;
141SUBREC ; -- sub-records
142 ;
143 N SEQ1,FIELD1,NAME1,VUID2,TYP2
144 ;
145 S SEQ1=0
146 F S SEQ1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1)) Q:'SEQ1 D Q:ERROR
147 .S IDX1=$O(^DIC(4.001,IFN,1,IDX,1,"ASEQ1",SEQ1,0))
148 .;
149 .S NAME1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,2)
150 .I NAME1="" S ERROR="1^subrecord sequence name missing SUBFILE : "_SUBFILE Q
151 .S FIELD1=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,3)
152 .I FIELD1="" S ERROR="1^subrecord sequence number missing SUBFILE : "_SUBFILE Q
153 .S VUID2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,4)
154 .S TYP2=$P(^DIC(4.001,IFN,1,IDX,1,IDX1,0),U,5)
155 .;
156 .S VALUE=$$VALUE(SUBFILE,IEN1_","_IEN_",",FIELD1,VUID2,TYP2) ;Q:VALUE=""
157 .;
158 .S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME1_HLFS_VALUE
159 .S CNT=CNT+1
160 ;
161 Q
162 ;
163SEND ; -- send HL7 message
164 ;
165 S HLP("PRIORITY")="I"
166 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
167 ;
168 ; check for error
169 I ($P($G(HLRESLT),U,3)'="") D Q
170 .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
171 ;
172 ; successful call, message ID returned
173 S ERROR="0^"_$P($G(HLRESLT),U,1)
174 ;
175 Q
176 ;
177EXIT ; -- exit
178 ;
179 D CLEAN^DILF
180 ;
181 K ^TMP("HLA",$J)
182 ;
183 Q
184 ;
185WP ;
186 ;
187 N WP,I,J
188 ;
189 S I=$$GET1^DIQ(IFN,IEN_",",FIELD,,"WP")
190 ;
191 Q:'$D(WP)
192 ;
193 S ^TMP("HLA",$J,CNT)="ZRT"_HLFS_NAME_HLFS_$G(WP(1))
194 ;
195 S I=1,J=1
196 F S I=$O(WP(I)) Q:'I D
197 .S ^TMP("HLA",$J,CNT,J)=WP(I)
198 .S J=J+1
199 ;
200 S CNT=CNT+1
201 ;
202 Q
203 ;
204ESC(VALUE) ;
205 ;
206 I VALUE["^" F Q:VALUE'["^" D
207 .S VALUE=$P(VALUE,"^")_"\F\"_$P(VALUE,"^",2,9999)
208 I VALUE["&" F Q:VALUE'["&" D
209 .S VALUE=$P(VALUE,"&")_"\T\"_$P(VALUE,"&",2,9999)
210 ;
211 Q VALUE
212 ;
213VALUE(IFN,IENS,FIELD,VUID,TYP) ;
214 ;
215 Q:IFN="" "" Q:FIELD="" "" Q:IENS="" ""
216 ;
217 S:$G(TYP)="" TYP="ST"
218 ;S VUID=$S($G(VUID)'="":":99.99",1:"")
219 ;
220 ;S VALUE=$$GET1^DIQ(IFN,IENS,FIELD_VUID) Q:VALUE="" ""
221 S VALUE=$$GET1^DIQ(IFN,IENS,FIELD) Q:VALUE="" ""
222 S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,1)
223 S VALUE=$$ESC(VALUE)
224 ;
225 Q VALUE
226 ;
Note: See TracBrowser for help on using the repository browser.