source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPXAPI5.m@ 1604

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1LRPXAPI5 ;SLC/STAFF Lab Extract API code - Match ;9/30/03 09:59
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 ;
4MATCH(DFN,DATE,CONDS,TYPE) ; $$(dfn,date,conds,type) -> 1 if ok, else 0
5 ; from LRPXAPI3,LRPXAPI6
6 ; check if conditions are met for date/time
7 I CONDS="|" Q $$EXACT^LRPXAPI4(DFN,DATE,.CONDS)
8 N FETCH,ITEM,NODE,OK,RESULTS,SEPARATE,SUB,XDATE K FETCH,RESULTS,SEPARATE
9 S OK=1
10 I '$L($O(CONDS(""))) Q 1
11 M FETCH=^PXRMINDX(63,"PDI",DFN,DATE)
12 S ITEM=""
13 F S ITEM=$O(FETCH(ITEM)) Q:ITEM="" D Q:'OK
14 . I $E(ITEM)'=TYPE S OK=0 Q
15 . S NODE=""
16 . F S NODE=$O(FETCH(ITEM,NODE)) Q:NODE="" D
17 .. S SUB=$P(NODE,";",2)
18 .. I '(SUB="AU"!(SUB="AY")!(SUB=33)!(SUB=80)) D
19 ... S SEPARATE($P(NODE,";",1,3),ITEM,NODE)=""
20 .. E S SEPARATE(DATE,ITEM,NODE)=""
21 I 'OK Q 0
22 S XDATE=""
23 F S XDATE=$O(SEPARATE(XDATE)) Q:XDATE="" D Q:OK
24 . K RESULTS
25 . M RESULTS=SEPARATE(XDATE)
26 . I '$L($O(RESULTS(""))) S OK=0 Q
27 . I $D(CONDS(0)) D NOTEQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
28 . I $D(CONDS(1)) D EQUAL(.CONDS,.RESULTS,.OK) I 'OK Q
29 . I $D(CONDS("AC")) D AC(.CONDS,.RESULTS,.OK) I 'OK Q
30 . I $D(CONDS("MC")) D MC(.CONDS,.RESULTS,.OK) I 'OK Q
31 . I $D(CONDS("AS")) D AS(.CONDS,.RESULTS,.OK) I 'OK Q
32 . I $D(CONDS("MIR")) D MIR(.CONDS,.RESULTS,.OK) I 'OK Q
33 Q OK
34 ;
35NOTEQUAL(CONDS,RESULTS,OK) ;
36 ; check not equal condition for pointer values
37 N ITEM,ITEM1
38 S OK=1
39 S ITEM=""
40 F S ITEM=$O(CONDS(0,ITEM)) Q:ITEM="" D I 'OK Q
41 . I $D(RESULTS(ITEM)) S OK=0 Q
42 . S ITEM1=$O(RESULTS($P(ITEM,";",1,2)))
43 . I $P(ITEM1,";",1,2)'=$P(ITEM,";",1,2) S OK=0 Q
44 Q
45 ;
46EQUAL(CONDS,RESULTS,OK) ;
47 ; check equal condition for pointer values
48 N ITEM
49 S OK=1
50 S ITEM=""
51 F S ITEM=$O(CONDS(1,ITEM)) Q:ITEM="" D I 'OK Q
52 . I '$D(RESULTS(ITEM)) S OK=0 Q
53 Q
54 ;
55AC(CONDS,RESULTS,OK) ;
56 ; check conditions for AP categories
57 N CAT,CATEGORY,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
58 S OK=1
59 S ITEM=""
60 F S ITEM=$O(CONDS("AC",ITEM)) Q:ITEM="" D
61 . S CATEGORY=$P(ITEM,"=",2)
62 . I '$L(CATEGORY) Q
63 . S CATEGORY=$E(CATEGORY,2)
64 . S NOTEQUAL=0
65 . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
66 . S ITEMC="A"
67 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;Z" D
68 .. I ITEMC["A;T;" Q
69 .. S NODE=""
70 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
71 ... S SUB=$P(NODE,";",2)
72 ... I SUB=33!(SUB=80) S CAT="A"
73 ... E S CAT=$E(SUB)
74 ... I NOTEQUAL,CAT=CATEGORY K RESULTS
75 ... I 'NOTEQUAL,CAT'=CATEGORY K RESULTS(ITEMC,NODE) Q
76 S NEXT=$O(RESULTS("A"))
77 I NEXT="" S OK=0 Q
78 I NEXT]"A;S" S OK=0 Q
79 Q
80 ;
81MC(CONDS,RESULTS,OK) ;
82 ; check conditions for Micro categories
83 N CATEGORY,CATSUB,ITEM,ITEMC,NEXT,NODE,NOTEQUAL,SUB
84 S OK=1
85 S ITEM=""
86 F S ITEM=$O(CONDS("MC",ITEM)) Q:ITEM="" D
87 . S CATEGORY=$P(ITEM,"=",2)
88 . I '$L(CATEGORY) Q
89 . S CATEGORY=$E(CATEGORY,2)
90 . S CATSUB=$$CATSUB^LRPXAPIU(CATEGORY,"M")
91 . S NOTEQUAL=0
92 . I $L($P(ITEM,"'=",2)) S NOTEQUAL=1
93 . S ITEMC="M"
94 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"M;Z" D
95 .. I ITEMC["M;T;" Q
96 .. I ITEMC["M;S;" Q
97 .. S NODE=""
98 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D
99 ... S SUB=$P(NODE,";",4)
100 ... I NOTEQUAL,SUB=CATSUB K RESULTS Q
101 ... I 'NOTEQUAL,SUB'=CATSUB K RESULTS(ITEMC,NODE) Q
102 S NEXT=$O(RESULTS("M"))
103 I NEXT="" S OK=0 Q
104 I NEXT]"M;S" S OK=0 Q
105 Q
106 ;
107AS(CONDS,RESULTS,OK) ;
108 ; check conditions for AP specimen
109 N CHECK,ITEM,ITEMC,S
110 S OK=1
111 S ITEM=""
112 F S ITEM=$O(CONDS("AS",ITEM)) Q:ITEM="" D I OK Q
113 . I $E(ITEM,2)="'" D Q
114 .. ; good if the specimen text is not present for this collection
115 .. S ITEMC="A;S;1"
116 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D Q:OK
117 ... S OK=0
118 ... S S=$P(ITEMC,"1.",2)
119 ... S CHECK="I "_ITEM
120 ... X CHECK I $T S OK=1
121 . ; good if any of the specimen text for this collection have a matching text
122 . I $O(RESULTS("A;S;1"))="" Q
123 . I $O(RESULTS("A"))]"A;S;Z" Q
124 . S OK=0
125 . S ITEMC="A;S;1"
126 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]"A;S;Z" D Q:OK
127 .. S S=$P(ITEMC,"1.",2)
128 .. S CHECK="I "_ITEM
129 .. X CHECK I $T S OK=1
130 Q
131 ;
132MIR(CONDS,RESULTS,OK) ; $$(dfn,date,conds) -> 1 if ok, else 0
133 ; check conditions for antimicrobial results and interpretations
134 N ABNODE,CHECK,I,ITEM,ITEMC,ITEMZ,NODE,R
135 S OK=1
136 ; check bacterial antimicrobials
137 S ITEM=""
138 F S ITEM=$O(CONDS("MIR",ITEM)) Q:ITEM="" D I 'OK Q
139 . I $E(ITEM,2)="'" D Q
140 .. ; good if the interpretation/result is not present for this collection
141 .. S ITEMC="M;A"
142 .. S ITEMZ="M;A;Z"
143 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]ITEMZ D Q:'OK
144 ... S NODE=""
145 ... F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D Q:'OK
146 .... S ABNODE=$$REFVAL^LRPXAPI(NODE)
147 .... S I=$P(ABNODE,U,2)
148 .... S R=$P(ABNODE,U)
149 .... S CHECK="I "_ITEM
150 .... X CHECK I $T S OK=0
151 . ; good if any of the interpretations/results have matching conditions
152 . I $O(RESULTS("M;A"))="" Q
153 . I $O(RESULTS("M;A"))]"M;A;Z" Q
154 . S OK=0
155 . S ITEMC="M;A"
156 . S ITEMZ="M;A;Z"
157 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]ITEMZ D Q:OK
158 .. S NODE=""
159 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D Q:OK
160 ... S ABNODE=$$REFVAL^LRPXAPI(NODE)
161 ... S I=$P(ABNODE,U,2)
162 ... S R=$P(ABNODE,U)
163 ... S CHECK="I "_ITEM
164 ... X CHECK I $T S OK=1
165 ; check mycobacterial antimicrobials
166 F S ITEM=$O(CONDS("MIR",ITEM)) Q:ITEM="" D I 'OK Q
167 . I $E(ITEM,2)="'" D Q
168 .. ; good if the interpretation/result is not present for this collection
169 .. S ITEMC="M;M"
170 .. S ITEMZ="M;M;Z"
171 .. F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]ITEMZ D Q:'OK
172 ... S NODE=""
173 ... F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D Q:'OK
174 .... S ABNODE=$$REFVAL^LRPXAPI(NODE)
175 .... S R=$P(ABNODE,U)
176 .... S I=R
177 .... S CHECK="I "_ITEM
178 .... X CHECK I $T S OK=0
179 . ; good if any of the interpretations/results have matching conditions
180 . I $O(RESULTS("M;M"))="" Q
181 . I $O(RESULTS("M;M"))]"M;M;Z" Q
182 . S OK=0
183 . S ITEMC="M;M"
184 . S ITEMZ="M;M;Z"
185 . F S ITEMC=$O(RESULTS(ITEMC)) Q:ITEMC="" Q:ITEMC]ITEMZ D Q:OK
186 .. S NODE=""
187 .. F S NODE=$O(RESULTS(ITEMC,NODE)) Q:NODE="" D Q:OK
188 ... S ABNODE=$$REFVAL^LRPXAPI(NODE)
189 ... S R=$P(ABNODE,U)
190 ... S I=R
191 ... S CHECK="I "_ITEM
192 ... X CHECK I $T S OK=1
193 Q
194 ;
Note: See TracBrowser for help on using the repository browser.