1 | DG488 ;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 | ;
|
---|
6 | TEST ; Entry point for testing this routine, then fall thru.
|
---|
7 | S TESTING=1
|
---|
8 | EN ; 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 | ;
|
---|
30 | TASK ; 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 | ;
|
---|
72 | DG40812(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 | ;
|
---|
105 | DEL40821(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 | ;
|
---|
123 | DG22AIND(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 | ;
|
---|
139 | DG40821(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 | ;
|
---|
169 | DEL21(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 | ;
|
---|
179 | CHK40812(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 | ;
|
---|
193 | DG40822(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 | ;
|
---|
223 | CHKSTAT() ;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 | ;
|
---|
245 | GETLAST ;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 | ;
|
---|
262 | MSG(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 | ;
|
---|
281 | STOP ; alternate stop method
|
---|
282 | S ^XTMP($$NAMSPC,0,"STOP")=""
|
---|
283 | Q
|
---|
284 | NAMSPC() ;
|
---|
285 | Q "DG*5.3*488"
|
---|