source: FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UTL1C.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1LA7UTL1C ;HOIFO/BH - Microbiology Query Utility ; 3/11/03 10:45am
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**69**;Sep 27, 1994
3 ;
4 ;
5MI(LRDFN,LRIDT,LAARRAY) ; Get Microbiology data
6 ; Get top node data
7 ;
8 N LACOMIEN,LAGETIEN,LAGSIEN,LAIEN,LAORGIEN,LAPARIEN,LAPRIEN,LAREMIEN,LASCCOM,LASCIEN,LAFIXANT,LAFCOM,LAFUNIEN,LAMBIEN,LAMBCOM,LAFIXMB,LAMBFLD,LAMBFLD1,LACNT1,LAMBRES,LAVIEN
9 N LAGETS,LAGETIEN,LAMFLD,LAANTIEN,LACMANTI,LABSPIEN,LAPSPIEN,LAMSPIEN,LAVRRIEN
10 ;
11 S LAIEN=LRIDT_","_LRDFN
12 K LARET,LAERR
13 D GETS^DIQ(63.05,LAIEN,".01;.05;.055;.06;11.51;11.57;11.58;22:23;24;25;.99","IE","LARET","LAERR")
14 I $D(LAERR("DIERR")) K LAERR Q
15 M @LAARRAY=LARET
16 K LARET,LAERR
17 ;
18 ; Get Bact RPT Remark
19 S LAREMIEN=0
20 F S LAREMIEN=$O(^LR(LRDFN,"MI",LRIDT,4,LAREMIEN)) Q:'LAREMIEN D
21 . S LAGETIEN=LAREMIEN_","_LRIDT_","_LRDFN
22 . K LARET,LAERR
23 . D GETS^DIQ(63.33,LAGETIEN,".01","IE","LARET","LAERR")
24 . I $D(LAERR("DIERR")) K LAERR Q
25 . M @LAARRAY=LARET
26 . K LARET,LAERR
27 ;
28 ; Get Gram Stain
29 S LAGSIEN=0
30 F S LAGSIEN=$O(^LR(LRDFN,"MI",LRIDT,2,LAGSIEN)) Q:'LAGSIEN D
31 . S LAGETIEN=LAGSIEN_","_LRIDT_","_LRDFN
32 . K LARET,LAERR
33 . D GETS^DIQ(63.29,LAGETIEN,".01","IE","LARET","LAERR")
34 . I $D(LAERR("DIERR")) K LAERR Q
35 . M @LAARRAY=LARET
36 . K LARET,LAERR
37 ;
38 ; Get Organism data
39 S LAORGIEN=0
40 F S LAORGIEN=$O(^LR(LRDFN,"MI",LRIDT,3,LAORGIEN)) Q:'LAORGIEN D
41 . S LAGETIEN=LAORGIEN_","_LRIDT_","_LRDFN
42 . K LARET,LAERR
43 . D GETS^DIQ(63.3,LAGETIEN,".01;1","IE","LARET","LAERR")
44 . I $D(LAERR("DIERR")) K LAERR Q
45 . M @LAARRAY=LARET
46 . K LARET,LAERR
47 . S LACOMIEN=0
48 . F S LACOMIEN=$O(^LR(LRDFN,"MI",LRIDT,3,LAORGIEN,1,LACOMIEN)) Q:'LACOMIEN D
49 . . S LAGETIEN=LACOMIEN_","_LAORGIEN_","_LRIDT_","_LRDFN
50 . . K LARET,LAERR
51 . . D GETS^DIQ(63.31,LAGETIEN,".01","IE","LARET","LAERR")
52 . . I $D(LAERR("DIERR")) K LAERR Q
53 . . M @LAARRAY=LARET
54 . . K LARET,LAERR
55 . ;
56 . ;
57 . S LAFIXANT=2
58 . F S LAFIXANT=$O(^LR(LRDFN,"MI",LRIDT,3,LAORGIEN,LAFIXANT)) Q:'LAFIXANT!(LAFIXANT'<3) D
59 . . Q:$E(LAFIXANT,1,4)'="2.00"
60 . . S LAGETIEN=LAORGIEN_","_LRIDT_","_LRDFN
61 . . I $L(LAFIXANT)<7 D
62 . . . S LAMFLD=$$DECODE^LA7UTL1B(LAFIXANT)
63 . . . I LAMFLD="" Q
64 . . . N LACNT1,LACNT,LAVAL,LA7ARR1,LAMFLD2,LAIN,LAMFLD3,LAMFLD4
65 . . . F LACNT=2,3,4 D
66 . . . . S LAVAL=$P(LAMFLD,U,LACNT)
67 . . . . S LAIN="LAMFLD"_LACNT
68 . . . . S @LAIN=$P(LAVAL,"~")
69 . . . . S LA7ARR1(@LAIN)=$P(LAVAL,"~",2)
70 . . . . ;
71 . . . K LARET,LAERR
72 . . . D GETS^DIQ(63.3,LAGETIEN,LAMFLD2_";"_LAMFLD3_";"_LAMFLD4,"IE","LARET","LAERR")
73 . . . I $D(LAERR("DIERR")) K LAERR Q
74 . . . S LACNT1=0
75 . . . S LAGETIEN=LAGETIEN_","
76 . . . F S LACNT1=$O(LA7ARR1(LACNT1)) Q:'LACNT1 D
77 . . . . N LARES
78 . . . . S LARES=$G(LARET(63.3,LAGETIEN,LACNT1,"I"))
79 . . . . I LARES="" K LARET(63.3,LAGETIEN,LACNT1) Q
80 . . . . S LARET(63.3,LAGETIEN,LACNT1,"I")=LA7ARR1(LACNT1)_U_LARES
81 . . . M @LAARRAY=LARET
82 . . . ;
83 . . . ;
84 . . I $L(LAFIXANT)>6 D
85 . . . N LACNT2,LANAME,LATEST,LARET,LAERR,LARES
86 . . . D FIELD^DID(63.3,LAFIXANT,"","LABEL","LATEST")
87 . . . I '$D(LATEST("LABEL")) Q
88 . . . S LANAME=LATEST("LABEL")
89 . . . ;
90 . . . D GETS^DIQ(63.3,LAGETIEN,LAFIXANT_";"_LAFIXANT_"1;"_LAFIXANT_"2","IE","LARET","LAERR")
91 . . . I $D(LAERR("DIERR")) K LAERR Q
92 . . . S LAGETIEN=LAGETIEN_","
93 . . . S LARES=$G(LARET(63.3,LAGETIEN,LAFIXANT,"I"))
94 . . . S:LARES'="" LARET(63.3,LAGETIEN,LAFIXANT,"I")=LANAME_U_LARES
95 . . . I LARES="" K LARET(63.3,LAGETIEN,LAFIXANT)
96 . . . F LACNT2=1,2 D
97 . . . . K LATEST
98 . . . . D FIELD^DID(63.3,LAFIXANT_LACNT2,"","LABEL","LATEST")
99 . . . . I '$D(LATEST("LABEL")) Q
100 . . . . S LANAME=LATEST("LABEL")
101 . . . . S LARES=$G(LARET(63.3,LAGETIEN,LAFIXANT_LACNT2,"I"))
102 . . . . I LARES="" K LARET(63.3,LAGETIEN,LAFIXANT_LACNT2) Q
103 . . . . S LARET(63.3,LAGETIEN,LAFIXANT_LACNT2,"I")=LANAME_U_LARES
104 . . . M @LAARRAY=LARET
105 . ;
106 . S LACMANTI=0
107 . F S LACMANTI=$O(^LR(LRDFN,"MI",LRIDT,3,LAORGIEN,3,LACMANTI)) Q:'LACMANTI D
108 . . S LAANTIEN=LACMANTI_","_LAORGIEN_","_LRIDT_","_LRDFN
109 . . K LARET,LAERR
110 . . D GETS^DIQ(63.32,LAANTIEN,".01;1;2","IE","LARET","LAERR")
111 . . I $D(LAERR("DIERR")) K LAERR Q
112 . . M @LAARRAY=LARET
113 . . K LARET,LAERR
114 ;
115 ;
116 ; Get Parasite data
117 S LAPARIEN=0
118 F S LAPARIEN=$O(^LR(LRDFN,"MI",LRIDT,6,LAPARIEN)) Q:'LAPARIEN D
119 . S LAGETIEN=LAPARIEN_","_LRIDT_","_LRDFN
120 . K LARET,LAERR
121 . D GETS^DIQ(63.34,LAGETIEN,".01","IE","LARET","LAERR")
122 . I $D(LAERR("DIERR")) K LAERR Q
123 . M @LAARRAY=LARET
124 . K LARET,LAERR
125 . ; - Get stage code data
126 . S LASCIEN=0
127 . F S LASCIEN=$O(^LR(LRDFN,"MI",LRIDT,6,LAPARIEN,1,LASCIEN)) Q:'LASCIEN D
128 . . S LAGETIEN=LASCIEN_","_LAPARIEN_","_LRIDT_","_LRDFN
129 . . K LARET,LAERR
130 . . D GETS^DIQ(63.35,LAGETIEN,".01;1","IE","LARET","LAERR")
131 . . I $D(LAERR("DIERR")) K LAERR Q
132 . . M @LAARRAY=LARET
133 . . K LARET,LAERR
134 . . ; - Get stage code comments
135 . . S LASCCOM=0
136 . . F S LASCCOM=$O(^LR(LRDFN,"MI",LRIDT,6,LAPARIEN,1,LASCIEN,1,LASCCOM)) Q:'LASCCOM D
137 . . . S LAGETIEN=LASCCOM_","_LASCIEN_","_LAPARIEN_","_LRIDT_","_LRDFN
138 . . . K LARET,LAERR
139 . . . D GETS^DIQ(63.351,LAGETIEN,".01","IE","LARET","LAERR")
140 . . . I $D(LAERR("DIERR")) K LAERR Q
141 . . . M @LAARRAY=LARET
142 . . . K LARET,LAERR
143 ;
144 ; - Get Parasite Remarks
145 S LAPRIEN=0
146 F S LAPRIEN=$O(^LR(LRDFN,"MI",LRIDT,7,LAPRIEN)) Q:'LAPRIEN D
147 . S LAGETIEN=LAPRIEN_","_LRIDT_","_LRDFN
148 . K LARET,LAERR
149 . D GETS^DIQ(63.36,LAGETIEN,".01","IE","LARET","LAERR")
150 . I $D(LAERR("DIERR")) K LAERR Q
151 . M @LAARRAY=LARET
152 . K LARET,LAERR
153 ;
154 ; ---Fungus Yeast
155 S LAFUNIEN=0
156 F S LAFUNIEN=$O(^LR(LRDFN,"MI",LRIDT,9,LAFUNIEN)) Q:'LAFUNIEN D
157 . S LAGETIEN=LAFUNIEN_","_LRIDT_","_LRDFN
158 . K LARET,LAERR
159 . D GETS^DIQ(63.37,LAGETIEN,".01;1","IE","LARET","LAERR")
160 . I $D(LAERR("DIERR")) K LAERR Q
161 . M @LAARRAY=LARET
162 . K LARET,LAERR
163 . S LAFCOM=0
164 . F S LAFCOM=$O(^LR(LRDFN,"MI",LRIDT,9,LAFUNIEN,1,LAFCOM)) Q:'LAFCOM D
165 . . S LAGETIEN=LAFCOM_","_LAFUNIEN_","_LRIDT_","_LRDFN
166 . . K LARET,LAERR
167 . . D GETS^DIQ(63.372,LAGETIEN,".01","IE","LARET","LAERR")
168 . . I $D(LAERR("DIERR")) K LAERR Q
169 . . M @LAARRAY=LARET
170 . . K LARET,LAERR
171 ;
172 ; ---Mycobacteruim
173 ;
174 S LAMBIEN=0
175 F S LAMBIEN=$O(^LR(LRDFN,"MI",LRIDT,12,LAMBIEN)) Q:'LAMBIEN D
176 . S LAGETIEN=LAMBIEN_","_LRIDT_","_LRDFN
177 . K LARET,LAERR
178 . D GETS^DIQ(63.39,LAGETIEN,".01;1","IE","LARET","LAERR")
179 . I $D(LAERR("DIERR")) K LAERR Q
180 . M @LAARRAY=LARET
181 . K LARET,LAERR
182 . S LAMBCOM=0
183 . F S LAMBCOM=$O(^LR(LRDFN,"MI",LRIDT,12,LAMBIEN,1,LAMBCOM)) Q:'LAMBCOM D
184 . . S LAGETIEN=LAMBCOM_","_LAMBIEN_","_LRIDT_","_LRDFN
185 . . K LARET,LAERR
186 . . D GETS^DIQ(63.4,LAGETIEN,".01","IE","LARET","LAERR")
187 . . I $D(LAERR("DIERR")) K LAERR Q
188 . . M @LAARRAY=LARET
189 . K LARET,LAERR
190 . S LAFIXMB=2
191 . S LAGETIEN=LAMBIEN_","_LRIDT_","_LRDFN
192 . F S LAFIXMB=$O(^LR(LRDFN,"MI",LRIDT,12,LAMBIEN,LAFIXMB)) Q:'LAFIXMB!(LAFIXMB'<3) D
193 . . Q:$E(LAFIXMB,1,4)'="2.00"
194 . . I $L(LAFIXMB)<7 D
195 . . . S LAMBFLD=$P($$DECODEMB^LA7UTL1B(LAFIXMB),U,2)
196 . . . I LAMBFLD="" Q
197 . . . S LAMBFLD1=$P(LAMBFLD,"~",2)
198 . . . S LAMBFLD=$P(LAMBFLD,"~",1)
199 . . . K LARET,LAERR
200 . . . D GETS^DIQ(63.39,LAGETIEN,LAMBFLD,"IE","LARET","LAERR")
201 . . . ;
202 . . . I $D(LAERR("DIERR"))!('$D(LARET)) K LARET,LAERR Q
203 . . . ;
204 . . . S LAGETS=LAGETIEN_","
205 . . . S LAMBRES=$G(LARET(63.39,LAGETS,LAMBFLD,"I"))
206 . . . I LAMBRES="" K LARET(63.39,LAGETS,LAMBFLD) Q
207 . . . S LARET(63.39,LAGETS,LAMBFLD,"I")=LAMBFLD1_U_LAMBRES
208 . . . M @LAARRAY=LARET
209 . . . ;
210 . . . ;
211 . . I $L(LAFIXMB)>6 D
212 . . . N LANAME,LATEST,LARET,LAERR,LAMBRES
213 . . . D FIELD^DID(63.39,LAFIXMB,"","LABEL","LATEST")
214 . . . I '$D(LATEST("LABEL")) Q
215 . . . S LANAME=LATEST("LABEL")
216 . . . K LARET,LAERR
217 . . . D GETS^DIQ(63.39,LAGETIEN,LAFIXMB,"IE","LARET","LAERR")
218 . . . ;
219 . . . I $D(LAERR("DIERR"))!('$D(LARET)) K LAERR Q
220 . . . S LAGETS=LAGETIEN_","
221 . . . S LAMBRES=$G(LARET(63.39,LAGETS,LAFIXMB,"I"))
222 . . . I LAMBRES="" K LARET(63.39,LAGETS,LAFIXMB) Q
223 . . . S:LAMBRES'="" LARET(63.39,LAGETS,LAFIXMB,"I")=LANAME_U_LAMBRES
224 . . . M @LAARRAY=LARET
225 ;
226 ; ---Virus
227 ;
228 S LAVIEN=0
229 F S LAVIEN=$O(^LR(LRDFN,"MI",LRIDT,17,LAVIEN)) Q:'LAVIEN D
230 . S LAGETIEN=LAVIEN_","_LRIDT_","_LRDFN
231 . K LARET,LAERR
232 . D GETS^DIQ(63.43,LAGETIEN,".01","IE","LARET","LAERR")
233 . I $D(LAERR("DIERR")) K LAERR Q
234 . M @LAARRAY=LARET
235 . K LARET,LAERR
236 ;
237 ; ---Parasitology Smear/Prep
238 ;
239 S LAPSPIEN=0
240 F S LAPSPIEN=$O(^LR(LRDFN,"MI",LRIDT,24,LAPSPIEN)) Q:'LAPSPIEN D
241 . S LAGETIEN=LAPSPIEN_","_LRIDT_","_LRDFN
242 . K LARET,LAERR
243 . D GETS^DIQ(63.341,LAGETIEN,".01","IE","LARET","LAERR")
244 . I $D(LAERR("DIERR")) K LAERR Q
245 . M @LAARRAY=LARET
246 . K LARET,LAERR
247 ;
248 ; ---Bacteriology Smear/Prep
249 ;
250 S LABSPIEN=0
251 F S LABSPIEN=$O(^LR(LRDFN,"MI",LRIDT,25,LABSPIEN)) Q:'LABSPIEN D
252 . S LAGETIEN=LABSPIEN_","_LRIDT_","_LRDFN
253 . K LARET,LAERR
254 . D GETS^DIQ(63.291,LAGETIEN,".01","IE","LARET","LAERR")
255 . I $D(LAERR("DIERR")) K LAERR Q
256 . M @LAARRAY=LARET
257 . K LARET,LAERR
258 ;
259 ; ---Mycology Smear/Prep
260 ;
261 S LAMSPIEN=0
262 F S LAMSPIEN=$O(^LR(LRDFN,"MI",LRIDT,15,LAMSPIEN)) Q:'LAMSPIEN D
263 . S LAGETIEN=LAMSPIEN_","_LRIDT_","_LRDFN
264 . K LARET,LAERR
265 . D GETS^DIQ(63.371,LAGETIEN,".01","IE","LARET","LAERR")
266 . I $D(LAERR("DIERR")) K LAERR Q
267 . M @LAARRAY=LARET
268 . K LARET,LAERR
269 ;
270 ; ---Virology RPT
271 ;
272 S LAVRRIEN=0
273 F S LAVRRIEN=$O(^LR(LRDFN,"MI",LRIDT,18,LAVRRIEN)) Q:'LAVRRIEN D
274 . S LAGETIEN=LAVRRIEN_","_LRIDT_","_LRDFN
275 . K LARET,LAERR
276 . D GETS^DIQ(63.44,LAGETIEN,".01","IE","LARET","LAERR")
277 . I $D(LAERR("DIERR")) K LAERR Q
278 . M @LAARRAY=LARET
279 . K LARET,LAERR
280 ;
281 Q
282 ;
Note: See TracBrowser for help on using the repository browser.