source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53618.m@ 940

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1DG53618 ;ALB/GN/PHH,EG - DG*5.3*618 CLEANUP DANGLING RECS; 04/27/2005
2 ;;5.3;Registration;**618**;Aug 13, 1993
3 ;
4 ; Cleans up dangling file Income Relation file #408.12 records where
5 ; it points to bad or non-existent Income Person file #408.13 and
6 ; Patient file #2 records.
7 ;
8 ; 1. If it points to file 2, that doesn't exist or has a bad 0 node,
9 ; delete the 408.12 rec that points to the bad 2 rec, then
10 ; delete the 408.21 that points to 408.12 rec, then
11 ; delete the 408.22 rec that points to the 408.21.
12 ; 2. Same logic will be used if points to bad 408.13 recs
13 ;
14 Q
15 ;
16POST ;post install entry tag call. processes entire file in live mode
17 N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
18 D MES^XPDUTL("")
19 D MES^XPDUTL("=====================================================")
20 D MES^XPDUTL("Queuing Bad Patient Relation Pointers cleanup process.....")
21 I $$CHKSTAT(1) D Q
22 . D BMES^XPDUTL("ABORTING Post Install Cleanup Queuing")
23 . D MES^XPDUTL("=====================================================")
24 . Q
25 S ZTRTN="QUE^DG53618"
26 S ZTDESC="Cleanup Bad Pointers In Patient Relation File"
27 S ZTIO="",ZTDTH=$H
28 S CHKPNT=0,ZTSAVE("CHKPNT")=""
29 D ^%ZTLOAD
30 D MES^XPDUTL("This request queued as Task # "_ZTSK)
31 D MES^XPDUTL("=====================================================")
32 D MES^XPDUTL("")
33 Q
34 ;
35TEST ; Entry point for taskman (testing mode)
36 N TESTING,ZTQUEUED
37 S TESTING=1,ZTQUEUED=0
38 ;if running again, check to see if complete
39 ;if so, ask user to rerun
40 I $$CHKSTAT(0) D Q
41 . U 0 W !,"Task is already running or user opted to not restart"
42 . Q
43 D QUE
44 Q
45QUE ; Entry point for taskman (live mode)
46 N NAMSPC S NAMSPC=$$NAMSPC^DG53618
47 N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,DGTOT,DGDEL12,BEGTIME,PURGDT,DGDEL21
48 N TMP,ICDT,COUNT,TYPE,TYPNAM,DGDEL22,REC12,REC21,REC22
49 N DGBAD03,DGBADPAT,DGBADPER
50 N R12,PT,DFN,X,U
51 S U="^"
52 I '$D(TESTING) N TESTING S TESTING=0
53 I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED=1
54 ;
55 ;get last run info if exists
56 S XREC=$G(^XTMP(NAMSPC,0,0))
57 S R12=+$P(XREC,U,1) ;last REC processed
58 S DGTOT=+$P(XREC,U,2) ;total records processed
59 S DGDEL12=+$P(XREC,U,3) ;total bad 408.12 records purged
60 S DGDEL21=+$P(XREC,U,7) ;total bad 408.21 records found
61 S DGDEL22=+$P(XREC,U,8) ;total bad 408.22 records found
62 S DGBADPAT=+$P(XREC,U,9) ;total bad pointer to file #2
63 S DGBADPER=+$P(XREC,U,10) ;total bad pointer to file #408.13
64 S DGBAD03=+$P(XREC,U,11) ;null or bad field # 03
65 ;
66 ;setup XTMP according to stds.
67 D SETUPX(90)
68 ;
69 ;init status field and start date & time if null
70 S $P(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
71 S:$P(^XTMP(NAMSPC,0,0),U,4)="" $P(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
72 ;
73 ;drive through 408.12 looking for bad variable pointers
74 S ZTSTOP=0
75 F QQ=1:1 S R12=$O(^DGPR(408.12,R12)) Q:(R12'>0)!ZTSTOP D
76 . ;check for stop request after every 20 processed DFN recs
77 . I QQ#20=0 D
78 . . S:$$S^%ZTLOAD ZTSTOP=1
79 . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
80 . . Q
81 . I ZTSTOP Q
82 . S DGTOT=DGTOT+1
83 . S $P(^XTMP(NAMSPC,0,0),U,1,2)=R12_U_DGTOT
84 . ;
85 . S DFN=$$GET1^DIQ(408.12,R12_",",.01,"I")
86 . S PT=$$GET1^DIQ(408.12,R12_",",.03,"I")
87 . ;
88 . ;good patient (#.01),good variable pointer (#.03)...quit
89 . I $$GOODPAT(DFN)="Y",$$GOODPTR(PT)="Y" Q
90 . ;
91 . ; cleanup Income Relation file #408.12 & the bad pointed to file
92 . ; either Patient file #2 or Income Person file #408.13
93 . I 'ZTQUEUED W !!,"File #408.12, ien ",R12," has a bad pointer to "
94 . ;if patient (#.01) is null
95 . I DFN="" D
96 . . S X="null patient (field #.01)"
97 . . I 'ZTQUEUED W X
98 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
99 . . S DGBADPAT=DGBADPAT+1
100 . . D ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
101 . . Q
102 . ;patient #.01 not found
103 . I DFN'="",$$GOODPAT(DFN)="N" D
104 . . S X="patient "_DFN_" (field #.01)"
105 . . I 'ZTQUEUED W X
106 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
107 . . S DGBADPAT=DGBADPAT+1
108 . . ;I 'TESTING S DA=DFN,DIK="^DPT(" D ^DIK
109 . . D ACHK03(R12,PT,ZTQUEUED,TESTING,.DGBADPAT,.DGBADPER,.DGBAD03)
110 . . Q
111 . ;patient (#.03) is also a patient, is bad, but patient (# .01) is ok
112 . I $$GOODPAT(DFN)="Y",PT["DPT",$$GOODPTR(PT)="N" D
113 . . S X="patient "_$P(PT,";",1)_" (field #.03)"
114 . . I 'ZTQUEUED W X
115 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
116 . . S DGBADPAT=DGBADPAT+1
117 . . ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
118 . . Q
119 . ;patient (#.01) is good, but income person is bad
120 . I $$GOODPAT(DFN)="Y",PT["DGPR",$$GOODPTR(PT)="N" D
121 . . S X="income person "_$P(PT,";",1)_" (field #.03)"
122 . . I 'ZTQUEUED W X
123 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
124 . . S DGBADPER=DGBADPER+1
125 . . I 'TESTING S DA=$P(PT,";",1),DIK="^DGPR(408.13," D ^DIK
126 . . Q
127 . ;patient #.01 is good, but #.03 is null
128 . I $$GOODPAT(DFN)="Y",PT="" D
129 . . S X="null field #.03"
130 . . I 'ZTQUEUED W X
131 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
132 . . S DGBAD03=DGBAD03+1
133 . . Q
134 . ;patient #.01 is good, but #.03 is not null
135 . ;and is bad
136 . I $$GOODPAT(DFN)="Y",PT'["DGPR",PT'["DPT",PT'="",$$GOODPTR(PT)="N" D
137 . . S X="variable pointer "_$P(PT,";",1)_" (field #.03)"
138 . . I 'ZTQUEUED W X
139 . . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",1)=X
140 . . S DGBAD03=DGBAD03+1
141 . . Q
142 . D DEL40812(R12,.DGDEL12,.DGDEL21,.DGDEL22,ZTQUEUED,TESTING,NAMSPC)
143 . Q
144 ;
145 ;update last processed info
146 S X=$G(^XTMP(NAMSPC,0,0))
147 S $P(X,U,3)=DGDEL12,$P(X,U,7)=DGDEL21
148 S $P(X,U,8)=DGDEL22,$P(X,U,9)=DGBADPAT
149 S $P(X,U,10)=DGBADPER,$P(X,U,11)=DGBAD03
150 S ^XTMP(NAMSPC,0,0)=X
151 ;set status and mail stats
152 I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
153 E S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
154 S X=$$MAIL^DG53618M(TESTING)
155 K TESTING
156 L -^XTMP($$NAMSPC)
157 Q
158 ;
159GOODPAT(DFN) ;determine if patient is there
160 N X,U
161 S U="^"
162 I DFN="" Q "N"
163 I '$D(^DPT(DFN,0)) Q "N"
164 S X=$G(^DPT(DFN,0)) I X="" Q "N"
165 I X?13"^".E Q "N"
166 Q "Y"
167 ;
168GOODPTR(PT) ;determine if reference is there
169 N X,U,SUB,GL,REF
170 S U="^"
171 I PT'["DPT",PT'["DGPR" Q "N"
172 S SUB=$P(PT,";",1),GL=$P(PT,";",2)
173 I SUB="" Q "N"
174 I SUB'=+SUB S SUB=$C(34)_SUB_$C(34)
175 I GL'="DPT(",GL'="DGPR(408.13," Q "N"
176 S REF="^"_GL_SUB_",0)"
177 S X=$G(@REF)
178 I '$D(@REF) Q "N"
179 I $G(GL)["DPT",X?13"^".E Q "N"
180 I $G(GL)["DGPR",$P(X,U,1)="" Q "N"
181 Q "Y"
182 ;
183 ;at this point, you have a bad .01 field, but want
184 ;to check .03 also
185ACHK03(R12,PT,ZTQUEUED,TESTING,DGBADPAT,DGBADPER,DGBAD03) ;
186 ;update counters to include bad variable pointers
187 ;bad pointer to patient
188 I PT["DPT",$$GOODPTR(PT)="N" D Q
189 . S DGBADPAT=DGBADPAT+1
190 . S X="and bad patient pointer "_$P(PT,";",1)_" (field #.03)"
191 . I 'ZTQUEUED W !," ",X
192 . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
193 . ;I 'TESTING S DA=$P(PT,";",1),DIK="^DPT(" D ^DIK
194 . Q
195 ;bad pointer to income person
196 I PT["DGPR",$$GOODPTR(PT)="N" D Q
197 . S DGBADPER=DGBADPER+1
198 . S X="and bad income person pointer "_$P(PT,";",1)_" (field #.03)"
199 . I 'ZTQUEUED W !," ",X
200 . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
201 . I 'TESTING S DA=$P(PT,";",1),DIK="^DGPR(408.13," D ^DIK
202 . Q
203 ;null variable pointer
204 I PT="" D Q
205 . S X="and null pointer (field #.03)"
206 . I 'ZTQUEUED W !," ",X
207 . S DGBAD03=DGBAD03+1
208 . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
209 . Q
210 ;bad variable pointer
211 I $$GOODPTR(PT)="N" D
212 . S X="and bad variable pointer "_$P(PT,";",1)_" (field #.03)"
213 . I 'ZTQUEUED W !," ",X
214 . S DGBAD03=DGBAD03+1
215 . S ^XTMP(NAMSPC,"BADPR",R12,"ERR",2)=X
216 . Q
217 Q
218 ;
219DEL40812(R12,DGDEL12,DGDEL21,DGDEL22,ZTQUEUED,TESTING,NAMSPC) ;
220 ; Kill bad #408.12 file rec and files that point to it
221 N DA,DIK,R21,R22,X
222 S DA=R12,DIK="^DGPR(408.12," D ^DIK:'TESTING
223 S DGDEL12=DGDEL12+1
224 I 'ZTQUEUED W !,?2,"Deleting 408.12 ien > ",R12
225 ;
226 ;kill all 408.21's that point to the bad 408.12
227 S R21=0
228 F S R21=$O(^DGMT(408.21,"C",R12,R21)) Q:'R21 D
229 . I 'TESTING S DA=R21,DIK="^DGMT(408.21," D ^DIK
230 . S DGDEL21=DGDEL21+1
231 . S X="Deleting related ien "_R21_" in file #408.21"
232 . I 'ZTQUEUED W !,?4,X
233 . S ^XTMP(NAMSPC,"BADPR",R12,"REL",R21)=X
234 . ;
235 . ;kill all 408.22's that point to the bad 408.21
236 . S R22=0
237 . F S R22=$O(^DGMT(408.22,"AIND",R21,R22)) Q:'R22 D
238 . . I 'TESTING S DA=R22,DIK="^DGMT(408.22," D ^DIK
239 . . S DGDEL22=DGDEL22+1
240 . . S X="Deleting related ien "_R22_" in file # 408.22"
241 . . I 'ZTQUEUED W !,?6,X
242 . . S ^XTMP(NAMSPC,"BADPR",R12,"REL",R21,R22)=X
243 . . Q
244 . Q
245 Q
246 ;
247CHKSTAT(POST) ;
248 N Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC
249 S QUIT=0
250 S NAMSPC=$$NAMSPC
251 L +^XTMP(NAMSPC):1
252 I '$T D BMES^XPDUTL("*** ALREADY RUNNING ***") Q 1
253 ;
254 ; get job status
255 S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5)
256 S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6)
257 ;
258 I POST D KILIT Q 0
259 ;
260 ;if job Completed and run from menu opt, ask to Re-Run
261 I STAT="COMPLETED" D
262 . W " was Completed on "_$$FMTE^XLFDT(STIME)
263 . W !," Do you want to Re-Run again?"
264 . K DIR
265 . S DIR("?",1)=" Entering Y, will delete the XTMP global where theprevious cleanup"
266 . S DIR("?")=" information was stored and begin a new job, or N to cancel request"
267 . S DIR(0)="Y" D ^DIR
268 . I 'Y S QUIT=1 Q
269 . W !," ARE YOU SURE?"
270 . K DIR
271 . S DIR("?")="Enter Y to begin a new Job or N to cancel request"
272 . S DIR(0)="Y" D ^DIR
273 . I 'Y S QUIT=1 Q
274 . ;fall thru to re-run mode, kill ^XTMPs
275 . D KILIT
276 . Q
277 Q QUIT
278 ;
279KILIT ; kill Xtmp work file for a re-run
280 S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53618
281 K ^XTMP(NAMSPC)
282 Q
283 ;
284STOP ; alternate stop method
285 S ^XTMP($$NAMSPC,0,"STOP")=""
286 Q
287 ;
288SETUPX(EXPDAY) ;Setup XTMP
289 N BEGTIME,PURGDT,NAMSPC,U
290 S U="^"
291 S NAMSPC=$$NAMSPC^DG53618
292 S BEGTIME=$$NOW^XLFDT()
293 S PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY)
294 S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
295 S $P(^XTMP(NAMSPC,0),U,3)="Cleanup Bad Pointers In PATIENT RELATION File"
296 Q
297 ;
298NAMSPC() ; Return a consistent name space variable
299 Q $T(+0)
Note: See TracBrowser for help on using the repository browser.