DG714 ;ALB/GAH - Deceased Patient Means Test Cleanup ; 18-SEP-2006 15:41
;;5.3;Registration;**714**;14-AUG-2006;Build 5
;
; This program will loop through all veterans on the system that
; have means tests. For those people that are deceased, their last
; means test will be deleted if it has a status of REQUIRED.
;
; ^XTMP("DG714",0,0)=DELRECS^DFNLST^STATUS^STARTTM^ENDTIME^TOTRECS
; where DELRECS = Number of patients that had means tests deleted
; DFNLST = Last record number examined
; STATUS = RUNNING - Job is still processing
; COMPLETED - Job processed all records
; STOPPED - Job was stopped before completion
; STARTTM = Date/Time when job was started in FM format
; ENDTIME = Date/Time when job stopped or completed in FM format
; TOTRECS = Total number of record examined
;
; ^XTMP("DG714",1,"TASK")=ZTSK
; where ZTSK = Taskman task number
;
; ^XTMP("DG714",1,"STOP")=ZTSTOP
; where ZTSTOP = 1 to stop the job
;
; ^XTMP("DG714","TEST")=""
; This node is set to send mail to a test account during testing
; It will not be set in production
;
; Must be run from line tag
Q
;
START ;Start process
N NAMSPC,TASK,U
S U="^"
S NAMSPC=$$NAMSPC
S TASK=$P($G(^XTMP(NAMSPC,1,"TASK")),U,3)
Q:TASK&$$ACTIVE(TASK) ; Quit if already running
D QUEUE($$QTIME)
Q
QUEUE(ZTDTH) ; Queue the process
N NAMSPC,ZTRTN,ZTDESC,ZTIO,ZTSK
S NAMSPC=$$NAMSPC
S ZTRTN="QUE^"_NAMSPC
S ZTDESC=NAMSPC_" - Remove REQUIRED MT for deceased patients"
S ZTIO=""
D ^%ZTLOAD
K ^XTMP(NAMSPC,1,"TASK")
I '$D(ZTSK) S ^XTMP(NAMSPC,1,"TASK")="Unable to queue post-install process."
I $D(ZTSK) S ^XTMP(NAMSPC,1,"TASK")=$G(ZTSK)
D HOME^%ZIS
Q
QTIME() ; Get the run time for queuing
N %,%H,%I,X
D NOW^%DTC
Q $P(%,".")_"."_$E($P(%,".",2),1,4)
;
TEST(START,END,PROCESS) ;Entry point for testing
; There is a range given so no need for the old data in ^XTMP
K ^XTMP($$NAMSPC,0)
S START=+START
; START is the first record to be processed so prime it for $O
I START'=0 S START=$O(^DGMT(408.31,"AID",1,START),-1)
I END'="" S END=$O(^DGMT(408.31,"AID",1,END))
S TESTING=1
D QUE
Q
QUE ;
N ZTSTOP,X,U,NAMSPC,COMPLETE
S U="^"
S NAMSPC=$$NAMSPC
I '$D(TESTING) N TESTING S TESTING=0
S X=$$SETUPX(90)
S X=$G(^XTMP(NAMSPC,0,0))
S $P(X,U,3)="RUNNING"
S $P(X,U,4)=$$NOW^XLFDT
S ^XTMP(NAMSPC,0,0)=X
;
S ZTSTOP=$$CLEAN(TESTING)
S X=$G(^XTMP(NAMSPC,0,0))
S $P(X,U,3)=$S(ZTSTOP:"STOPPED",1:"COMPLETED")
S $P(X,U,5)=$$NOW^XLFDT
S ^XTMP(NAMSPC,0,0)=X
D MAIL($P(X,U,4),$P(X,U,5),$P(X,U),$P(X,U,6),'ZTSTOP)
K TESTING,^XTMP(NAMSPC,1)
L -^XTMP(NAMSPC)
Q
SETUPX(EXPDAYS) ;
; requires EXPDAYS - number of days to keep XTMP around
N BEGTIME,PURGDT,NAMSPC,U
S U="^"
S NAMSPC=$$NAMSPC
S BEGTIME=$$NOW^XLFDT()
S PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAYS)
S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
S $P(^XTMP(NAMSPC,0),U,3)="MEANS TEST DATE OF DEATH CLEANUP"
Q 1
STOP() ;returns stop flag
N ZTSTOP,U,X,NAMSPC
S U="^"
S NAMSPC=$$NAMSPC
S ZTSTOP=0
; Check to see if the job is set to stop either manually
; or through Taskman
I $$S^%ZTLOAD!$G(^XTMP(NAMSPC,1,"STOP")) D
. K ^XTMP(NAMSPC,1,"STOP")
. S ZTSTOP=1
Q ZTSTOP
ACTIVE(ZTSK) ;check if job is running, stopped, or complete
N NAMSPC,STAT,Y
S NAMSPC=$$NAMSPC
S ZTSK=+$G(^XTMP(NAMSPC,1,"TASK"))
D STAT^%ZTLOAD
S Y=ZTSK(1)
I Y=0 S STAT=-1
I ",1,2,4,"[(","_Y_",") S STAT=1
I ",3,5,"[(","_Y_",") S STAT=0
; If the job is not active but the status is running, change status to
; STOPPED
I $P($G(^XTMP(NAMSPC,0,0)),U,3)="RUNNING",STAT'>0 S $P(^XTMP(NAMSPC,0,0),U,3)="STOPPED"
Q STAT
;
NAMSPC() ;
Q $T(+0)
CLEAN(TESTING) ; Loop through veterans to compare data
N CRF,DATA,DFN,DGMTI,NAMSPC,DELRECS,HIT,REC11,REC12,REC132,STARTTM,STATUS,TOTRECS,U,ZTSTOP
S NAMSPC=$$NAMSPC
S U="^"
S (DELRECS,ZTSTOP)=0
S STARTTM=$$NOW^XLFDT
S DATA=^XTMP(NAMSPC,0,0)
I 'TESTING S END="",DFN=0
I TESTING S DFN=START ;If testing, get range
N STOP
S STOP=0
K ^XTMP(NAMSPC,"TEST","AUDIT")
;
; Loop through the means test cross reference
F TOTRECS=0:1 S DFN=$O(^DGMT(408.31,"AID",1,DFN)) D Q:ZTSTOP!STOP
. I DFN=END!(DFN'?1.N.1(1"."1.N)) S STOP=1 Q
. ; Keep track of the last DFN processes
. S $P(^XTMP(NAMSPC,0,0),U,2)=DFN
. ; Check that there is a date of death and that the last means test
. ; has a status of REQUIRED
. S $P(^XTMP(NAMSPC,0,0),U,2)=DFN
. S HIT=0
. F Q:'$$OK2DEL^DGMTDELS(DFN,.DGMTI) D
. . S HIT=1
. . ; Save the audit info if testing
. . I TESTING S ^XTMP(NAMSPC,"TEST","AUDIT",DFN)=DGMTI
. . ; Delete the means test
. . D:'TESTING!(TESTING&$G(PROCESS)) DELMT^DGMTDELS(DGMTI)
. ; Check to see if the job has been signalled to stop
. I TOTRECS,TOTRECS#1000=0 S ZTSTOP=$$STOP
. S:HIT DELRECS=DELRECS+1 ;increment new record counter if means test deleted
;
I TESTING S ^XTMP(NAMSPC,"TEST","TOT")="PROCESSED:"_TOTRECS_" DELETED:"_DELRECS
; Do some recordkeeping
S DATA=^XTMP(NAMSPC,0,0)
S $P(DATA,U,1)=DELRECS
S $P(DATA,U,4)=STARTTM
S $P(DATA,U,6)=TOTRECS
S ^XTMP(NAMSPC,0,0)=DATA
Q ZTSTOP
MAIL(STARTTM,ENDTIME,DELRECS,TOTRECS,COMPLETE) ; Send mail message
N XMDUZ,XMY,XMSUB,XMTEXT
S NAMSPC=$$NAMSPC
S U="^"
; Set FROM duz
S XMDUZ=.5
; Send completion message to developer
S XMY(DUZ)=""
S XMSUB="DG MEANS TEST DATE OF DEATH CLEANUP"
I COMPLETE D
. S ^TMP(NAMSPC,$J,"MSG",0)=6
. S ^TMP(NAMSPC,$J,"MSG",1)=" Means Test Date of Death Cleanup"
. S ^TMP(NAMSPC,$J,"MSG",2)=""
. S ^TMP(NAMSPC,$J,"MSG",3)=" Started at: "_$TR($$FMTE^XLFDT(STARTTM,2),"@"," ")
. S ^TMP(NAMSPC,$J,"MSG",4)=" Completed at: "_$TR($$FMTE^XLFDT(ENDTIME,2),"@"," ")
. S ^TMP(NAMSPC,$J,"MSG",5)="Records Examined: "_TOTRECS
. S ^TMP(NAMSPC,$J,"MSG",6)=" Records Deleted: "_DELRECS
. S XMTEXT="^TMP(NAMSPC,$J,""MSG"","
I 'COMPLETE D
. S ^TMP(NAMSPC,$J,"MSG",0)=8
. S ^TMP(NAMSPC,$J,"MSG",1)=" Means Test Date of Death Cleanup"
. S ^TMP(NAMSPC,$J,"MSG",2)=" ***Processing not complete***"
. S ^TMP(NAMSPC,$J,"MSG",3)=""
. S ^TMP(NAMSPC,$J,"MSG",4)=" Started at: "_$TR($$FMTE^XLFDT(STARTTM,2),"@"," ")
. S ^TMP(NAMSPC,$J,"MSG",5)=" Stopped at: "_$TR($$FMTE^XLFDT(ENDTIME,2),"@"," ")
. S ^TMP(NAMSPC,$J,"MSG",6)=" Records Examined: "_TOTRECS
. S ^TMP(NAMSPC,$J,"MSG",7)=" Records Deleted: "_DELRECS
. S ^TMP(NAMSPC,$J,"MSG",8)="Last Record Processed: "_$P($G(^XTMP(NAMSPC,0,0)),U,2)
. S XMTEXT="^TMP(NAMSPC,$J,""MSG"","
D ^XMD
K ^TMP(NAMSPC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG714 6746 printed Sep 23, 2025@20:16:32 Page 2
DG714 ;ALB/GAH - Deceased Patient Means Test Cleanup ; 18-SEP-2006 15:41
+1 ;;5.3;Registration;**714**;14-AUG-2006;Build 5
+2 ;
+3 ; This program will loop through all veterans on the system that
+4 ; have means tests. For those people that are deceased, their last
+5 ; means test will be deleted if it has a status of REQUIRED.
+6 ;
+7 ; ^XTMP("DG714",0,0)=DELRECS^DFNLST^STATUS^STARTTM^ENDTIME^TOTRECS
+8 ; where DELRECS = Number of patients that had means tests deleted
+9 ; DFNLST = Last record number examined
+10 ; STATUS = RUNNING - Job is still processing
+11 ; COMPLETED - Job processed all records
+12 ; STOPPED - Job was stopped before completion
+13 ; STARTTM = Date/Time when job was started in FM format
+14 ; ENDTIME = Date/Time when job stopped or completed in FM format
+15 ; TOTRECS = Total number of record examined
+16 ;
+17 ; ^XTMP("DG714",1,"TASK")=ZTSK
+18 ; where ZTSK = Taskman task number
+19 ;
+20 ; ^XTMP("DG714",1,"STOP")=ZTSTOP
+21 ; where ZTSTOP = 1 to stop the job
+22 ;
+23 ; ^XTMP("DG714","TEST")=""
+24 ; This node is set to send mail to a test account during testing
+25 ; It will not be set in production
+26 ;
+27 ; Must be run from line tag
+28 QUIT
+29 ;
START ;Start process
+1 NEW NAMSPC,TASK,U
+2 SET U="^"
+3 SET NAMSPC=$$NAMSPC
+4 SET TASK=$PIECE($GET(^XTMP(NAMSPC,1,"TASK")),U,3)
+5 ; Quit if already running
if TASK&$$ACTIVE(TASK)
QUIT
+6 DO QUEUE($$QTIME)
+7 QUIT
QUEUE(ZTDTH) ; Queue the process
+1 NEW NAMSPC,ZTRTN,ZTDESC,ZTIO,ZTSK
+2 SET NAMSPC=$$NAMSPC
+3 SET ZTRTN="QUE^"_NAMSPC
+4 SET ZTDESC=NAMSPC_" - Remove REQUIRED MT for deceased patients"
+5 SET ZTIO=""
+6 DO ^%ZTLOAD
+7 KILL ^XTMP(NAMSPC,1,"TASK")
+8 IF '$DATA(ZTSK)
SET ^XTMP(NAMSPC,1,"TASK")="Unable to queue post-install process."
+9 IF $DATA(ZTSK)
SET ^XTMP(NAMSPC,1,"TASK")=$GET(ZTSK)
+10 DO HOME^%ZIS
+11 QUIT
QTIME() ; Get the run time for queuing
+1 NEW %,%H,%I,X
+2 DO NOW^%DTC
+3 QUIT $PIECE(%,".")_"."_$EXTRACT($PIECE(%,".",2),1,4)
+4 ;
TEST(START,END,PROCESS) ;Entry point for testing
+1 ; There is a range given so no need for the old data in ^XTMP
+2 KILL ^XTMP($$NAMSPC,0)
+3 SET START=+START
+4 ; START is the first record to be processed so prime it for $O
+5 IF START'=0
SET START=$ORDER(^DGMT(408.31,"AID",1,START),-1)
+6 IF END'=""
SET END=$ORDER(^DGMT(408.31,"AID",1,END))
+7 SET TESTING=1
+8 DO QUE
+9 QUIT
QUE ;
+1 NEW ZTSTOP,X,U,NAMSPC,COMPLETE
+2 SET U="^"
+3 SET NAMSPC=$$NAMSPC
+4 IF '$DATA(TESTING)
NEW TESTING
SET TESTING=0
+5 SET X=$$SETUPX(90)
+6 SET X=$GET(^XTMP(NAMSPC,0,0))
+7 SET $PIECE(X,U,3)="RUNNING"
+8 SET $PIECE(X,U,4)=$$NOW^XLFDT
+9 SET ^XTMP(NAMSPC,0,0)=X
+10 ;
+11 SET ZTSTOP=$$CLEAN(TESTING)
+12 SET X=$GET(^XTMP(NAMSPC,0,0))
+13 SET $PIECE(X,U,3)=$SELECT(ZTSTOP:"STOPPED",1:"COMPLETED")
+14 SET $PIECE(X,U,5)=$$NOW^XLFDT
+15 SET ^XTMP(NAMSPC,0,0)=X
+16 DO MAIL($PIECE(X,U,4),$PIECE(X,U,5),$PIECE(X,U),$PIECE(X,U,6),'ZTSTOP)
+17 KILL TESTING,^XTMP(NAMSPC,1)
+18 LOCK -^XTMP(NAMSPC)
+19 QUIT
SETUPX(EXPDAYS) ;
+1 ; requires EXPDAYS - number of days to keep XTMP around
+2 NEW BEGTIME,PURGDT,NAMSPC,U
+3 SET U="^"
+4 SET NAMSPC=$$NAMSPC
+5 SET BEGTIME=$$NOW^XLFDT()
+6 SET PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAYS)
+7 SET ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME
+8 SET $PIECE(^XTMP(NAMSPC,0),U,3)="MEANS TEST DATE OF DEATH CLEANUP"
+9 QUIT 1
STOP() ;returns stop flag
+1 NEW ZTSTOP,U,X,NAMSPC
+2 SET U="^"
+3 SET NAMSPC=$$NAMSPC
+4 SET ZTSTOP=0
+5 ; Check to see if the job is set to stop either manually
+6 ; or through Taskman
+7 IF $$S^%ZTLOAD!$G(^XTMP(NAMSPC,1,"STOP"))
Begin DoDot:1
+8 KILL ^XTMP(NAMSPC,1,"STOP")
+9 SET ZTSTOP=1
End DoDot:1
+10 QUIT ZTSTOP
ACTIVE(ZTSK) ;check if job is running, stopped, or complete
+1 NEW NAMSPC,STAT,Y
+2 SET NAMSPC=$$NAMSPC
+3 SET ZTSK=+$GET(^XTMP(NAMSPC,1,"TASK"))
+4 DO STAT^%ZTLOAD
+5 SET Y=ZTSK(1)
+6 IF Y=0
SET STAT=-1
+7 IF ",1,2,4,"[(","_Y_",")
SET STAT=1
+8 IF ",3,5,"[(","_Y_",")
SET STAT=0
+9 ; If the job is not active but the status is running, change status to
+10 ; STOPPED
+11 IF $PIECE($GET(^XTMP(NAMSPC,0,0)),U,3)="RUNNING"
IF STAT'>0
SET $PIECE(^XTMP(NAMSPC,0,0),U,3)="STOPPED"
+12 QUIT STAT
+13 ;
NAMSPC() ;
+1 QUIT $TEXT(+0)
CLEAN(TESTING) ; Loop through veterans to compare data
+1 NEW CRF,DATA,DFN,DGMTI,NAMSPC,DELRECS,HIT,REC11,REC12,REC132,STARTTM,STATUS,TOTRECS,U,ZTSTOP
+2 SET NAMSPC=$$NAMSPC
+3 SET U="^"
+4 SET (DELRECS,ZTSTOP)=0
+5 SET STARTTM=$$NOW^XLFDT
+6 SET DATA=^XTMP(NAMSPC,0,0)
+7 IF 'TESTING
SET END=""
SET DFN=0
+8 ;If testing, get range
IF TESTING
SET DFN=START
+9 NEW STOP
+10 SET STOP=0
+11 KILL ^XTMP(NAMSPC,"TEST","AUDIT")
+12 ;
+13 ; Loop through the means test cross reference
+14 FOR TOTRECS=0:1
SET DFN=$ORDER(^DGMT(408.31,"AID",1,DFN))
Begin DoDot:1
+15 IF DFN=END!(DFN'?1.N.1(1"."1.N))
SET STOP=1
QUIT
+16 ; Keep track of the last DFN processes
+17 SET $PIECE(^XTMP(NAMSPC,0,0),U,2)=DFN
+18 ; Check that there is a date of death and that the last means test
+19 ; has a status of REQUIRED
+20 SET $PIECE(^XTMP(NAMSPC,0,0),U,2)=DFN
+21 SET HIT=0
+22 FOR
if '$$OK2DEL^DGMTDELS(DFN,.DGMTI)
QUIT
Begin DoDot:2
+23 SET HIT=1
+24 ; Save the audit info if testing
+25 IF TESTING
SET ^XTMP(NAMSPC,"TEST","AUDIT",DFN)=DGMTI
+26 ; Delete the means test
+27 if 'TESTING!(TESTING&$GET(PROCESS))
DO DELMT^DGMTDELS(DGMTI)
End DoDot:2
+28 ; Check to see if the job has been signalled to stop
+29 IF TOTRECS
IF TOTRECS#1000=0
SET ZTSTOP=$$STOP
+30 ;increment new record counter if means test deleted
if HIT
SET DELRECS=DELRECS+1
End DoDot:1
if ZTSTOP!STOP
QUIT
+31 ;
+32 IF TESTING
SET ^XTMP(NAMSPC,"TEST","TOT")="PROCESSED:"_TOTRECS_" DELETED:"_DELRECS
+33 ; Do some recordkeeping
+34 SET DATA=^XTMP(NAMSPC,0,0)
+35 SET $PIECE(DATA,U,1)=DELRECS
+36 SET $PIECE(DATA,U,4)=STARTTM
+37 SET $PIECE(DATA,U,6)=TOTRECS
+38 SET ^XTMP(NAMSPC,0,0)=DATA
+39 QUIT ZTSTOP
MAIL(STARTTM,ENDTIME,DELRECS,TOTRECS,COMPLETE) ; Send mail message
+1 NEW XMDUZ,XMY,XMSUB,XMTEXT
+2 SET NAMSPC=$$NAMSPC
+3 SET U="^"
+4 ; Set FROM duz
+5 SET XMDUZ=.5
+6 ; Send completion message to developer
+7 SET XMY(DUZ)=""
+8 SET XMSUB="DG MEANS TEST DATE OF DEATH CLEANUP"
+9 IF COMPLETE
Begin DoDot:1
+10 SET ^TMP(NAMSPC,$JOB,"MSG",0)=6
+11 SET ^TMP(NAMSPC,$JOB,"MSG",1)=" Means Test Date of Death Cleanup"
+12 SET ^TMP(NAMSPC,$JOB,"MSG",2)=""
+13 SET ^TMP(NAMSPC,$JOB,"MSG",3)=" Started at: "_$TRANSLATE($$FMTE^XLFDT(STARTTM,2),"@"," ")
+14 SET ^TMP(NAMSPC,$JOB,"MSG",4)=" Completed at: "_$TRANSLATE($$FMTE^XLFDT(ENDTIME,2),"@"," ")
+15 SET ^TMP(NAMSPC,$JOB,"MSG",5)="Records Examined: "_TOTRECS
+16 SET ^TMP(NAMSPC,$JOB,"MSG",6)=" Records Deleted: "_DELRECS
+17 SET XMTEXT="^TMP(NAMSPC,$J,""MSG"","
End DoDot:1
+18 IF 'COMPLETE
Begin DoDot:1
+19 SET ^TMP(NAMSPC,$JOB,"MSG",0)=8
+20 SET ^TMP(NAMSPC,$JOB,"MSG",1)=" Means Test Date of Death Cleanup"
+21 SET ^TMP(NAMSPC,$JOB,"MSG",2)=" ***Processing not complete***"
+22 SET ^TMP(NAMSPC,$JOB,"MSG",3)=""
+23 SET ^TMP(NAMSPC,$JOB,"MSG",4)=" Started at: "_$TRANSLATE($$FMTE^XLFDT(STARTTM,2),"@"," ")
+24 SET ^TMP(NAMSPC,$JOB,"MSG",5)=" Stopped at: "_$TRANSLATE($$FMTE^XLFDT(ENDTIME,2),"@"," ")
+25 SET ^TMP(NAMSPC,$JOB,"MSG",6)=" Records Examined: "_TOTRECS
+26 SET ^TMP(NAMSPC,$JOB,"MSG",7)=" Records Deleted: "_DELRECS
+27 SET ^TMP(NAMSPC,$JOB,"MSG",8)="Last Record Processed: "_$PIECE($GET(^XTMP(NAMSPC,0,0)),U,2)
+28 SET XMTEXT="^TMP(NAMSPC,$J,""MSG"","
End DoDot:1
+29 DO ^XMD
+30 KILL ^TMP(NAMSPC)
+31 QUIT
