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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1DG53558 ;ALB/GN - DG*5.3*558 CLEANUP FOR DUPE MEANS TEST FILE ; 7/16/04 11:17am
2 ;;5.3;Registration;**558,579**;Aug 13, 1993
3 ;
4 ; Read through the Mean Test file (#408.31) via the "C" xref.
5 ; Search for duplicate & Bad tests and delete them. Duplicates are
6 ; defined as more than one test for the same patient for the same day
7 ; and the same status. All dupes but the primary test will be
8 ; deleted and when no primary test on a given day then the last
9 ; transmission for that day will be kept
10 ;
11 ; Bad tests are defined as those that have a NULL status code in
12 ; the 0 node of file 408.31.
13 ;
14 ; DG*5.3*579 - changes were made to fix a problem when future dated
15 ; tests come in and flip a test from Primary to Non-Primary. This
16 ; should not be done for IVM converted cases. This patch will
17 ; find those IVM tests and flip them back to Priamry and flip the
18 ; future test that caused this back to Non-Primary.
19 Q
20TEST ; Entry point for testing this routine
21 S TESTING=1
22EN ; Entry point for purging Duplicate Means Tests
23 ;
24 N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
25 S CHKPNT=5
26 W !,"Do you want to process a group of "_CHKPNT_" duplicates and stop? "
27 K DIR
28 S DIR("?",1)=" Enter Y to process at least "_CHKPNT_" dupes and stop the utility. This will "
29 S DIR("?",2)=" allow you to verify the cleanup in small steps. Enter N to process the "
30 S DIR("?")=" remainder of the file to completion."
31 S DIR(0)="Y" D ^DIR
32 I $D(DTOUT)!$D(DUOUT) W !,"Cancelled...",! Q
33 ;
34 S:'Y CHKPNT=0 ;do not use check points
35 ;
36 ; setup TM variables and Load
37 S ZTRTN=$S($G(TESTING):"QUET^DG53558",1:"QUE^DG53558")
38 S ZTDESC="Cleanup Duplicates in the Means Test file"
39 S ZTIO=""
40 S ZTSAVE("CHKPNT")=""
41 ;
42 W !!,ZTDESC,!
43 ;check if already running or completed.
44 S QUIT=$$CHKSTAT(0)
45 Q:QUIT
46 D ^%ZTLOAD
47 L -^XTMP($$NAMSPC)
48 I $D(ZTSK) D
49 . W !,"This request queued as Task # ",ZTSK,!
50 Q
51 ;
52POST ;
53 N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT
54 D MES^XPDUTL("")
55 D MES^XPDUTL("=====================================================")
56 D MES^XPDUTL("Queuing Dupe Income Test Purge Utility.....")
57 I $$CHKSTAT(1) D Q
58 . D BMES^XPDUTL("ABORTING Post Install Utility Queuing")
59 . D MES^XPDUTL("=====================================================")
60 S ZTRTN="QUE^DG53558"
61 S ZTDESC="Cleanup Duplicates in the Means Test file"
62 S ZTIO="",ZTDTH=$H
63 S CHKPNT=0,ZTSAVE("CHKPNT")=""
64 D ^%ZTLOAD
65 L -^XTMP($$NAMSPC)
66 D MES^XPDUTL("This request queued as Task # "_ZTSK)
67 D MES^XPDUTL("=====================================================")
68 D MES^XPDUTL("")
69 Q
70 ;
71QUET ; Entry point for taskman (testing mode)
72 S TESTING=1
73QUE ; Entry point for taskman (live mode)
74 N NAMSPC S NAMSPC=$$NAMSPC^DG53558
75 L +^XTMP(NAMSPC):10 I '$T D Q ;quit if can't get a lock
76 . S $P(^XTMP(NAMSPC,0,0),U,5)="NO LOCK GAINED"
77 N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,IVMTOT,IVMPUR,BEGTIME,PURGDT,IVMBAD
78 N DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,DELETED,IVMIEN,PRIM
79 N SRCE,TMPIVM,XX,IVMCV,MAX,IVMIEND,IVMPFL,LINK,LTYP,LTNAM
80 S TESTING=+$G(TESTING)
81 ;
82 ;get last run info if exists
83 S XREC=$G(^XTMP(NAMSPC,0,0))
84 S DFN=$P(XREC,U,1) ;last REC processed
85 S IVMTOT=+$P(XREC,U,2) ;total records processed
86 S IVMPUR=+$P(XREC,U,3) ;total dupe records purged
87 S IVMBAD=+$P(XREC,U,7) ;total bad records purged
88 S IVMPFL=+$P(XREC,U,8) ;total PRIM records fliped
89 S IVMDUPE=IVMPUR
90 ;
91 ;setup XTMP according to stds. & for 60 day expiration
92 D SETUPX^DG53558M(60)
93 ;
94 ;init status field and start date & time if null
95 S $P(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^"
96 S:$P(^XTMP(NAMSPC,0,0),U,4)="" $P(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT
97 ;
98 ;drive through "C" XREF level of MT file
99 S ZTSTOP=0,DELETED=0
100 F QQ=1:1 S DFN=$O(^DGMT(408.31,"C",DFN)) Q:'DFN D Q:ZTSTOP
101 . I $G(CHKPNT)>1,IVMPUR>IVMDUPE,IVMPUR-CHKPNT>IVMDUPE S ZTSTOP=1 Q
102 . K TMP,TMPIVM
103 . S IVMTOT=IVMTOT+1
104 . ;
105 . ;build local TMP and prioritize dupes
106 . S MTIEN=0
107 . F S MTIEN=$O(^DGMT(408.31,"C",DFN,MTIEN)) Q:'MTIEN D
108 . . I '$D(^DGMT(408.31,MTIEN,0)) K ^DGMT(408.31,"C",DFN,MTIEN) Q
109 . . S ICDT=$P(^DGMT(408.31,MTIEN,0),"^",1)
110 . . S MTST=$P(^DGMT(408.31,MTIEN,0),"^",3)
111 . . S PRI=+$G(^DGMT(408.31,MTIEN,"PRIM"))
112 . . S SRCE=+$P(^DGMT(408.31,MTIEN,0),"^",23)
113 . . S MAX=0
114 . . S:$D(^DGMT(408.31,MTIEN,"C")) MAX=$O(^DGMT(408.31,MTIEN,"C",""),-1)
115 . . S IVMCV=0 ;init IVM converted flag to no DG*5.3*579
116 . . F XX=1:1:MAX D Q:IVMCV
117 . . . S:^DGMT(408.31,MTIEN,"C",XX,0)["Z06 MT via Edb" IVMCV=1
118 . . I SRCE=2,IVMCV D ;IVM converted test from EDB
119 . . . S TMPIVM(DFN,ICDT,MTST)=MTIEN,TMPIVM(DFN,ICDT)=MTIEN
120 . . . S PRI=1 ;set as PRIMARY
121 . . ;
122 . . ;test for null MT status & flag as BAD and delete
123 . . I MTST="" D Q
124 . . . S TYPE=$P($G(^DGMT(408.31,MTIEN,0)),"^",19),TYPNAM=""
125 . . . S:TYPE]"" TYPNAM=$G(^DG(408.33,TYPE,0))
126 . . . D DELBAD(MTIEN,DFN,.IVMBAD,.DELETED)
127 . . . Q:'DELETED
128 . . . S ^XTMP(NAMSPC,DFN,ICDT,999999,MTIEN,"BAD")=TYPE
129 . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,MTIEN,"BAD")=TYPNAM
130 . . . S $P(^XTMP(NAMSPC,0,0),U,7)=IVMBAD
131 . . ;
132 . . S COUNT=+$G(TMP(DFN,ICDT,MTST))+1
133 . . S TMP(DFN,ICDT,MTST)=COUNT
134 . . S TMP(DFN,ICDT,MTST,MTIEN)=PRI
135 . . S:PRI TMP(DFN,ICDT,MTST,"P")=MTIEN
136 . ;
137 . ;drive thru TMP and delete all dupes, but last one per day per sts
138 . S ICDT=""
139 . F S ICDT=$O(TMP(DFN,ICDT)) Q:ICDT="" D
140 . . S MTST=""
141 . . ;
142 . . ;if this is the IVM test that is set to not prim, then flip it
143 . . S IVMIEND=$G(TMPIVM(DFN,ICDT)) ;DG*5.3*579
144 . . I IVMIEND D
145 . . . D SETPRIM(IVMIEND,1,.IVMPFL)
146 . . . S LINK=$P($G(^DGMT(408.31,IVMIEND,2)),"^",6)
147 . . . D:LINK SETPRIM(LINK,1,.IVMPFL) ;set any linked test to PRIM
148 . . ;
149 . . F S MTST=$O(TMP(DFN,ICDT,MTST)) Q:MTST="" D
150 . . . ;keep at least one test per day per status, even if not PRIM
151 . . . D:'$D(TMP(DFN,ICDT,MTST,"P")) SETPRI(.TMP)
152 . . . ; drive thru ien's and del dupes
153 . . . S MTIEN=0
154 . . . F S MTIEN=$O(TMP(DFN,ICDT,MTST,MTIEN)) Q:'MTIEN D
155 . . . . S PRIM=$G(^DGMT(408.31,MTIEN,"PRIM"))
156 . . . . S LINK=$P($G(^DGMT(408.31,MTIEN,2)),"^",6)
157 . . . . ;
158 . . . . ;if this ien is primary & it is not the IVM test or Linked to
159 . . . . ;the IVM test, then it should be flipped back to Not Primary
160 . . . . I IVMIEND,PRIM,MTIEN'=IVMIEND,LINK'=IVMIEND D ;DG*5.3*579
161 . . . . . D SETPRIM(MTIEN,0,.IVMPFL)
162 . . . . . S TMP(DFN,ICDT,MTST,MTIEN)=0
163 . . . . ;
164 . . . . I TMP(DFN,ICDT,MTST,"P")'=MTIEN D
165 . . . . . S TYPE=$P($G(^DGMT(408.31,MTIEN,0)),"^",19),TYPNAM=""
166 . . . . . S:TYPE]"" TYPNAM=$G(^DG(408.33,TYPE,0))
167 . . . . . D DELMT^DG53558M(MTIEN,DFN,.IVMPUR,.DELETED,.LINK)
168 . . . . . Q:'DELETED
169 . . . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,MTIEN)=TYPNAM
170 . . . . . I LINK,'$D(^DGMT(408.31,LINK,0)) S LINK=0
171 . . . . . Q:'LINK
172 . . . . . S LTYP=$P($G(^DGMT(408.31,LINK,0)),"^",19),LTNAM=""
173 . . . . . S:LTYP LTNAM=$G(^DG(408.33,LTYP,0))
174 . . . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,LINK)=LTNAM
175 . . . . M ^XTMP(NAMSPC,DFN,ICDT,MTST)=TMP(DFN,ICDT,MTST)
176 . ;
177 . ;update last processed info
178 . S $P(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPUR
179 . S $P(^XTMP(NAMSPC,0,0),U,7,8)=IVMBAD_U_IVMPFL
180 . ;
181 . ;check for stop request after every 100 processed DFN recs
182 . I QQ#100=0 D
183 . . S:$$S^%ZTLOAD ZTSTOP=1
184 . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
185 ;
186 ;set status and mail stats
187 I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
188 E S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
189 D MAIL^DG53558M
190 K TESTING
191 L -^XTMP($$NAMSPC)
192 Q
193 ;
194 ;DG*5.3*579
195SETPRIM(DA,PR,IVMP) ; set an Income Test (in #408.31) to either Prim or Not
196 Q:'$D(DA)!'$D(PR)
197 N DR,DIE,DGDATA,DGPRI
198 S DGPRI=$G(^DGMT(408.31,DA,"PRIM"))
199 Q:DGPRI=PR ;quit if already at that sts
200 S IVMP=$G(IVMP)+1
201 S DGDATA="FLIPPED TO "_$S(PR=0:"NOT PRIMARY",1:"PRIMARY")
202 S:$D(NAMSPC) ^XTMP(NAMSPC_".DET",DFN,ICDT,DA)=DGDATA
203 S DR="2////"_PR,DIE="^DGMT(408.31,"
204 D:'$G(TESTING) ^DIE
205 Q
206 ;
207SETPRI(TMP) ;indicate like a primary (in TMP) to avoid it from being deleted
208 N IEN
209 S IEN=$O(TMP(DFN,ICDT,MTST,""),-1)
210 S TMP(DFN,ICDT,MTST,IEN)=1
211 S TMP(DFN,ICDT,MTST,"P")=IEN
212 Q
213 ;
214DELBAD(IEN,DFN,PUR,DELETED) ; Kill Bad test
215 S DELETED=0
216 Q:'$G(IEN)
217 S TESTING=+$G(TESTING,1),DFN=$G(DFN)
218 I 'TESTING S DELETED=$$DEL^DG53558M(IEN,.LINK,DFN)
219 S:TESTING DELETED=1
220 Q:'DELETED
221 S IVMBAD=IVMBAD+1
222 I '$D(ZTQUEUED) W !,"Deleting BAD IEN in 408.31 > ",IEN," for DFN > ",DFN
223 Q
224 ;
225CHKSTAT(POST) ;check if job is running, stopped, or completed
226 N Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC
227 S QUIT=0
228 S NAMSPC=$$NAMSPC
229 L +^XTMP(NAMSPC):1
230 I '$T D BMES^XPDUTL("*** ALREADY RUNNING ***") Q 1
231 ;
232 ; get job status
233 S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5)
234 S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6)
235 ;
236 I POST D KILIT Q 0 ;DG*5.3*579
237 ;
238 ;if job Completed and run from menu opt, ask to Re-Run
239 I STAT="COMPLETED" D
240 . W " was Completed on "_$$FMTE^XLFDT(STIME)
241 . W !," Do you want to Re-Run again?"
242 . K DIR
243 . S DIR("?",1)=" Entering Y, will delete the XTMP global where the previous cleanup"
244 . S DIR("?")=" information was stored and begin a new job, or N to cancel request"
245 . S DIR(0)="Y" D ^DIR
246 . I 'Y S QUIT=1 Q
247 . W !," ARE YOU SURE?"
248 . K DIR
249 . S DIR("?")="Enter Y to begin a new Job or N to cancel request"
250 . S DIR(0)="Y" D ^DIR
251 . I 'Y S QUIT=1 Q
252 . ;fall thru to re-run mode, kill ^XTMPs
253 . D KILIT
254 Q QUIT
255 ;
256KILIT ; kill Xtmp work files for a re-run
257 S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53558
258 K ^XTMP(NAMSPC),^XTMP(NAMSPC_".DET")
259 Q
260 ;
261STOP ; alternate stop method
262 S ^XTMP($$NAMSPC,0,"STOP")=""
263 Q
264 ;
265NAMSPC() ; Return a consistent name space variable
266 Q "DG53558"
Note: See TracBrowser for help on using the repository browser.