source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPXCHK.m@ 1800

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1LRPXCHK ;SLC/STAFF - Lab PXRMINDX Index Validation ;3/30/04 12:01
2 ;;5.2;LAB SERVICE;**295**;Sep 27, 1994
3 ;
4PATS ; select patients for index check
5 N DFN,ERR,REPAIR
6 D CLEAN
7 F D GETPT^LRPXAPPU(.DFN,.ERR) Q:ERR D
8 . S ^TMP("LRLOG PATS",$J,DFN)=""
9 D
10 . I '$O(^TMP("LRLOG PATS",$J,0)) Q
11 . D GETREP(.REPAIR,.ERR) I ERR Q
12 . D CHECK(REPAIR)
13 D CLEAN
14 Q
15 ;
16DATES ; check indexes for a date range of patient collections
17 N CNT,DATE1,DATE2,DFN,LRDFN,LRIDT,OK,REPAIR,START,STOP,SUB
18 D CLEAN
19 D GETDATE^LRPXAPPU(.DATE1,.DATE2,.ERR) I ERR Q
20 D GETREP(.REPAIR,.ERR) I ERR Q
21 S STOP=$$LRIDT^LRPXAPIU(DATE1)
22 S START=$$LRIDT^LRPXAPIU(DATE2)
23 S CNT=0
24 S LRDFN=0
25 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
26 . S OK=0
27 . F SUB="CH","MI","CY","SP","EM" D Q:OK
28 .. S LRIDT=START
29 .. F S LRIDT=$O(^LR(LRDFN,SUB,LRIDT)) Q:LRIDT<1 Q:LRIDT>STOP D Q:OK
30 ... S DFN=$$DFN^LRPXAPIU(LRDFN)
31 ... I 'DFN Q
32 ... S ^TMP("LRLOG PATS",$J,DFN)=""
33 ... S OK=1,CNT=CNT+1
34 W !,CNT," Patients to check"
35 D CHECK(REPAIR)
36 D CLEAN
37 Q
38 ;
39CHECK(REPAIR) ;
40 N CNT,DFN
41 S REPAIR=$G(REPAIR)
42 S DFN=0
43 F S DFN=$O(^TMP("LRLOG PATS",$J,DFN)) Q:DFN<1 D
44 . W !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
45 . D CHKPAT(DFN)
46 S CNT=0
47 S DFN=0
48 F S DFN=$O(^TMP("LRLOG",$J,DFN)) Q:DFN<1 D
49 . S CNT=CNT+1
50 I 'CNT W !,"Indexes were valid" Q
51 W !,CNT," Patients with invalid indexes"
52 I REPAIR D REPAIR
53 Q
54 ;
55ALL ; check all patient indexes
56 ; this takes a very long time
57 ; to be used in small test accounts
58 ; START and STOP determine range of DFNs to check
59 Q ; for testing
60 N DFN,ERR,REPAIR,START,STOP
61 D CLEAN
62 W !,"WARNING - checking ALL patients",!
63 D GETREP(.REPAIR,.ERR) I ERR Q
64 S START=1
65 S STOP=10000000000000
66 S DFN=START-.1
67 F S DFN=$O(^DPT(DFN)) Q:DFN<1 Q:DFN>STOP D
68 . W !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
69 . D CHKPAT(DFN)
70 I REPAIR D REPAIR
71 D CLEAN
72 Q
73 ;
74CHKPAT(DFN) ; from LRLOG
75 ; find bad nodes,
76 ; store as ^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)=NODE
77 ; only when ^TMP("LRLOG PATS",$J) is present
78 ; if ^TMP("LRLOG PATS",$J) is not present, write to screen
79 N ITEM,LRDFN
80 K ^TMP("LRPXCHK",$J)
81 S LRDFN=$$LRDFN^LRPXAPIU(DFN)
82 I 'LRDFN Q
83 M ^TMP("LRPXCHK",$J,"LR",LRDFN)=^LR(LRDFN)
84 M ^TMP("LRPXCHK",$J,"PI",DFN)=^PXRMINDX(63,"PI",DFN)
85 M ^TMP("LRPXCHK",$J,"PDI",DFN)=^PXRMINDX(63,"PDI",DFN)
86 S ITEM=""
87 F S ITEM=$O(^PXRMINDX(63,"IP",ITEM)) Q:ITEM="" D
88 . I $D(^PXRMINDX(63,"IP",ITEM,DFN)) D
89 . M ^TMP("LRPXCHK",$J,"IP",ITEM,DFN)=^PXRMINDX(63,"IP",ITEM,DFN)
90 D INTEG(DFN)
91 D CHKLR(DFN)
92 D CHKPI(DFN,LRDFN)
93 K ^TMP("LRPXCHK",$J)
94 Q
95 ;
96INTEG(DFN) ; make sure "PI", "IP", and "PDI" are consistent
97 N DATE,ITEM,NODE
98 S DATE=0
99 F S DATE=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE)) Q:DATE<1 D
100 . S ITEM="A"
101 . F S ITEM=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM)) Q:ITEM="" D
102 .. S NODE=""
103 .. F S NODE=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) Q:NODE="" D
104 ... I '$D(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) D
105 .... D BAD("PDI-PI",DFN,ITEM,DATE,NODE)
106 ... I '$D(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) D
107 .... D BAD("PDI-IP",DFN,ITEM,DATE,NODE)
108 S ITEM=""
109 F S ITEM=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM)) Q:ITEM="" D
110 . S DATE=0
111 . F S DATE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE)) Q:DATE<1 D
112 .. S NODE=""
113 .. F S NODE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D
114 ... I '$D(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) D
115 .... D BAD("PI-IP",DFN,ITEM,DATE,NODE)
116 ... I 'ITEM,'$D(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) D
117 .... D BAD("PI-PDI",DFN,ITEM,DATE,NODE)
118 S ITEM=""
119 F S ITEM=$O(^TMP("LRPXCHK",$J,"IP",ITEM)) Q:ITEM="" D
120 . S DATE=0
121 . F S DATE=$O(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE)) Q:DATE<1 D
122 .. S NODE=""
123 .. F S NODE=$O(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) Q:NODE="" D
124 ... I '$D(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) D
125 .... D BAD("IP-PI",DFN,ITEM,DATE,NODE)
126 ... I 'ITEM,'$D(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) D
127 .... D BAD("IP-PDI",DFN,ITEM,DATE,NODE)
128 Q
129 ;
130CHKLR(DFN) ; go thru "PI" to make sure ^LR is consistent
131 N DATE,ITEM,NODE
132 S ITEM=""
133 F S ITEM=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM)) Q:ITEM="" D
134 . S DATE=0
135 . F S DATE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE)) Q:DATE<1 D
136 .. S NODE=""
137 .. F S NODE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D
138 ... I '$$REFVAL(NODE) D BAD("LR",DFN,ITEM,DATE,NODE) Q
139 Q
140 ;
141CHKPI(DFN,LRDFN) ; go thru ^LR to make sure "PI" is consistent
142 N DATE,ITEM,LRIDT,LRDN,NODE,ZERO
143 S LRIDT=0
144 F S LRIDT=$O(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
145 . S ZERO=$G(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT,0))
146 . S DATE=+ZERO I 'DATE Q
147 . I '$P(ZERO,U,3) Q
148 . S LRDN=1
149 . F S LRDN=$O(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
150 .. S ITEM=$$TEST^LRPXAPIU(LRDN)
151 .. I 'ITEM Q
152 .. S NODE=LRDFN_";CH;"_LRIDT_";"_LRDN
153 .. I '$D(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) D BAD("CH",DFN,ITEM,DATE,NODE)
154 D MI^LRPXCHKM(DFN,LRDFN)
155 D AP^LRPXCHKA(DFN,LRDFN)
156 Q
157 ;
158TMPCHK(DFN,DATE,ITEM,NODE) ;
159 I '$D(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) D BAD(NODE,DFN,ITEM,DATE,NODE)
160 Q
161 ;
162BAD(INDEX,DFN,ITEM,DATE,NODE) ; write error to screen, collect in global
163 W !,?5,INDEX," ",DFN," ",ITEM," ",DATE," ",NODE
164 S ^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)=NODE
165 Q
166 ;
167CLEAN ; clear tmp globals
168 ; "LRLOG" collects invalid nodes, "LRLOG PATS" are patients checked
169 K ^TMP("LRLOG",$J)
170 K ^TMP("LRLOG PATS",$J)
171 Q
172 ;
173REFVAL(REF) ; $$(reference location in ^LR) -> if ref exists 1, else 0
174 N SUB
175 I REF'[";" Q ""
176 S SUB=$P(REF,";",2)
177 S SUB=""""_SUB_""""
178 S $P(REF,";",2)=SUB
179 S REF=$TR(REF,";",",")
180 S REF="^LR("_REF_")"
181 I $D(@REF) Q 1
182 Q 0
183 ;
184REPAIR ; correct invalid indexes
185 ; kill off bad indexes
186 ; reset all indexes at date of bad index
187 N DATE,DFN,DOD,INDEX,ITEM,NODE,REPAIR K REPAIR
188 S DFN=0
189 F S DFN=$O(^TMP("LRLOG",$J,DFN)) Q:DFN<1 D
190 . S LRDFN=$$LRDFN^LRPXAPIU(DFN)
191 . S DOD=$$DOD^LRPXAPIU(DFN)
192 . S DATE=0
193 . F S DATE=$O(^TMP("LRLOG",$J,DFN,DATE)) Q:DATE<1 D
194 .. S LRIDT=$$LRIDT^LRPXAPIU(DATE)
195 .. K REPAIR
196 .. S ITEM=""
197 .. F S ITEM=$O(^TMP("LRLOG",$J,DFN,DATE,ITEM)) Q:ITEM="" D
198 ... S INDEX=""
199 ... F S INDEX=$O(^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)) Q:INDEX="" D
200 .... S NODE=^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)
201 .... I '$L(NODE) Q
202 .... S REPAIR($P(NODE,";",2))=""
203 .... D KLAB^LRPX(DFN,DATE,ITEM,NODE)
204 .. S SUB=""
205 .. F S SUB=$O(REPAIR(SUB)) Q:SUB="" D
206 ... I SUB="CH" D CH(DFN,LRDFN,DATE,LRIDT) Q
207 ... I SUB="MI" D MICRO(DFN,LRDFN,DATE,LRIDT) Q
208 ... D AP(DFN,LRDFN,DATE,LRIDT,SUB)
209 .. I DATE=DOD D AU(DFN,LRDFN,DATE) Q
210 Q
211 ;
212CH(DFN,LRDFN,DATE,LRIDT) ;
213 N DAT,LRDN,NODE,TEMP,TEST
214 I '$$VERIFIED^LRPXAPI(LRDFN,LRIDT) Q
215 S DAT=LRDFN_";CH;"_LRIDT
216 S LRDN=1
217 F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
218 . S NODE=DAT_";"_LRDN
219 . S TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
220 . S TEST=+$P($P(TEMP,U,3),"!",6)
221 . I 'TEST S TEST=$$TEST^LRPXAPIU(LRDN)
222 . I 'TEST Q
223 . D SLAB^LRPX(DFN,DATE,TEST,NODE)
224 Q
225 ;
226MICRO(DFN,LRDFN,DATE,LRIDT) ;
227 K ^TMP("LRPX",$J)
228 M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,"MI",LRIDT)
229 M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
230 D MICRO^LRPXRM(DFN,LRDFN,DATE,LRIDT)
231 K ^TMP("LRPX",$J)
232 Q
233 ;
234AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
235 K ^TMP("LRPX",$J)
236 M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,SUB,LRIDT)
237 M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
238 D AP^LRPXRM(DFN,LRDFN,DATE,LRIDT,SUB)
239 K ^TMP("LRPX",$J)
240 Q
241 ;
242AU(DFN,LRDFN,DATE) ;
243 I '+$G(^LR(LRDFN,"AU")) Q
244 I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q
245 K ^TMP("LRPX",$J)
246 M ^TMP("LRPX",$J,"AR","AY")=^LR(LRDFN,"AY")
247 M ^TMP("LRPX",$J,"AR",80)=^LR(LRDFN,80)
248 M ^TMP("LRPX",$J,"AR",33)=^LR(LRDFN,33)
249 M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
250 D AUTOPSY^LRPXRM(LRDFN)
251 K ^TMP("LRPX",$J)
252 Q
253 ;
254GETREP(REPAIR,ERR) ;
255 ; asks to repair indexes
256 N DIR,DIRUT,DTOUT,X,Y K DIR
257 S ERR=0,REPAIR=""
258 S DIR(0)="YAO"
259 S DIR("A")="Repair invalid indexes? "
260 S DIR("B")="YES"
261 D ^DIR K DIR
262 I Y[U!$D(DTOUT) S ERR=1 Q
263 S REPAIR=Y
264 W !
265 Q
266 ;
Note: See TracBrowser for help on using the repository browser.