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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1DG488 ;ALB/GN - CLEANUP PATIENT RELATION & INCOME FILES;12/11/02 ; 2/4/03 1:25pm
2 ;;5.3;REGISTRATION;**488**;5-1-2001
3 ;
4 Q
5 ;
6TEST ; Entry point for testing this routine, then fall thru.
7 S TESTING=1
8EN ; Entry point to start job
9 ;
10 N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE
11 ;
12 S TESTING=+$G(TESTING)
13 ; setup TM variables and Load
14 S ZTSAVE("TESTING")=""
15 S ZTRTN=("TASK^DG488")
16 S ZTDESC="Cleanup Patient Relation & Income Files"
17 S ZTIO=""
18 W !!,ZTDESC,!
19 ;
20 ;check if already running or completed.
21 S QUIT=$$CHKSTAT
22 I QUIT L -^XTMP($$NAMSPC) K TESTING Q
23 D ^%ZTLOAD
24 L -^XTMP($$NAMSPC)
25 K TESTING
26 I $D(ZTSK) D
27 . W !,"This request queued as Task # ",ZTSK,!
28 Q
29 ;
30TASK ; Entry point for taskman
31 L +^XTMP($$NAMSPC):10 I '$T D Q ;quit if can't get a lock
32 . S $P(^XTMP($$NAMSPC,0,0),U,12)="NO LOCK GAINED"
33 N ZTSTOP,LSTREC,DIK,DA,NAMSPC,DGT12,DG12,DG12X,DGT22,DG22,DG22X
34 N BEGTIME,PURGDT,DGFIL,IEN,DGIEN,BTIME,STAT,STIME,DGT21,DG21,DG21X
35 S NAMSPC=$$NAMSPC
36 S ZTDESC=$G(ZTDESC,"Cleanup of Patient Related Income files")
37 ;
38 S TESTING=$G(TESTING,1) ;assume testing if not defined
39 ;setup XTMP according to stds.
40 S BEGTIME=$$NOW^XLFDT()
41 S PURGDT=$$FMADD^XLFDT(BEGTIME,30)
42 S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME_U_ZTDESC
43 S ^XTMP(NAMSPC,0,"TASKID")=$G(ZTSK,"DIRECT")
44 S ^XTMP(NAMSPC,0,"TESTING")=TESTING
45 ;get last run data
46 D GETLAST
47 ;init begin time, if not there, and status & stop time fields
48 S $P(^XTMP(NAMSPC,0,0),U,12,13)="RUNNING^"
49 S:$P(^XTMP(NAMSPC,0,0),U,11)="" $P(^XTMP(NAMSPC,0,0),U,11)=$$NOW^XLFDT
50 ;start/restart cleanups
51 S:DGFIL="" DGFIL=408.12
52 I DGFIL=408.12 D
53 . S IEN=DGIEN,DGIEN=0
54 . D DG40812(IEN)
55 . S:'ZTSTOP DGFIL=408.21 ;continue if stop not requested
56 I DGFIL=408.21 D
57 . S IEN=DGIEN,DGIEN=0
58 . D DG40821(IEN)
59 . S:'ZTSTOP DGFIL=408.22 ;continue if stop not requested
60 I DGFIL=408.22 D
61 . S IEN=DGIEN
62 . D DG40822(IEN)
63 ;
64 ;set status and mail stats
65 I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,12,13)="STOPPED"_U_$$NOW^XLFDT
66 E S $P(^XTMP(NAMSPC,0,0),U,12,13)="COMPLETED"_U_$$NOW^XLFDT
67 D MAIL^DG488M
68 L -^XTMP(NAMSPC)
69 K TESTING
70 Q
71 ;
72DG40812(IEN) ; Main Cleanup driver for file 408.12
73 N REC12 S ZTSTOP=0
74 F S IEN=$O(^DGPR(408.12,"B",IEN)) Q:('IEN)!(ZTSTOP) D
75 . S REC12=0
76 . F S REC12=$O(^DGPR(408.12,"B",IEN,REC12)) Q:('REC12)!(ZTSTOP) D
77 . . S DGT12=DGT12+1
78 . . ;
79 . . ;if bad xref then kill the xref, else check for damaged 0 node
80 . . I '$D(^DGPR(408.12,REC12)) D
81 . . . S ^XTMP(NAMSPC,408.12,"B",IEN,REC12)=""
82 . . . I 'TESTING K ^DGPR(408.12,"B",IEN,REC12)
83 . . . S DG12X=DG12X+1
84 . . E D
85 . . . Q:+$P(^DGPR(408.12,REC12,0),U,3) ;quit if piece 3 is there
86 . . . M ^XTMP(NAMSPC,"408.12",REC12)=^DGPR(408.12,REC12)
87 . . . D DEL40821(REC12,.DG21,.DG21X)
88 . . . ;
89 . . . ;delete bad 408.12
90 . . . S DIK="^DGPR(408.12,",DA=REC12
91 . . . I 'TESTING D ^DIK
92 . . . K DIK,DA
93 . . . S DG12=DG12+1
94 . . ;
95 . . ;check for stop request after every 100 processed recs
96 . . I DGT12#100=0 D
97 . . . S:$$S^%ZTLOAD ZTSTOP=1
98 . . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
99 . . S LSTREC=DGFIL_"/"_IEN
100 . . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
101 . . S $P(^XTMP(NAMSPC,0,0),U,2,6)=DGT12_U_DG12_U_DG12X_U_DGT22_U_DG22
102 . . S $P(^XTMP(NAMSPC,0,0),U,9,10)=DG21_U_DG21X
103 Q
104 ;
105DEL40821(R12,DG21,DG21X) ; Delete any entries in 408.21 that point to the bad
106 ; 408.12 record.
107 N REC21 S REC21=0
108 F S REC21=$O(^DGMT(408.21,"C",R12,REC21)) Q:'REC21 D
109 . ;if bad xref then kill the xref, else kill the real record
110 . I '$D(^DGMT(408.21,REC21)) D
111 . . S ^XTMP(NAMSPC,408.21,"C",R12,REC21)=""
112 . . I 'TESTING K ^DGMT(408.21,"C",R12,REC21)
113 . . S DG21X=DG21X+1
114 . E D
115 . . M ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
116 . . D DG22AIND(REC21)
117 . . S DIK="^DGMT(408.21,",DA=REC21
118 . . I 'TESTING D ^DIK
119 . . K DIK,DA
120 . . S DG21=DG21+1
121 Q
122 ;
123DG22AIND(R21) ;Delete any entries in 408.22 that is pointing to the bad 408.21
124 N REC22 S REC22=0
125 F S REC22=$O(^DGMT(408.22,"AIND",R21,REC22)) Q:'REC22 D
126 . S DGT22=DGT22+1
127 . ;if bad xref then kill the xref, else kill the real record
128 . I '$D(^DGMT(408.22,REC22)) D
129 . . I 'TESTING K ^DGMT(408.22,"AIND",R21,REC22)
130 . . S DG22=DG22+1
131 . E D
132 . . M ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
133 . . S DIK="^DGMT(408.22,",DA=REC22
134 . . I 'TESTING D ^DIK
135 . . K DIK,DA
136 . . S DG22=DG22+1
137 Q
138 ;
139DG40821(IEN) ; Main Cleanup driver for file 408.21, If 408.21 not pointed to
140 ; by any 408.22 record, then delete it and check 408.12 for possible
141 ; deletion as well.
142 N REC21 S ZTSTOP=0
143 F S IEN=$O(^DGMT(408.21,"B",IEN)) Q:('IEN)!(ZTSTOP) D
144 . S REC21=0
145 . F S REC21=$O(^DGMT(408.21,"B",IEN,REC21)) Q:('REC21)!(ZTSTOP) D
146 . . S DGT21=DGT21+1
147 . . ;if bad xref then kill the xref, else check for damaged 0 node
148 . . I '$D(^DGMT(408.21,REC21)) D
149 . . . S ^XTMP(NAMSPC,408.21,"B",IEN,REC21)=""
150 . . . I 'TESTING K ^DGMT(408.21,"B",IEN,REC21)
151 . . . S DG21X=DG21X+1
152 . . E D
153 . . . Q:$D(^DGMT(408.22,"AIND",REC21)) ;quit if 408.21 pointed to
154 . . . M ^XTMP(NAMSPC,"408.21",REC21)=^DGMT(408.21,REC21)
155 . . . S REC12=0
156 . . . D DEL21(REC21,.REC12,.DG21)
157 . . . D:REC12 CHK40812(REC12,REC21,.DG12)
158 . . ;
159 . . ;check for stop request after every 100 processed recs
160 . . I DGT21#100=0 D
161 . . . S:$$S^%ZTLOAD ZTSTOP=1
162 . . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
163 . . S LSTREC=DGFIL_"/"_IEN
164 . . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
165 . . S $P(^XTMP(NAMSPC,0,0),U,3)=DG12
166 . . S $P(^XTMP(NAMSPC,0,0),U,8,10)=DGT21_U_DG21_U_DG21X
167 Q
168 ;
169DEL21(R21,R12,DG21) ; save to Xtmp & associated REC12, then delete the 408.21
170 Q:'$D(^DGMT(408.21,R21))
171 M ^XTMP(NAMSPC,"408.21",R21)=^DGMT(408.21,R21)
172 S R12=+$P($G(^DGMT(408.21,R21,0)),U,2)
173 S DIK="^DGMT(408.21,",DA=R21
174 I 'TESTING D ^DIK
175 K DIK,DA
176 S DG21=DG21+1
177 Q
178 ;
179CHK40812(R12,R21,DG12) ; delete 408.12's if no other 408.21's pointing to it
180 N XX,OK,REC21 S (REC21,OK)=0
181 F XX=0:1 S REC21=$O(^DGMT(408.21,"C",R12,REC21)) Q:'REC21 D
182 . S:REC21=R21 OK=1
183 Q:XX>1 ;quit if other 408.21's are pointing to 408.12
184 Q:(XX=1)&('OK) ;quit if only one rec and not the correct one
185 ;
186 M ^XTMP(NAMSPC,"408.12",R12)=^DGPR(408.12,R12)
187 S DIK="^DGPR(408.12,",DA=R12
188 I 'TESTING D ^DIK
189 K DIK,DA
190 S DG12=DG12+1
191 Q
192 ;
193DG40822(IEN) ; Main Cleanup driver for file 408.22
194 N REC22 S ZTSTOP=0
195 F S IEN=$O(^DGMT(408.22,"B",IEN)) Q:('IEN)!(ZTSTOP) D
196 . S REC22=0
197 . F S REC22=$O(^DGMT(408.22,"B",IEN,REC22)) Q:('REC22)!(ZTSTOP) D
198 . . S DGT22=DGT22+1
199 . . ;
200 . . ;if bad xref then kill the xref, else check for damaged 0 node
201 . . I '$D(^DGMT(408.22,REC22)) D
202 . . . S ^XTMP(NAMSPC,"408.22","B",IEN,REC22)=""
203 . . . I 'TESTING K ^DGMT(408.22,"B",IEN,REC22)
204 . . . S DG22X=DG22X+1
205 . . E D
206 . . . Q:+$P(^DGMT(408.22,REC22,0),U,2) ;quit if piece 2 is there
207 . . . ;save & delete bad 408.22 rec
208 . . . M ^XTMP(NAMSPC,"408.22",REC22)=^DGMT(408.22,REC22)
209 . . . S DIK="^DGMT(408.22,",DA=REC22
210 . . . I 'TESTING D ^DIK
211 . . . K DIK,DA
212 . . . S DG22=DG22+1
213 . . ;
214 . . ;check for stop request after every 100 processed recs
215 . . I DGT22#100=0 D
216 . . . S:$$S^%ZTLOAD ZTSTOP=1
217 . . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
218 . . S LSTREC=DGFIL_"/"_IEN
219 . . S $P(^XTMP(NAMSPC,0,0),U,1)=LSTREC
220 . . S $P(^XTMP(NAMSPC,0,0),U,5,7)=DGT22_U_DG22_U_DG22X
221 Q
222 ;
223CHKSTAT() ;check if job is running, stopped, or completed
224 N Y,DUOUT,DTOUT,QUIT,NAMSPC
225 S QUIT=0
226 S NAMSPC=$$NAMSPC
227 L +^XTMP(NAMSPC):1
228 I '$T W !!,*7,"*** ALREADY RUNNING ***" H 4 Q 1
229 ;
230 ; get current mode
231 N TESTMODE S TESTMODE=$G(^XTMP(NAMSPC,0,"TESTING"))
232 ; get job status
233 S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,12)
234 S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,13)
235 Q:STAT="" QUIT
236 ;
237 ;if job Completed or trying to resume in Live mode when previously
238 ;incompleted in Test mode, ask to Re-Run
239 I STAT="COMPLETED" D
240 . D MSG(.QUIT)
241 E D
242 . I ('TESTING&TESTMODE)!(TESTING&'TESTMODE) D MSG(.QUIT)
243 Q QUIT
244 ;
245GETLAST ;get last run info
246 S DGFIL=$P($G(^XTMP(NAMSPC,0,0)),"/") ;file
247 S DGIEN=+$P($G(^XTMP(NAMSPC,0,0)),"/",2) ;ien
248 S DGT12=+$P($G(^XTMP(NAMSPC,0,0)),U,2) ;tot 408.12 recs processed
249 S DG12=+$P($G(^XTMP(NAMSPC,0,0)),U,3) ;tot 408.12 recs purged
250 S DG12X=+$P($G(^XTMP(NAMSPC,0,0)),U,4) ;tot bad 408.12 "B" purged
251 S DGT22=+$P($G(^XTMP(NAMSPC,0,0)),U,5) ;tot 408.22 recs processed
252 S DG22=+$P($G(^XTMP(NAMSPC,0,0)),U,6) ;tot 408.22 recs purged
253 S DG22X=+$P($G(^XTMP(NAMSPC,0,0)),U,7) ;tot bad 408.22 "B" purged
254 S DGT21=+$P($G(^XTMP(NAMSPC,0,0)),U,8) ;tot 408.21 recs processed
255 S DG21=+$P($G(^XTMP(NAMSPC,0,0)),U,9) ;tot 408.21 recs purged
256 S DG21X=+$P($G(^XTMP(NAMSPC,0,0)),U,10) ;tot bad 408.21 "C" purged
257 S BTIME=$P($G(^XTMP(NAMSPC,0,0)),U,11) ;begin time
258 S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,12) ;status
259 S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,13) ;stop time
260 Q
261 ;
262MSG(QUIT) ;print message to user
263 W " was "_STAT_" on "_$$FMTE^XLFDT(STIME)
264 W " in "_$S(TESTMODE:"TEST",1:"LIVE")_" mode "
265 W !," Do you want to Re-Run in "_$S(TESTING:"TEST",1:"LIVE")
266 W " mode?"
267 K DIR
268 S DIR("?",1)=" Entering Y, will delete the XTMP global where the previous cleanup"
269 S DIR("?")=" information was stored and begin a new job, or N to cancel request"
270 S DIR(0)="Y" D ^DIR
271 I 'Y S QUIT=1 Q
272 W !," ARE YOU SURE?"
273 K DIR
274 S DIR("?")="Enter Y to begin a new Job or N to cancel request"
275 S DIR(0)="Y" D ^DIR
276 I 'Y S QUIT=1 Q
277 ;fall thru to re-run mode, kill ^XTMP
278 K ^XTMP(NAMSPC)
279 Q
280 ;
281STOP ; alternate stop method
282 S ^XTMP($$NAMSPC,0,"STOP")=""
283 Q
284NAMSPC() ;
285 Q "DG*5.3*488"
Note: See TracBrowser for help on using the repository browser.