source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPXAPI4.m@ 1579

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1LRPXAPI4 ;SLC/STAFF Lab Extract API code - Exact Match ;9/29/03 21:17
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 ;
4EXACT(DFN,DATE,CONDS) ; from LRPXAPI5
5 ; check if conditions are met for date/time
6 N FETCH,ITEM,NODE,OK,RESULTS,SEPARATE,XDATE K FETCH,RESULTS,SEPARATE
7 S OK=1
8 I '$L($O(CONDS(""))) Q 1
9 M FETCH=^PXRMINDX(63,"PDI",DFN,DATE)
10 S ITEM=""
11 F S ITEM=$O(FETCH(ITEM)) Q:ITEM="" D
12 . S NODE=""
13 . F S NODE=$O(FETCH(ITEM,NODE)) Q:NODE="" D
14 .. S SEPARATE($P(NODE,";",1,3),ITEM,NODE)=""
15 S XDATE=""
16 F S XDATE=$O(SEPARATE(XDATE)) Q:XDATE="" D Q:OK
17 . K RESULTS
18 . M RESULTS=SEPARATE(XDATE)
19 . I '$L($O(RESULTS(""))) S OK=0 Q
20 . I $D(CONDS("MIR")) D MIR(.CONDS,.RESULTS,.OK) I 'OK Q
21 . I $D(CONDS("AS")) D AS(.CONDS,.RESULTS,.OK) I 'OK Q
22 . I $D(CONDS("MC")) D MC(.CONDS,.RESULTS,.OK) I 'OK Q
23 . I $D(CONDS("AC")) D AC(.CONDS,.RESULTS,.OK) I 'OK Q
24 . I $D(CONDS(1)) D EQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
25 . I $D(CONDS(0)) D NOTEQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
26 . I '$L($O(RESULTS(""))) S OK=0 Q 0
27 . D SCRAPS(.CONDS,.RESULTS,.OK) I 'OK Q
28 . D THREAD(.CONDS,.RESULTS,.OK) I 'OK Q
29 Q OK
30 ;
31THREAD(CONDS,RESULTS,OK) ;
32 ; uses TCHK within this scope
33 N CHK,FILE,IEN,ITEM,ITEMC,NEXT,NODE,NODEC,NUM,PAR,PARSTOP,START,STOP
34 S OK=1
35 ; check Micro - only O <-> A match
36 I $D(CONDS("X","M;O")),($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))) D Q:'OK
37 . I '($D(CONDS("X","M;A"))!$D(CONDS("X","M;M"))!$D(CONDS("X","M;MIR"))) Q
38 . S ITEM="M;O;"
39 . F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" Q:ITEM]"M;O;Z" D Q:'OK
40 .. S NODE=""
41 .. F S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE="" D Q:'OK
42 ... S IEN=$P(NODE,";",5)
43 ... S OK=0
44 ... S ITEMC="M;A;"
45 ... F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;A;Z" D Q:OK
46 .... S NODEC=""
47 .... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:OK
48 ..... I IEN=$P(NODEC,";",5) S OK=1 Q
49 ... S ITEMC="M;M;"
50 ... F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;M;Z" D Q:OK
51 .... S NODEC=""
52 .... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:OK
53 ..... I IEN=$P(NODEC,";",5) S OK=1 Q
54 I $D(CONDS("X","M")) Q
55 ; check AP - M <-> E , S <-> T and O <-> [D M F P] match
56 S PAR="A;M",START="A;E"
57 I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,7,START) Q:'OK
58 S PAR="A;S",START="A;T"
59 I $D(CONDS("X",PAR)),$D(CONDS("X",START)) D TCHK(PAR,5,START) Q:'OK
60 S PAR="A;O"
61 I $D(CONDS("X",PAR)) D Q:'OK
62 . F FILE="D","M","F","P" D Q:'OK
63 .. S START="A;"_FILE
64 .. I $D(CONDS("X",START)) D TCHK(PAR,5,START)
65 Q
66TCHK(PAR,NUM,START) ; within scope of THREAD
67 S ITEM=PAR,PARSTOP=PAR_";Z",STOP=START_";Z"
68 F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" Q:ITEM]PARSTOP D Q:'OK
69 . S NODE=""
70 . F S NODE=$O(RESULTS(ITEM,NODE)) Q:NODE="" D Q:'OK
71 .. S IEN=$P(NODE,";",1,NUM)
72 .. S CHK=0
73 .. S ITEMC=START
74 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D Q:CHK
75 ... S NODEC=""
76 ... F S NODEC=$O(RESULTS(ITEMC,NODEC)) Q:NODEC="" D Q:CHK
77 .... I IEN=$P(NODEC,";",1,NUM) S CHK=1 Q
78 .... I $L(NODEC,";")=4 S CHK=1 Q ; at collection date
79 .. I 'CHK K RESULTS(ITEM)
80 S NEXT=$O(RESULTS(PAR))
81 I NEXT="" S OK=0 Q
82 I NEXT]PARSTOP S OK=0 Q
83 Q
84 ;
85SCRAPS(CONDS,RESULTS,OK) ;
86 N ITEM,ITEMC
87 S OK=1
88 S ITEM=""
89 F S ITEM=$O(RESULTS(ITEM)) Q:ITEM="" D
90 . S ITEMC=$P(ITEM,";",1,2)
91 . I ITEMC="M;A",$D(CONDS("MIR")) Q
92 . I ITEMC="M;M",$D(CONDS("MIR")) Q
93 . I '$D(CONDS("X",ITEMC)) K RESULTS(ITEM)
94 I '$L($O(RESULTS(""))) S OK=0 Q
95 Q
96 ;
97NOTEQUAL(CONDS,RESULTS,OK) ;
98 ; check not equal condition for pointer values
99 N FILE,ITEM,START,STOP,TYPE
100 S OK=1
101 S ITEM=""
102 F S ITEM=$O(CONDS(0,ITEM)) Q:ITEM="" D Q:'OK
103 . S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
104 . K RESULTS(ITEM)
105 . S NEXT=$O(RESULTS(START))
106 . I NEXT="" S OK=0 Q
107 . I NEXT]STOP S OK=0 Q
108 Q
109 ;
110EQUAL(CONDS,RESULTS,OK) ;
111 ; check equal condition for pointer values
112 N FILE,ITEM,ITEMC,NEXT,START,STOP,TYPE
113 S OK=1
114 S ITEM=""
115 F S ITEM=$O(CONDS(1,ITEM)) Q:ITEM="" D
116 . S TYPE=$E(ITEM),FILE=$E(ITEM,3),START=TYPE_";"_FILE,STOP=TYPE_";"_FILE_";Z"
117 . S ITEMC=START
118 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
119 .. I ITEMC=ITEM Q
120 .. K RESULTS(ITEMC)
121 S NEXT=$O(RESULTS(START))
122 I NEXT="" S OK=0 Q
123 I NEXT]STOP S OK=0 Q
124 Q
125 ;
126AC(CONDS,RESULTS,OK) ;
127 ; check conditions for AP categories
128 N CAT,CATEGORY,ITEM,ITEMC,NODE,NOTEQUAL,SUB
129 S OK=1
130 S ITEM=""
131 F S ITEM=$O(CONDS("AC",ITEM)) Q:ITEM="" D
132 . S CATEGORY=$P(ITEM,"=",2)
133 . I '$L(CATEGORY) Q
134 . S CATEGORY=$E(CATEGORY,2)
135 . S NOTEQUAL=0
136 . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
137 . S ITEMC="A"
138 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;Z" D
139 .. I ITEMC["A;T;" Q
140 .. S NODE=""
141 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
142 ... S SUB=$P(NODE,";",2)
143 ... I SUB=33!(SUB=80) S CAT="A"
144 ... E S CAT=$E(SUB)
145 ... I NOTEQUAL,CAT=CATEGORY K RESULTS(ITEMC,NODE) Q
146 ... I 'NOTEQUAL,CAT'=CATEGORY K RESULTS(ITEMC,NODE) Q
147 I '$L($O(RESULTS(""))) S OK=0 Q
148 Q
149 ;
150MC(CONDS,RESULTS,OK) ;
151 ; check conditions for Micro categories
152 N CATEGORY,CATSUB,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
153 S OK=1
154 S ITEM=""
155 F S ITEM=$O(CONDS("MC",ITEM)) Q:ITEM="" D
156 . S CATEGORY=$P(ITEM,"=",2)
157 . I '$L(CATEGORY) Q
158 . S CATEGORY=$E(CATEGORY,2)
159 . S CATSUB=$$CATSUB^LRPXAPIU(CATEGORY,"M")
160 . S NOTEQUAL=0
161 . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
162 . S ITEMC="M"
163 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;Z" D
164 .. I ITEMC["M;T;" Q
165 .. I ITEMC["M;S;" Q
166 .. S NODE=""
167 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
168 ... S SUB=$P(NODE,";",4)
169 ... I NOTEQUAL,SUB=CATSUB K RESULTS(ITEMC,NODE) Q
170 ... I 'NOTEQUAL,SUB'=CATSUB K RESULTS(ITEMC,NODE) Q
171 S NEXT=$O(RESULTS("M"))
172 I NEXT="" S OK=0 Q
173 I NEXT]"M;S" S OK=0 Q
174 Q
175 ;
176AS(CONDS,RESULTS,OK) ;
177 ; check conditions for AP specimen
178 N CHECK,ITEM,ITEMC,NEXT,S
179 S OK=1
180 S ITEM=""
181 F S ITEM=$O(CONDS("AS",ITEM)) Q:ITEM="" D
182 . I $E(ITEM,2)="'" D Q
183 .. ; good if the specimen text is not present for this collection
184 .. S ITEMC="A;S;1"
185 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D
186 ... S S=$P(ITEMC,"1.",2)
187 ... S CHECK="I "_ITEM
188 ... X CHECK I '$T K RESULTS(ITEMC)
189 . ; good if any of the specimen text for this collection have a matching text
190 . I $O(RESULTS("A;S;1"))="" Q
191 . I $O(RESULTS("A;S;1"))]"A;S;Z" Q
192 . S OK=0
193 . S ITEMC="A;S;1"
194 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D
195 .. S S=$P(ITEMC,"1.",2)
196 .. S CHECK="I "_ITEM
197 .. X CHECK I '$T K RESULTS(ITEMC)
198 S NEXT=$O(RESULTS("A;S;"))
199 I NEXT="" S OK=0 Q
200 I NEXT]"A;S;Z" S OK=0 Q
201 S OK=1
202 Q
203 ;
204MIR(CONDS,RESULTS,OK) ;
205 ; check conditions for antimicrobial results and interpretations
206 ; uses MCHK within this scope
207 N ABNODE,ABTYPE,CHECK,I,ITEM,ITEMC,NEXTA,NEXTM,NODE,R,START,STOP
208 S OK=0
209 F ABTYPE="A","M" D MCHK(ABTYPE)
210 S NEXTA=$O(RESULTS("M;A"))
211 S NEXTM=$O(RESULTS("M;M"))
212 I NEXTA="",NEXTM="" Q
213 I NEXTA="",NEXTM]"M;M;Z" Q
214 I NEXTA]"M;A;Z",NEXTM="" Q
215 I NEXTA]"M;A;Z",NEXTM]"M;M;Z" Q
216 S OK=1
217 Q
218MCHK(ABTYPE) ; within scope of MIR
219 S START="M;"_ABTYPE
220 S STOP=START_";Z"
221 S ITEM=""
222 F S ITEM=$O(CONDS("MIR",ITEM)) Q:ITEM="" D
223 . I $E(ITEM,2)="'" D Q
224 .. ; good if the interpretation/result is not present for this collection
225 .. S ITEMC=START
226 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
227 ... S NODE=""
228 ... F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
229 .... S ABNODE=$$REFVAL^LRPXAPI(NODE)
230 .... I ABTYPE="A" D
231 ..... S I=$P(ABNODE,U,2)
232 ..... S R=$P(ABNODE,U)
233 .... E D
234 ..... S R=$P(ABNODE,U)
235 ..... S I=R
236 .... S CHECK="I "_ITEM
237 .... X CHECK I $T Q
238 .... K RESULTS(ITEMC,NODE)
239 . ; good if any of the interpretations/results have matching conditions
240 . I $O(RESULTS(START))="" Q
241 . I $O(RESULTS(START))]STOP Q
242 . S ITEMC=START
243 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]STOP D
244 .. S NODE=""
245 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
246 ... S ABNODE=$$REFVAL^LRPXAPI(NODE)
247 ... S I=$P(ABNODE,U,2)
248 ... S R=$P(ABNODE,U)
249 ... S CHECK="I "_ITEM
250 ... X CHECK I '$T K RESULTS(ITEMC,NODE)
251 Q
252 ;
Note: See TracBrowser for help on using the repository browser.