source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRPXAPI2.m@ 1169

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1LRPXAPI2 ; SLC/STAFF Lab Extract API code ;2/26/04 15:15
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 ;
4VERIFIED(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if verified, else 0
5 ; checks for date report completed
6 I +$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q 1
7 Q 0
8 ;
9MIVERIFY(LRDFN,LRIDT,SUB) ; $$(lrdfn,lridt,sub) -> 1 if verified, else 0
10 ; checks for report date approved on subscript
11 S SUB=+$G(SUB)
12 I SUB>0,SUB<17,$G(^LR(LRDFN,"MI",LRIDT,SUB)) Q 1
13 Q 0
14 ;
15APVERIFY(LRDFN,LRIDT,APSUB) ; $$(lrdfn,lridt,ap subscrpt) -> 1 if verified
16 ; autopsy checks for:
17 ; date of death,
18 ; date autopsy report completed,
19 ; autopsy release date/time
20 ; otherwise, checks for date report completed and report release date
21 N OK
22 S OK=0
23 I APSUB="CY"!(APSUB="EM")!(APSUB="SP") D Q OK
24 . I $P($G(^LR(LRDFN,APSUB,LRIDT,0)),U,3),$P(^(0),U,11) S OK=1
25 I APSUB="AU" D Q OK
26 . I '$$DOD^LRPXAPIU($$DFN^LRPXAPIU(LRDFN)) Q
27 . I '$P($G(^LR(LRDFN,"AU")),U,3) Q
28 . I '$P(^LR(LRDFN,"AU"),U,15) Q
29 . S OK=1
30 Q OK
31 ;
32VAL(LRDFN,LRIDT,LRDN) ; from LRPXAPI
33 ; $$(lrdfn,lridt,lrdn) -> result node
34 Q $G(^LR(LRDFN,"CH",LRIDT,LRDN))
35 ;
36REFVAL(REF) ; from LRPXAPI
37 ; $$(reference location in ^LR) -> data node
38 N SUB
39 I REF'[";" Q ""
40 S SUB=$P(REF,";",2)
41 S SUB=""""_SUB_""""
42 S $P(REF,";",2)=SUB
43 S REF=$TR(REF,";",",")
44 S REF="^LR("_REF_")"
45 Q $G(@REF)
46 ;
47LRPXRM(RESULT,REF,ITEM,TYPES) ; from LRPXAPI
48 ; returns result node from index subscript as RESULT
49 N FILE,IEN,SECTION,TEST,VALUES
50 S RESULT=""
51 S VALUES=$$REFVAL(REF)
52 I '$L(VALUES) Q
53 I ITEM>0 D Q
54 . S $P(VALUES,U)=$$VRESULT^LRPXAPIU(ITEM,$P(VALUES,U))
55 . S RESULT=+ITEM_U_$$TESTNM^LRPXAPIU(+ITEM)_U_VALUES
56 . D SC(.RESULT,REF,TYPES)
57 I '$L(ITEM) D Q
58 . I $P(REF,";",2)'="CH" Q
59 . S TEST=$$TEST^LRPXAPIU(+$P(REF,";",4))
60 . I 'TEST Q
61 . S RESULT=TEST_U_$$TESTNM^LRPXAPIU(TEST)_U_VALUES
62 . D SC(.RESULT,REF,TYPES)
63 S SECTION=$P(ITEM,";") I $L(SECTION)'=1 Q
64 S FILE=$P(ITEM,";",2) I $L(FILE)'=1 Q
65 S IEN=+$P(ITEM,";",3) I 'IEN Q
66 I SECTION="M" D Q
67 . I FILE="S" S RESULT=IEN_U_$$SPECNM^LRPXAPIU(IEN)_U_VALUES Q
68 . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
69 . I FILE="O" S RESULT=IEN_U_$$BUGNM^LRPXAPIU(IEN)_U_VALUES Q
70 . I FILE="A" S RESULT=IEN_U_$$ABNM^LRPXAPIU(IEN)_U_VALUES Q
71 . I FILE="M" S RESULT=IEN_U_$$TBNM^LRPXAPIU(IEN)_U_VALUES Q
72 I SECTION="A" D Q
73 . I FILE="S" S RESULT=U_$$UP^XLFSTR(VALUES)_U_VALUES Q
74 . I FILE="T" S RESULT=IEN_U_$$TESTNM^LRPXAPIU(IEN)_U_VALUES Q
75 . I FILE="O" S RESULT=IEN_U_$$ORGNM^LRPXAPIU(IEN)_U_VALUES Q
76 . I FILE="D" S RESULT=IEN_U_$$DISNM^LRPXAPIU(IEN)_U_VALUES Q
77 . I FILE="M" S RESULT=IEN_U_$$MORPHNM^LRPXAPIU(IEN)_U_VALUES Q
78 . I FILE="E" S RESULT=IEN_U_$$ETINM^LRPXAPIU(IEN)_U_VALUES Q
79 . I FILE="F" S RESULT=IEN_U_$$FUNNM^LRPXAPIU(IEN)_U_VALUES Q
80 . I FILE="P" S RESULT=IEN_U_$$PROCNM^LRPXAPIU(IEN)_U_VALUES Q
81 . I FILE="I" S RESULT=IEN_U_$$ICD9^LRPXAPIU(IEN)_U_VALUES Q
82 Q
83 ;
84SC(RESULT,REF,TYPES) ;
85 N CNT,LINE,LRDFN,LRIDT,SPEC
86 I TYPES["S" D
87 . S $P(REF,";",4)=0
88 . S SPEC=+$P($$REFVAL(REF),U,5)
89 . S RESULT("SPECIMEN")=SPEC_U_$$SPECNM^LRPXAPIU(SPEC)
90 I TYPES["C" D
91 . S CNT=0,LRDFN=+$P(REF,";"),LRIDT=+$P(REF,";",3)
92 . S LINE=0
93 . F S LINE=$O(^LR(LRDFN,"CH",LRIDT,1,LINE)) Q:LINE<1 D
94 .. S CNT=CNT+1
95 .. S RESULT("COMMENTS",CNT)=$G(^LR(LRDFN,"CH",LRIDT,1,LINE,0))
96 . S RESULT("COMMENTS")=CNT
97 Q
98 ;
99SPEC(DATA,DFN,DATE,STYPE,ERR) ; from LRPXAPI
100 ; returns specimen node, comment, values in array DATA
101 N LRDFN,LRIDT K DATA
102 S ERR=0
103 S LRDFN=$$LRDFN^LRPXAPIU(DFN)
104 I 'LRDFN S ERR=1 Q
105 I 'DATE S ERR=1 Q
106 S LRIDT=$$LRIDT^LRPXAPIU(DATE)
107 D LRSPEC(.DATA,LRDFN,LRIDT,STYPE,.ERR)
108 Q
109 ;
110LRSPEC(DATA,LRDFN,LRIDT,STYPE,ERR) ; from LRPXAPI
111 ; returns specimen node, comment, values in array DATA
112 K DATA
113 S ERR=0
114 I '$O(^LR(LRDFN,"CH",LRIDT,0)) S ERR=1 Q
115 I '$L(STYPE) S STYPE="A"
116 I STYPE="S" D SSPEC(.DATA,LRDFN,LRIDT) Q
117 I STYPE="C" D CSPEC(.DATA,LRDFN,LRIDT) Q
118 I STYPE="V" D VSPEC(.DATA,LRDFN,LRIDT) Q
119 I STYPE="A" D
120 . N ALL K ALL
121 . D SSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
122 . D CSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
123 . D VSPEC(.DATA,LRDFN,LRIDT) M ALL=DATA
124 . K DATA M DATA=ALL
125 Q
126 ;
127SSPEC(DATA,LRDFN,LRIDT) ; specimen node values
128 K DATA
129 S DATA("S")=$G(^LR(LRDFN,"CH",LRIDT,0))
130 Q
131 ;
132CSPEC(DATA,LRDFN,LRIDT) ; specimen comments
133 N CMT,CNT K DATA
134 I '$D(^LR(LRDFN,"CH",LRIDT,1,0)) Q
135 S CNT=0
136 S CMT=0
137 F S CMT=$O(^LR(LRDFN,"CH",LRIDT,1,CMT)) Q:CMT<1 D
138 . I '$D(^LR(LRDFN,"CH",LRIDT,1,CMT,0)) Q
139 . S CNT=CNT+1
140 . S DATA("C",CNT)=^LR(LRDFN,"CH",LRIDT,1,CMT,0)
141 Q
142 ;
143VSPEC(DATA,LRDFN,LRIDT) ; test nodes for collected specimen
144 N CNT,LRDN,VALUE K DATA
145 S CNT=0
146 S LRDN=1
147 F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<2 S VALUE=^(LRDN) D
148 . S CNT=CNT+1
149 . S DATA("V",CNT)=LRDN_U_VALUE
150 Q
151 ;
152COMMENT(LRDFN,LRIDT) ; $$(lrdfn,lridt) --> 1 if comment exists, else 0
153 I +$O(^LR(LRDFN,"CH",LRIDT,1,0)) Q 1
154 Q 0
155 ;
156VALUE(RESULT,DFN,DATE,TEST,COND,ERR) ; from LRPXAPI, LRPXAPI1
157 ; returns result node that has met conditions as RESULT
158 N LRDFN,LRIDT,LRDN
159 I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
160 I $L(COND) S COND=$$REPLACE("I "_COND)
161 S RESULT=""
162 S ERR=0
163 S LRDFN=$$LRDFN^LRPXAPIU(DFN)
164 I 'LRDFN S ERR=1 Q
165 I 'DATE S ERR=1 Q
166 S LRIDT=$$LRIDT^LRPXAPIU(DATE)
167 S LRDN=$$LRDN^LRPXAPIU(TEST)
168 I 'LRDN S ERR=1 Q
169 D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
170 Q
171 ;
172LRVALUE(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ; from LRPXAPI, LRPXAPI1
173 ; returns result node that has met conditions as RESULT
174 I $L(COND),'$$CONDOK^LRPXAPIU(COND,"C") S ERR=1 Q
175 I $L(COND) S COND=$$REPLACE("I "_COND)
176 D LRVAL(.RESULT,LRDFN,LRIDT,LRDN,COND,.ERR)
177 Q
178 ;
179LRVAL(RESULT,LRDFN,LRIDT,LRDN,COND,ERR) ;
180 N F,S,V,VALUE
181 S RESULT=""
182 S ERR=0
183 S VALUE=$G(^LR(LRDFN,"CH",LRIDT,LRDN))
184 I '$L(VALUE) S ERR=1 Q
185 I $L(COND) D I ERR Q
186 . S V=$P(VALUE,U)
187 . S F=$P(VALUE,U,2)
188 . S S=$P($P(VALUE,U,5),"!")
189 . I 'S S S=$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,5)
190 . X COND I '$T S ERR=1
191 S RESULT=VALUE
192 Q
193 ;
194CHNODE(ARRAY,NODE) ; from LRPXAPI
195 N NAME,NAME3,NAME5,NODE3,NODE5,PIECE,PIECE3,PIECE5,SUB K ARRAY
196 I '$L(NODE) Q
197 S NAME="RESULT^FLAG^CODES^VERIFIER^NORMALS^DATE-R^DATE-T^^INSTITUTION^LEDI^INSTRUMENT^TYPE"
198 S NAME3="NLT-O!NLT-R!LOINC!METHOD!MAP!TEST"
199 S NAME5="SPEC!LOW!HIGH!LOW-C!HIGH-C!!UNITS!DELTA-T!DELTA-V!DEF!LOW-T!HIGH-T"
200 F PIECE=1:1:12 D
201 . I PIECE=8 Q
202 . S SUB=$P(NAME,U,PIECE)
203 . I PIECE=8 Q
204 . I PIECE=3 D Q
205 .. S NODE3=$P(NODE,U,3)
206 .. F PIECE3=1:1:6 S ARRAY($P(NAME3,"!",PIECE3))=$P(NODE3,"!",PIECE3)
207 . I PIECE=5 D Q
208 .. S NODE5=$P(NODE,U,5)
209 .. F PIECE5=1:1:12 D
210 ... I PIECE5=6 Q
211 ... S ARRAY($P(NAME5,"!",PIECE5))=$P(NODE5,"!",PIECE5)
212 . S ARRAY(SUB)=$P(NODE,U,PIECE)
213 Q
214 ;
215ACCY(TESTS,ACC,BDN) ; from LRPXAPI
216 ; returns TESTS from yearly accession, ACC, BDN required
217 ; BDN is beginning date number
218 ; TESTS is array of file 60 iens
219 N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
220 I '$L($G(ACC)) Q
221 S LRAAB=$P(ACC," ")
222 I LRAAB="" Q
223 S BDN=$E($G(BDN))
224 I BDN'>1 Q
225 S LRAN=+$P(ACC," ",3)
226 I 'LRAN Q
227 S LRAA=+$O(^LRO(68,"B",LRAAB,0))
228 I 'LRAA D
229 . S DIC=68,DIC(0)="M"
230 . S X=LRAAB
231 . D ^DIC K DIC
232 . S LRAA=+Y
233 I LRAA'>0 Q
234 S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
235 S TEST=0
236 F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
237 . S TESTS(TEST)=TEST_U_$$TESTNM^LRPXAPIU(TEST)
238 Q
239 ;
240CONDOK(CONDO,TYPE) ; $$ from LRPXAPIU
241 N DEL,NUM,OK,OPER,PIECE,PIECES,VALID,VALIDOP,VALUE,VAR K PIECES
242 I '(TYPE="C"!(TYPE="M")!(TYPE="A")) Q 0
243 S COND=CONDO
244 I $E(COND)="|" S COND=$E(COND,2,245)
245 I $E(COND)="~" S COND=$E(COND,2,245)
246 I $L(COND)'>2 Q 0
247 I $E(COND,1,2)'?1U1P Q 0
248 I COND[U Q 0
249 I CONDO[" " Q 0
250 I CONDO["|" S DEL="|"
251 E S DEL="~"
252 I '$$SYNTAX($$REPLACE(COND)) Q 0
253 S PIECE=COND
254 D
255 . I TYPE="C" S VALID="FSV" Q
256 . I TYPE="A" S VALID="CDEFIMOPST" Q
257 . I TYPE="M" S VALID="ACIMORST" Q
258 F NUM=1:1 Q:'$L($P(PIECE,DEL,NUM)) S PIECES(NUM)=$P(PIECE,DEL,NUM)
259 S OK=1
260 S NUM=0
261 F S NUM=$O(PIECES(NUM)) Q:NUM<1 D Q:'OK
262 . S PIECE=PIECES(NUM)
263 . I $L(PIECE)<3 S OK=0 Q
264 . S VAR=$E(PIECE)
265 . I VALID'[VAR S OK=0 Q
266 . D
267 .. I VAR="V" S VALIDOP="=<>[]" Q
268 .. I VAR="F" S VALIDOP="=[]" Q
269 .. I VAR="I" S VALIDOP="=[]" Q
270 .. I VAR="R" S VALIDOP="=[]" Q
271 .. I VAR="S",TYPE="A" S VALIDOP="=[]" Q
272 .. S VALIDOP="="
273 . I $E(PIECE,3)="'" S OK=0 Q
274 . I $E(PIECE,2)="'" S OPER=$E(PIECE,3)
275 . E S OPER=$E(PIECE,2)
276 . I VALIDOP'[OPER S OK=0 Q
277 . S VALUE=$P(PIECE,OPER,2,999)
278 . I $E(VALUE)="""",$E(VALUE,$L(VALUE))'="""" S OK=0 Q
279 . I VAR="C" D Q:'OK
280 .. I VALUE'?1""""1U1"""" S OK=0 Q
281 .. I $$CATSUB^LRPXAPIU($E(VALUE,2),TYPE)=-1 S OK=0 Q
282 . I VALUE,VALUE'=+VALUE S OK=0 Q
283 . I $L($P(VALUE,"""",3)) S OK=0 Q
284 . I '$$SYNTAX(PIECE) S OK=0 Q
285 . I $E(PIECE,2)="=",COND[(VAR_"'=") S OK=0 Q
286 I 'OK Q 0
287 Q 1
288 ;
289REPLACE(COND) ; $$(condition) -> condition replacing | or ~ with commas
290 Q $TR(COND,"~|",",,")
291 ;
292SYNTAX(X) ; $$(condition) -> 1 if correct, else 0
293 ; check syntax when condition applies to an if statement
294 S X="I "_X
295 D ^DIM
296 I '$D(X) Q 0
297 Q 1
298 ;
299NORMALS(LOW,HIGH,TEST,SPEC) ; from LRPXAPIU
300 N NODE
301 S (LOW,HIGH)=""
302 S TEST=+$G(TEST)
303 I 'TEST Q
304 S SPEC=+$G(SPEC)
305 I 'SPEC Q
306 S NODE=$G(^LAB(60,TEST,1,SPEC,0))
307 S LOW=$P(NODE,U,2)
308 S HIGH=$P(NODE,U,3)
309 Q
310 ;
Note: See TracBrowser for help on using the repository browser.