source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRPXRM.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1LRPXRM ;SLC/STAFF Lab reminder index for micro and ap ;5/6/04 13:21
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 ;
4UPDATE(LRDFN,SUB,LRIDT) ; update Micro and AP xrefs in ^PXRMINDX(63
5 ; from LRAPDA,LRAPDSR,LRMIEDZ,LRMIEDZ2,LRMISTF1,LRMIV,LRMIV1,LRMIV2
6 ; - ^TMP("LRPX",$J, is used for processing any edits of Micro or AP data:
7 ; - All results "AR" are copied when the patient's sample is edited.
8 ; - Indexes of the patient's "PDI" are copied before "B" edits.
9 ; - Indexes created from the "AR" data provide an index after "A" edits.
10 ; - "A" and "B" are compared to determine what has been added "ADD"
11 ; and what has been deleted "DEL".
12 ; - The ^PXRMINDX(63 indexes are added or deleted using "ADD" and "DEL".
13 N DATE,DFN K ^TMP("LRPX",$J)
14 S LRIDT=+$G(LRIDT)
15 S DFN=$$DFN^LRPXAPIU(+$G(LRDFN)) I 'DFN Q
16 I SUB="AU" D Q
17 . S DATE=$$DOD^LRPXAPIU(DFN) I 'DATE Q
18 . I '+$G(^LR(LRDFN,"AU")) Q
19 . I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q
20 . M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
21 . M ^TMP("LRPX",$J,"AR","AY")=^LR(LRDFN,"AY")
22 . M ^TMP("LRPX",$J,"AR",80)=^LR(LRDFN,80)
23 . M ^TMP("LRPX",$J,"AR",33)=^LR(LRDFN,33)
24 . D AP(DFN,LRDFN,DATE,LRIDT,SUB)
25 . K ^TMP("LRPX",$J)
26 S DATE=$$LRIDT^LRPXAPIU(LRIDT)
27 M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
28 I SUB="MI" D
29 . M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,SUB,LRIDT)
30 . D MICRO(DFN,LRDFN,DATE,LRIDT)
31 E D
32 . M ^TMP("LRPX",$J,"AR",0)=^LR(LRDFN,SUB,LRIDT,0)
33 . M ^TMP("LRPX",$J,"AR",.1)=^LR(LRDFN,SUB,LRIDT,.1)
34 . M ^TMP("LRPX",$J,"AR",2)=^LR(LRDFN,SUB,LRIDT,2)
35 . M ^TMP("LRPX",$J,"AR",3)=^LR(LRDFN,SUB,LRIDT,3)
36 . D AP(DFN,LRDFN,DATE,LRIDT,SUB)
37 K ^TMP("LRPX",$J)
38 Q
39 ;
40MICRO(DFN,LRDFN,DATE,LRIDT) ;
41 N AB,ABDN,ACC,ITEM,NODE,ORG,ORGNUM,SPEC,SUB,TB,TBDN,TEST,TESTS K TESTS
42 S ITEM=0
43 F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
44 . I $E(ITEM)'="M" K ^TMP("LRPX",$J,"B",ITEM)
45 I '+$G(^TMP("LRPX",$J,"AR",0)) Q
46 I '$$MIVER(LRDFN,LRIDT) Q
47 S SPEC=+$P(^TMP("LRPX",$J,"AR",0),U,5)
48 I 'SPEC Q
49 S ITEM="M;S;"_SPEC
50 S NODE=LRDFN_";MI;"_LRIDT_";0"
51 D TMPSET(ITEM,NODE)
52 S ACC=$P(^TMP("LRPX",$J,"AR",0),U,6)
53 I $L(ACC) D
54 . D ACCY^LRPXAPI(.TESTS,ACC,DATE)
55 . I $O(TESTS(0)) D
56 .. S TEST=0
57 .. F S TEST=+$O(TESTS(TEST)) Q:TEST<1 D
58 ... S ITEM="M;T;"_TEST
59 ... D TMPSET(ITEM,NODE)
60 I $G(^TMP("LRPX",$J,"AR",1)) D
61 . S ORGNUM=0
62 . F S ORGNUM=$O(^TMP("LRPX",$J,"AR",3,ORGNUM)) Q:ORGNUM<1 D
63 .. S ORG=+$G(^TMP("LRPX",$J,"AR",3,ORGNUM,0))
64 .. I 'ORG Q
65 .. S ITEM="M;O;"_ORG
66 .. S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";0"
67 .. D TMPSET(ITEM,NODE)
68 .. S ABDN=1
69 .. F S ABDN=$O(^TMP("LRPX",$J,"AR",3,ORGNUM,ABDN)) Q:ABDN<1 D
70 ... S AB=$$AB^LRPXAPIU(ABDN)
71 ... I 'AB Q
72 ... S ITEM="M;A;"_AB
73 ... S NODE=LRDFN_";MI;"_LRIDT_";3;"_ORGNUM_";"_ABDN
74 ... D TMPSET(ITEM,NODE)
75 F SUB=6,9,12,17 D
76 . I '$G(^TMP("LRPX",$J,"AR",(SUB-1))) Q
77 . S ORGNUM=0
78 . F S ORGNUM=$O(^TMP("LRPX",$J,"AR",SUB,ORGNUM)) Q:ORGNUM<1 D
79 .. S ORG=+$G(^TMP("LRPX",$J,"AR",SUB,ORGNUM,0))
80 .. I 'ORG Q
81 .. S ITEM="M;O;"_ORG
82 .. S NODE=LRDFN_";MI;"_LRIDT_";"_SUB_";"_ORGNUM_";0"
83 .. D TMPSET(ITEM,NODE)
84 .. I SUB'=12 Q
85 .. S TBDN=2
86 .. F S TBDN=$O(^TMP("LRPX",$J,"AR",12,ORGNUM,TBDN)) Q:TBDN<2 D
87 ... S TB=$$TB^LRPXAPIU(TBDN)
88 ... I '$L(TB) Q
89 ... S ITEM="M;M;"_TB
90 ... S NODE=LRDFN_";MI;"_LRIDT_";12;"_ORGNUM_";"_TBDN
91 ... D TMPSET(ITEM,NODE)
92 D CKDEL
93 D CKADD
94 D DEL(DFN,DATE)
95 D ADD(DFN,DATE)
96 Q
97 ;
98MIVER(LRDFN,LRIDT) ; $$(lrdfn,lridt) -> 1 if any portion of micro is verified
99 N OK,SUB
100 S OK=0
101 F SUB=1,5,8,11,16 D Q:OK
102 . I $G(^LR(LRDFN,"MI",LRIDT,SUB)) S OK=1
103 Q OK
104 ;
105AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
106 N ITEM
107 I '$$APVERIFY^LRPXAPI(LRDFN,LRIDT,SUB) Q
108 S ITEM=0
109 F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
110 . I $E(ITEM)'="A" K ^TMP("LRPX",$J,"B",ITEM)
111 I SUB="AU" D AUTOPSY(LRDFN)
112 E D CYEMSP(LRDFN,LRIDT,DATE,SUB) ; cyto, electron micro, surg path
113 D CKDEL
114 D CKADD
115 D DEL(DFN,DATE)
116 D ADD(DFN,DATE)
117 Q
118 ;
119AUTOPSY(LRDFN) ;
120 N ETIOL,I,II,III,ICD,ICDX,ITEM,NODE,ORGAN,SNOMED,SPEC,SUB,SUBS
121 S SPEC=0
122 F S SPEC=$O(^TMP("LRPX",$J,"AR",33,SPEC)) Q:SPEC<1 D
123 . I '$L($P($G(^TMP("LRPX",$J,"AR",33,SPEC,0)),U)) Q
124 . S ITEM="A;S;1."_$P(^TMP("LRPX",$J,"AR",33,SPEC,0),U)
125 . S NODE=LRDFN_";33;"_SPEC_";0"
126 . D TMPSET(ITEM,NODE)
127 S ICD=0
128 F S ICD=$O(^TMP("LRPX",$J,"AR",80,ICD)) Q:ICD<1 D
129 . S ICDX=+$G(^TMP("LRPX",$J,"AR",80,ICD,0))
130 . I 'ICDX Q
131 . S ITEM="A;I;"_ICDX
132 . S NODE=LRDFN_";80;"_ICD_";0"
133 . D TMPSET(ITEM,NODE)
134 S I=0
135 F S I=$O(^TMP("LRPX",$J,"AR","AY",I)) Q:I<1 D
136 . S ORGAN=+$G(^TMP("LRPX",$J,"AR","AY",I,0))
137 . I 'ORGAN Q
138 . S ITEM="A;O;"_ORGAN
139 . S NODE=LRDFN_";AY;"_I_";0"
140 . D TMPSET(ITEM,NODE)
141 . F SUBS="1D","2M","3F","4P" D
142 .. S SUB=+SUBS
143 .. S II=0
144 .. F S II=$O(^TMP("LRPX",$J,"AR","AY",I,SUB,II)) Q:II<1 D
145 ... S SNOMED=+$G(^TMP("LRPX",$J,"AR","AY",I,SUB,II,0))
146 ... I 'SNOMED Q
147 ... S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
148 ... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
149 ... D TMPSET(ITEM,NODE)
150 ... I SUB'=2 Q
151 ... S III=0
152 ... F S III=$O(^TMP("LRPX",$J,"AR","AY",I,SUB,II,1,III)) Q:III<1 D
153 .... S ETIOL=+$G(^TMP("LRPX",$J,"AR","AY",I,SUB,II,1,III,0))
154 .... I 'ETIOL Q
155 .... S ITEM="A;E;"_ETIOL
156 .... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
157 .... D TMPSET(ITEM,NODE)
158 Q
159 ;
160CYEMSP(LRDFN,LRIDT,DATE,SUB) ;
161 N ACC,I,ICD,ICDX,ITEM,NODE,ORGAN,PREP,SPEC,TEST,TESTS K TESTS
162 I '($P($G(^TMP("LRPX",$J,"AR",0)),U,3)&($P($G(^(0)),U,11))) Q
163 S SPEC=0
164 F S SPEC=$O(^TMP("LRPX",$J,"AR",.1,SPEC)) Q:SPEC<1 D
165 . I '$L($P($G(^TMP("LRPX",$J,"AR",.1,SPEC,0)),U)) Q
166 . S ITEM="A;S;1."_$$UP^XLFSTR($P(^TMP("LRPX",$J,"AR",.1,SPEC,0),U))
167 . S NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";0"
168 . D TMPSET(ITEM,NODE)
169 . S PREP=0
170 . F S PREP=$O(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP)) Q:PREP<1 D
171 .. S TEST=0
172 .. F S TEST=$O(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
173 ... S TEST=+$G(^TMP("LRPX",$J,"AR",.1,SPEC,1,PREP,1,TEST,0))
174 ... I 'TEST Q
175 ... S ITEM="A;T;"_TEST
176 ... S NODE=LRDFN_";"_SUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
177 ... D TMPSET(ITEM,NODE)
178 ; S ACC=$P(^TMP("LRPX",$J,"AR",0),U,6) ; do not use tests on acc
179 ; I $L(ACC) D
180 ; . S NODE=LRDFN_";"_SUB_";"_LRIDT_";0"
181 ; . D ACCY^LRPXAPI(.TESTS,ACC,DATE)
182 ; . I $O(TESTS(0)) D
183 ; .. S TEST=0
184 ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
185 ; ... S ITEM="A;T;"_TEST
186 ; ... D TMPSET(ITEM,NODE)
187 S ICD=0
188 F S ICD=$O(^TMP("LRPX",$J,"AR",3,ICD)) Q:ICD<1 D
189 . S ICDX=+$G(^TMP("LRPX",$J,"AR",3,ICD,0))
190 . I 'ICDX Q
191 . S ITEM="A;I;"_ICDX
192 . S NODE=LRDFN_";"_SUB_";"_LRIDT_";3;"_ICD_";0"
193 . D TMPSET(ITEM,NODE)
194 S I=0
195 F S I=$O(^TMP("LRPX",$J,"AR",2,I)) Q:I<1 D
196 . S ORGAN=+$G(^TMP("LRPX",$J,"AR",2,I,0))
197 . I 'ORGAN Q
198 . S ITEM="A;O;"_ORGAN
199 . S NODE=LRDFN_";"_SUB_";"_LRIDT_";2;"_I_";0"
200 . D TMPSET(ITEM,NODE)
201 . D SNOMED(LRDFN,LRIDT,SUB,I)
202 Q
203 ;
204SNOMED(LRDFN,LRIDT,APSUB,I) ;
205 N ETIOL,II,III,ITEM,NODE,SNOMED,SUB,SUBS
206 F SUBS="1D","2M","3F","4P" D
207 . S SUB=+SUBS
208 . S II=0
209 . F S II=$O(^TMP("LRPX",$J,"AR",2,I,SUB,II)) Q:II<1 D
210 .. S SNOMED=+$G(^TMP("LRPX",$J,"AR",2,I,SUB,II,0))
211 .. I 'SNOMED Q
212 .. S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
213 .. S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";0"
214 .. D TMPSET(ITEM,NODE)
215 .. I SUB'=2 Q
216 .. S III=0
217 .. F S III=$O(^TMP("LRPX",$J,"AR",2,I,SUB,II,1,III)) Q:III<1 D
218 ... S ETIOL=+$G(^TMP("LRPX",$J,"AR",2,I,SUB,II,1,III,0))
219 ... I 'ETIOL Q
220 ... S ITEM="A;E;"_ETIOL
221 ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";1;"_III_";0"
222 ... D TMPSET(ITEM,NODE)
223 Q
224 ;
225TMPSET(ITEM,NODE) ;
226 S ^TMP("LRPX",$J,"A",ITEM,NODE)=""
227 Q
228 ;
229CKDEL ;
230 N ITEM,NODE
231 S ITEM=""
232 F S ITEM=$O(^TMP("LRPX",$J,"B",ITEM)) Q:ITEM="" D
233 . S NODE=""
234 . F S NODE=$O(^TMP("LRPX",$J,"B",ITEM,NODE)) Q:NODE="" D
235 .. I $D(^TMP("LRPX",$J,"A",ITEM,NODE)) Q
236 .. S ^TMP("LRPX",$J,"DEL",ITEM,NODE)=""
237 Q
238 ;
239CKADD ;
240 N ITEM,NODE
241 S ITEM=""
242 F S ITEM=$O(^TMP("LRPX",$J,"A",ITEM)) Q:ITEM="" D
243 . S NODE=""
244 . F S NODE=$O(^TMP("LRPX",$J,"A",ITEM,NODE)) Q:NODE="" D
245 .. I $D(^TMP("LRPX",$J,"B",ITEM,NODE)) Q
246 .. S ^TMP("LRPX",$J,"ADD",ITEM,NODE)=""
247 Q
248 ;
249DEL(DFN,DATE) ;
250 N ITEM,NODE
251 S ITEM=""
252 F S ITEM=$O(^TMP("LRPX",$J,"DEL",ITEM)) Q:ITEM="" D
253 . S NODE=""
254 . F S NODE=$O(^TMP("LRPX",$J,"DEL",ITEM,NODE)) Q:NODE="" D
255 .. D KLAB^LRPX(DFN,DATE,ITEM,NODE)
256 Q
257 ;
258ADD(DFN,DATE) ;
259 N ITEM,NODE
260 S ITEM=""
261 F S ITEM=$O(^TMP("LRPX",$J,"ADD",ITEM)) Q:ITEM="" D
262 . S NODE=""
263 . F S NODE=$O(^TMP("LRPX",$J,"ADD",ITEM,NODE)) Q:NODE="" D
264 .. D SLAB^LRPX(DFN,DATE,ITEM,NODE)
265 .. ; D TIMESTMP^LRLOG(DFN,$P(NODE,";",2),DATE,DUZ) ; *** future lab patch
266 Q
267 ;
Note: See TracBrowser for help on using the repository browser.