source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLABS.m@ 1470

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PXRMLABS ; SLC/PKR - Estimate of lab entries to set up. ;8/5/03 16:20
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;===============================================================
4NELR() ;.
5 N LRDFN,LRDN,LRIDT,NE,TEMP
6 ;DBIA #4179
7 S NE=0
8 S LRDFN=.9
9 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
10 . S TEMP=$G(^LR(LRDFN,0))
11 . I $P(TEMP,U,2)'=2 Q
12 . S LRIDT=0
13 . F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
14 .. I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3) Q ; check for completed
15 .. S LRDN=1
16 .. F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
17 ... S NE=NE+1
18 D AP(.NE)
19 D MICRO(.NE)
20 Q NE
21 ;
22 ;===============================================================
23AP(NE) ;
24 N ETIOL,I,II,III,ICD,ICDX
25 N LRDFN,ORGAN,SNOMED,SPEC,SUB,SUBS,TEMP
26 ;DBIA #4179
27 K ANUMS
28 D AANUMS(.ANUMS)
29 S LRDFN=.9
30 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
31 . S TEMP=$G(^LR(LRDFN,0))
32 . I $P(TEMP,U,2)'=2 Q
33 . D CYEMSP(LRDFN,.ANUMS,.NE) ; cytology, electron microscopy, sugrical path
34 . I '+$G(^LR(LRDFN,"AU")) Q ; date of autopsy
35 . S NE=NE+1
36 . S SPEC=0
37 . F S SPEC=$O(^LR(LRDFN,33,SPEC)) Q:SPEC<1 D
38 .. I '$L($P($G(^LR(LRDFN,33,SPEC,0)),U)) Q
39 .. S NE=NE+1
40 . S ICD=0
41 . F S ICD=$O(^LR(LRDFN,80,ICD)) Q:ICD<1 D
42 .. S ICDX=+$G(^LR(LRDFN,80,ICD,0))
43 .. I 'ICDX Q
44 .. S NE=NE+1
45 . S I=0
46 . F S I=$O(^LR(LRDFN,"AY",I)) Q:I<1 D
47 .. S ORGAN=+$G(^LR(LRDFN,"AY",I,0))
48 .. I 'ORGAN Q
49 .. S NE=NE+1
50 .. F SUBS="1D","2M","3F","4P" D
51 ... S SUB=+SUBS
52 ... S II=0
53 ... F S II=$O(^LR(LRDFN,"AY",I,SUB,II)) Q:II<1 D
54 .... S SNOMED=+$G(^LR(LRDFN,"AY",I,SUB,II,0))
55 .... I 'SNOMED Q
56 .... S NE=NE+1
57 .... I SUB'=2 Q
58 .... S III=0
59 .... F S III=$O(^LR(LRDFN,"AY",I,SUB,II,1,III)) Q:III<1 D
60 ..... S ETIOL=+$G(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
61 ..... I 'ETIOL Q
62 ..... S NE=NE+1
63 Q
64 ;
65CYEMSP(LRDFN,ANUMS,NE) ;
66 N ACC,APSUB,DATE,ERR,I,ICD,ICDX,LRIDT,NODE,ORGAN,PREP,SPEC
67 N TEST,TESTS K TESTS
68 ;DBIA #4179
69 F APSUB="CY","EM","SP" D
70 . I '$D(^LR(LRDFN,APSUB,0)) Q
71 . S LRIDT=0
72 . F S LRIDT=$O(^LR(LRDFN,APSUB,LRIDT)) Q:LRIDT<1 D
73 .. S DATE=+$G(^LR(LRDFN,APSUB,LRIDT,0))
74 .. I 'DATE Q
75 .. I '($P(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($P(^(0),U,11))) Q
76 .. S SPEC=0
77 .. F S SPEC=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC)) Q:SPEC<1 D
78 ... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U)) Q
79 ... S NE=NE+1
80 ... S PREP=0
81 ... F S PREP=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP)) Q:PREP<1 D
82 .... S TEST=0
83 .... F S TEST=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
84 ..... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0)),U)) Q
85 ..... S NE=NE+1
86 .. S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6)
87 .. I $L(ACC) D
88 ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
89 ... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
90 ... I 'ERR D
91 .... S TEST=0
92 .... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
93 ..... S NE=NE+1
94 .. S ICD=0
95 .. F S ICD=$O(^LR(LRDFN,APSUB,LRIDT,3,ICD)) Q:ICD<1 D
96 ... S ICDX=+$G(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
97 ... I 'ICDX Q
98 ... S NE=NE+1
99 .. S I=0
100 .. F S I=$O(^LR(LRDFN,APSUB,LRIDT,2,I)) Q:I<1 D
101 ... S ORGAN=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,0))
102 ... I 'ORGAN Q
103 ... S NE=NE+1
104 ... D SNOMED(LRDFN,LRIDT,DATE,APSUB,I,.NE)
105 Q
106 ;
107SNOMED(LRDFN,LRIDT,DATE,APSUB,I,NE) ;
108 N ETIOL,II,III,SNOMED,SUB,SUBS
109 ;DBIA #4179
110 F SUBS="1D","2M","3F","4P" D
111 . S SUB=+SUBS
112 . S II=0
113 . F S II=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II)) Q:II<1 D
114 .. S SNOMED=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
115 .. I 'SNOMED Q
116 .. S NE=NE+1
117 .. I SUB'=2 Q
118 .. S III=0
119 .. F S III=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III)) Q:III<1 D
120 ... S ETIOL=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
121 ... I 'ETIOL Q
122 ... S NE=NE+1
123 Q
124 ;
125 ;===============================================================
126MICRO(NE) ;
127 N AB,ABDN,ACC,ANUMS,DATE,ERR
128 N LRDFN,LRIDT,ORG,ORGNUM,SPEC,SUB
129 N TB,TBDN,TEMP,TEST,TESTS
130 ;DBIA #4179
131 K ANUMS,TESTS
132 D AANUMS(.ANUMS)
133 S LRDFN=.9
134 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
135 . S TEMP=$G(^LR(LRDFN,0))
136 . I $P(TEMP,U,2)'=2 Q
137 . S LRIDT=0
138 . F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
139 .. S DATE=+$G(^LR(LRDFN,"MI",LRIDT,0))
140 .. I 'DATE Q
141 .. S SPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
142 .. I 'SPEC Q
143 .. S NE=NE+1
144 .. S ACC=$P(^LR(LRDFN,"MI",LRIDT,0),U,6)
145 .. I $L(ACC) D
146 ... D ACC(.TESTS,ACC,DATE,.ANUMS,.ERR)
147 ... I 'ERR D
148 .... S TEST=0
149 .... F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
150 ..... S NE=NE+1
151 .. I $G(^LR(LRDFN,"MI",LRIDT,1)) D
152 ... S ORGNUM=0
153 ... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM)) Q:ORGNUM<1 D
154 .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,0))
155 .... I 'ORG Q
156 .... S NE=NE+1
157 .... S ABDN=1
158 .... F S ABDN=$O(^LR(LRDFN,"MI",LRIDT,3,ORGNUM,ABDN)) Q:ABDN<1 D
159 ..... S AB=+$G(^TMP("LRPXSXRB",$J,"AB",ABDN))
160 ..... I 'AB Q
161 ..... S NE=NE+1
162 .. F SUB=6,9,12,17 D
163 ... I '$G(^LR(LRDFN,"MI",LRIDT,(SUB-1))) Q
164 ... S ORGNUM=0
165 ... F S ORGNUM=$O(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM)) Q:ORGNUM<1 D
166 .... S ORG=+$G(^LR(LRDFN,"MI",LRIDT,SUB,ORGNUM,0))
167 .... I 'ORG Q
168 .... S NE=NE+1
169 .... I SUB'=12 Q
170 .... S TBDN=2
171 .... F S TBDN=$O(^LR(LRDFN,"MI",LRIDT,12,ORGNUM,TBDN)) Q:TBDN<2 D
172 ..... S TB=+$G(^TMP("LRPXSXRB",$J,"TB",TBDN))
173 ..... I '$L(TB) Q
174 ..... S NE=NE+1
175 Q
176 ;
177AANUMS(ANUMS) ;
178 N AA,ABREV K ANUMS
179 ;DBIA #4185
180 S AA=0
181 F S AA=$O(^LRO(68,AA)) Q:AA<1 D
182 . S ABREV=$P($G(^LRO(68,AA,0)),U,11)
183 . I $L(ABREV) S ANUMS(ABREV)=AA
184 Q
185 ;
186ACC(TESTS,ACC,BDN,ANUMS,ERR) ;
187 ; returns TESTS from micro accession, ACC, BDN required
188 ; BDN is beginning date number
189 ; ANUMS is array of accession name numbers (avoids lookup on repeated calls)
190 N DIC,LRAA,LRAAB,LRAD,LRAN,TEST,X,Y K DIC,TESTS
191 S ERR=0
192 I '$L($G(ACC)) S ERR=1 Q
193 S LRAAB=$P(ACC," ")
194 I LRAAB="" Q
195 S BDN=$E($G(BDN))
196 I BDN'>1 S ERR=1 Q
197 S LRAN=+$P(ACC," ",3)
198 I 'LRAN S ERR=1 Q
199 S LRAA=+$G(ANUMS(LRAAB))
200 I 'LRAA D
201 . S DIC=68,DIC(0)="M"
202 . S X=LRAAB
203 . D ^DIC K DIC
204 . S LRAA=+Y
205 . S ANUMS(LRAAB)=LRAA
206 I LRAA'>0 S ERR=1 Q
207 S LRAD=BDN_$P(ACC," ",2)_"0000" ; yearly acc areas are assumed
208 S TEST=0
209 F S TEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TEST)) Q:TEST<1 D
210 . S TESTS(TEST)=TEST
211 Q
212 ;
Note: See TracBrowser for help on using the repository browser.