SDECDTHCLNUP2 ;ALB/JAS - RECALL REMINDER & SDEC APPT REQUEST REPORT/CLEAN-UP FOR DECEASED PATIENTS ; Mar 20, 2023
;;5.3;SCHEDULING;**843**;AUG 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
RPT ;
;
N HTYP S HTYP="RPT"
D MAIN(HTYP),DEVCLOSE
Q
;
CLNUP ;
;
N HTYP S HTYP="CLN"
D MAIN(HTYP),DEVCLOSE
Q
;
MAIN(HTYP) ;
;
N CLNEDT,DA,DOD,DODLU,DTOUT,DUOUT,ECNT,ENTERDT,FSTDT,I,LSTDT,PCNT,PFLG,POP
N RCNT,RDA,SCNT,SDA,SDDFN,SVSTAT,UPEDT
S (DA,ECNT,PCNT,POP,RCNT,SCNT)=0,FSTDT=9999999.999999,LSTDT=0000000.000000
S (CLNEDT,UPEDT)=3201231 ; The latest date to include for record Cleanup
S ENTERDT=3211231 ; The Date of Death Entered By check date
;
D HEADER(HTYP),DEVOPEN(POP)
Q:POP
;
; Loop through AEXP1 x-ref to only search deceased patient records
;
F S DA=$O(^DPT("AEXP1",DA)) Q:'DA I $D(^DPT("AEXP1",DA)) D
. S SDDFN=0 F S SDDFN=$O(^DPT("AEXP1",DA,SDDFN)) Q:'SDDFN I $D(^DPT(SDDFN,0)) D
. . ;
. . S DOD=$$GET1^DIQ(2,SDDFN,.351,"I") Q:'DOD ; double-check for a populated Date of Death
. . Q:DOD>CLNEDT ; check DOD against default cut-off
. . S DODLU=$$GET1^DIQ(2,SDDFN,.354,"I") Q:'DODLU ; check for populated Date of Death Last Updated
. . I 'DODLU&(DOD>3141231) Q ; if no Date of Death Last Updated, quit if DOD is later than 2015
. . I DODLU&(DODLU>ENTERDT) Q ; check Date of Death Last Updated against default cut-off
. . ;
. . ; Search RECALL REMINDERS file
. . ;
. . S PFLG=0
. . I $D(^SD(403.5,"B",SDDFN)) D
. . . S RDA=0
. . . F S RDA=$O(^SD(403.5,"B",SDDFN,RDA)) Q:RDA="" I $D(^SD(403.5,RDA,0)) D
. . . . I 'PFLG S PFLG=1,PCNT=PCNT+1 I HTYP="RPT" D PDET(SDDFN,DOD)
. . . . I HTYP="RPT" W !," RECALL REMINDER Record IEN: "_RDA
. . . . I HTYP="CLN" S SVSTAT=$$REMOVEREC(RDA,SDDFN) I 'SVSTAT S ECNT=ECNT+1 Q
. . . . I DOD<FSTDT S FSTDT=DOD
. . . . I DOD>LSTDT S LSTDT=DOD
. . . . S RCNT=RCNT+1
. . ;
. . ; Search SDEC APPT REQUEST file
. . ;
. . I $D(^SDEC(409.85,"B",SDDFN)) D
. . . N SVSTAT S SDA=0
. . . F S SDA=$O(^SDEC(409.85,"B",SDDFN,SDA)) Q:SDA="" I $D(^SDEC(409.85,SDA,0)) D
. . . . Q:$$GET1^DIQ(409.85,SDA,23)="CLOSED" ; Make sure CURRENT STATUS of record isn't already Closed
. . . . I 'PFLG S PFLG=1,PCNT=PCNT+1 I HTYP="RPT" D PDET(SDDFN,DOD)
. . . . I HTYP="RPT" W !," SDEC APPT REQUEST Record IEN: "_SDA
. . . . I HTYP="CLN" S SVSTAT=$$UPDATEREQ(SDA) I 'SVSTAT S ECNT=ECNT+1 Q
. . . . I DOD<FSTDT S FSTDT=DOD
. . . . I DOD>LSTDT S LSTDT=DOD
. . . . S SCNT=SCNT+1
;
I HTYP="RPT" D RSUMM(ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT) Q
D CSUMM(ECNT,ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT)
Q
;
REMOVEREC(RDA,RDFN) ; Delete RECALL REMINDER record and update corresponding
; DELETE REASON field in RECALL REMINDER REMOVED file.
N LSTIEN,RET,RRRIEN
S LSTIEN=$O(^SD(403.56,"A"),-1)
;
; Call API that prepares and deletes RECALL REMINDER record
;
D RECDSET^SDEC52A(.RET,RDA)
I '$P(RET,"^",3) Q 0
;
; Locate the new IEN created in the RECALL REMINDER REMOVED file
;
S RRRIEN=$O(^SD(403.56,"B",RDFN,""),-1)
I 'RRRIEN!(RRRIEN'>LSTIEN) Q 0
;
; Update DELETE REASON field #203, Value=3 (DECEASED)
;
N FDA,FDAERR
S FDA(403.56,RRRIEN_",",203)=3
D FILE^DIE(,"FDA","FDAERR")
Q 1
;
UPDATEREQ(REQIEN) ; Update CURRENT STATUS field in SDEC APPT REQUEST file
; CURRENT STATUS - Field #23, Value="C" (CLOSED)
;
N FDA,FDAERR
S FDA(409.85,REQIEN_",",23)="C"
D FILE^DIE(,"FDA","FDAERR")
I $D(FDAERR) Q 0
Q 1
;
;
W !!!,?15,$S(HTYP="RPT":"Report",1:"Clean-up")_" for Scheduling records for deceased patients.",!!
Q
;
PDET(PDDFN,DOD) ; Detail line for Patient
;
W !!!,"PATIENT NAME: "_$$GET1^DIQ(2,PDDFN,.01,"E")
W !,"PATIENT IEN: ",PDDFN,?45,"DATE OF DEATH: "_$P($$FMTE^XLFDT(DOD),"@")
W ! F I=1:1:79 W "-"
Q
;
RSUMM(ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT) ; Report Summary
;
W !! F I=1:1:79 W "="
W !!,"Date of Death on or before: "_$P($$FMTE^XLFDT(UPEDT),"@")
W !,"Date of Death Last Updated on or before: "_$P($$FMTE^XLFDT(ENTERDT),"@")
W !!,"Deceased patients with active records: ",PCNT
I FSTDT<9999999.999999 D
. W !,"Earliest Date of Death found: "_$P($$FMTE^XLFDT(FSTDT),"@")
I LSTDT>0000000.000000 D
. W !,"Latest Date of Death found: "_$P($$FMTE^XLFDT(LSTDT),"@")
W !!,"Total associated RECALL REMINDER records: ",RCNT
W !,"Total associated SDEC APPT REQUEST records: ",SCNT
Q
;
CSUMM(ECNT,ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT) ; Clean-up Summary
;
W !! F I=1:1:79 W "="
W !!,"Date of Death on or before: "_$P($$FMTE^XLFDT(UPEDT),"@")
W !,"Date of Death Last Updated on or before: "_$P($$FMTE^XLFDT(ENTERDT),"@")
W !!,"Deceased patients with records cleaned up: ",PCNT
I FSTDT<9999999.999999 D
. W !,"Earliest Date of Death found: "_$P($$FMTE^XLFDT(FSTDT),"@")
I LSTDT>0000000.000000 D
. W !,"Latest Date of Death found: "_$P($$FMTE^XLFDT(LSTDT),"@")
W !!,"Total associated RECALL REMINDER records that were removed: ",RCNT
W !,"Total associated SDEC APPT REQUEST records that were closed: ",SCNT
W !,"Total unsuccessful updates: ",ECNT
Q
;
DEVOPEN(POP) ;Prompt for device
D ^%ZIS Q:POP
U IO
Q
;
DEVCLOSE ;Close device
;
D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECDTHCLNUP2 5353 printed Sep 23, 2025@20:28:24 Page 2
SDECDTHCLNUP2 ;ALB/JAS - RECALL REMINDER & SDEC APPT REQUEST REPORT/CLEAN-UP FOR DECEASED PATIENTS ; Mar 20, 2023
+1 ;;5.3;SCHEDULING;**843**;AUG 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
RPT ;
+1 ;
+2 NEW HTYP
SET HTYP="RPT"
+3 DO MAIN(HTYP)
DO DEVCLOSE
+4 QUIT
+5 ;
CLNUP ;
+1 ;
+2 NEW HTYP
SET HTYP="CLN"
+3 DO MAIN(HTYP)
DO DEVCLOSE
+4 QUIT
+5 ;
MAIN(HTYP) ;
+1 ;
+2 NEW CLNEDT,DA,DOD,DODLU,DTOUT,DUOUT,ECNT,ENTERDT,FSTDT,I,LSTDT,PCNT,PFLG,POP
+3 NEW RCNT,RDA,SCNT,SDA,SDDFN,SVSTAT,UPEDT
+4 SET (DA,ECNT,PCNT,POP,RCNT,SCNT)=0
SET FSTDT=9999999.999999
SET LSTDT=0000000.000000
+5 ; The latest date to include for record Cleanup
SET (CLNEDT,UPEDT)=3201231
+6 ; The Date of Death Entered By check date
SET ENTERDT=3211231
+7 ;
+8 DO HEADER(HTYP)
DO DEVOPEN(POP)
+9 if POP
QUIT
+10 ;
+11 ; Loop through AEXP1 x-ref to only search deceased patient records
+12 ;
+13 FOR
SET DA=$ORDER(^DPT("AEXP1",DA))
if 'DA
QUIT
IF $DATA(^DPT("AEXP1",DA))
Begin DoDot:1
+14 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^DPT("AEXP1",DA,SDDFN))
if 'SDDFN
QUIT
IF $DATA(^DPT(SDDFN,0))
Begin DoDot:2
+15 ;
+16 ; double-check for a populated Date of Death
SET DOD=$$GET1^DIQ(2,SDDFN,.351,"I")
if 'DOD
QUIT
+17 ; check DOD against default cut-off
if DOD>CLNEDT
QUIT
+18 ; check for populated Date of Death Last Updated
SET DODLU=$$GET1^DIQ(2,SDDFN,.354,"I")
if 'DODLU
QUIT
+19 ; if no Date of Death Last Updated, quit if DOD is later than 2015
IF 'DODLU&(DOD>3141231)
QUIT
+20 ; check Date of Death Last Updated against default cut-off
IF DODLU&(DODLU>ENTERDT)
QUIT
+21 ;
+22 ; Search RECALL REMINDERS file
+23 ;
+24 SET PFLG=0
+25 IF $DATA(^SD(403.5,"B",SDDFN))
Begin DoDot:3
+26 SET RDA=0
+27 FOR
SET RDA=$ORDER(^SD(403.5,"B",SDDFN,RDA))
if RDA=""
QUIT
IF $DATA(^SD(403.5,RDA,0))
Begin DoDot:4
+28 IF 'PFLG
SET PFLG=1
SET PCNT=PCNT+1
IF HTYP="RPT"
DO PDET(SDDFN,DOD)
+29 IF HTYP="RPT"
WRITE !," RECALL REMINDER Record IEN: "_RDA
+30 IF HTYP="CLN"
SET SVSTAT=$$REMOVEREC(RDA,SDDFN)
IF 'SVSTAT
SET ECNT=ECNT+1
QUIT
+31 IF DOD<FSTDT
SET FSTDT=DOD
+32 IF DOD>LSTDT
SET LSTDT=DOD
+33 SET RCNT=RCNT+1
End DoDot:4
End DoDot:3
+34 ;
+35 ; Search SDEC APPT REQUEST file
+36 ;
+37 IF $DATA(^SDEC(409.85,"B",SDDFN))
Begin DoDot:3
+38 NEW SVSTAT
SET SDA=0
+39 FOR
SET SDA=$ORDER(^SDEC(409.85,"B",SDDFN,SDA))
if SDA=""
QUIT
IF $DATA(^SDEC(409.85,SDA,0))
Begin DoDot:4
+40 ; Make sure CURRENT STATUS of record isn't already Closed
if $$GET1^DIQ(409.85,SDA,23)="CLOSED"
QUIT
+41 IF 'PFLG
SET PFLG=1
SET PCNT=PCNT+1
IF HTYP="RPT"
DO PDET(SDDFN,DOD)
+42 IF HTYP="RPT"
WRITE !," SDEC APPT REQUEST Record IEN: "_SDA
+43 IF HTYP="CLN"
SET SVSTAT=$$UPDATEREQ(SDA)
IF 'SVSTAT
SET ECNT=ECNT+1
QUIT
+44 IF DOD<FSTDT
SET FSTDT=DOD
+45 IF DOD>LSTDT
SET LSTDT=DOD
+46 SET SCNT=SCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 ;
+48 IF HTYP="RPT"
DO RSUMM(ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT)
QUIT
+49 DO CSUMM(ECNT,ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT)
+50 QUIT
+51 ;
REMOVEREC(RDA,RDFN) ; Delete RECALL REMINDER record and update corresponding
+1 ; DELETE REASON field in RECALL REMINDER REMOVED file.
+2 NEW LSTIEN,RET,RRRIEN
+3 SET LSTIEN=$ORDER(^SD(403.56,"A"),-1)
+4 ;
+5 ; Call API that prepares and deletes RECALL REMINDER record
+6 ;
+7 DO RECDSET^SDEC52A(.RET,RDA)
+8 IF '$PIECE(RET,"^",3)
QUIT 0
+9 ;
+10 ; Locate the new IEN created in the RECALL REMINDER REMOVED file
+11 ;
+12 SET RRRIEN=$ORDER(^SD(403.56,"B",RDFN,""),-1)
+13 IF 'RRRIEN!(RRRIEN'>LSTIEN)
QUIT 0
+14 ;
+15 ; Update DELETE REASON field #203, Value=3 (DECEASED)
+16 ;
+17 NEW FDA,FDAERR
+18 SET FDA(403.56,RRRIEN_",",203)=3
+19 DO FILE^DIE(,"FDA","FDAERR")
+20 QUIT 1
+21 ;
UPDATEREQ(REQIEN) ; Update CURRENT STATUS field in SDEC APPT REQUEST file
+1 ; CURRENT STATUS - Field #23, Value="C" (CLOSED)
+2 ;
+3 NEW FDA,FDAERR
+4 SET FDA(409.85,REQIEN_",",23)="C"
+5 DO FILE^DIE(,"FDA","FDAERR")
+6 IF $DATA(FDAERR)
QUIT 0
+7 QUIT 1
+8 ;
+1 ;
+2 WRITE !!!,?15,$SELECT(HTYP="RPT":"Report",1:"Clean-up")_" for Scheduling records for deceased patients.",!!
+3 QUIT
+4 ;
PDET(PDDFN,DOD) ; Detail line for Patient
+1 ;
+2 WRITE !!!,"PATIENT NAME: "_$$GET1^DIQ(2,PDDFN,.01,"E")
+3 WRITE !,"PATIENT IEN: ",PDDFN,?45,"DATE OF DEATH: "_$PIECE($$FMTE^XLFDT(DOD),"@")
+4 WRITE !
FOR I=1:1:79
WRITE "-"
+5 QUIT
+6 ;
RSUMM(ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT) ; Report Summary
+1 ;
+2 WRITE !!
FOR I=1:1:79
WRITE "="
+3 WRITE !!,"Date of Death on or before: "_$PIECE($$FMTE^XLFDT(UPEDT),"@")
+4 WRITE !,"Date of Death Last Updated on or before: "_$PIECE($$FMTE^XLFDT(ENTERDT),"@")
+5 WRITE !!,"Deceased patients with active records: ",PCNT
+6 IF FSTDT<9999999.999999
Begin DoDot:1
+7 WRITE !,"Earliest Date of Death found: "_$PIECE($$FMTE^XLFDT(FSTDT),"@")
End DoDot:1
+8 IF LSTDT>0000000.000000
Begin DoDot:1
+9 WRITE !,"Latest Date of Death found: "_$PIECE($$FMTE^XLFDT(LSTDT),"@")
End DoDot:1
+10 WRITE !!,"Total associated RECALL REMINDER records: ",RCNT
+11 WRITE !,"Total associated SDEC APPT REQUEST records: ",SCNT
+12 QUIT
+13 ;
CSUMM(ECNT,ENTERDT,FSTDT,LSTDT,PCNT,RCNT,SCNT,UPEDT) ; Clean-up Summary
+1 ;
+2 WRITE !!
FOR I=1:1:79
WRITE "="
+3 WRITE !!,"Date of Death on or before: "_$PIECE($$FMTE^XLFDT(UPEDT),"@")
+4 WRITE !,"Date of Death Last Updated on or before: "_$PIECE($$FMTE^XLFDT(ENTERDT),"@")
+5 WRITE !!,"Deceased patients with records cleaned up: ",PCNT
+6 IF FSTDT<9999999.999999
Begin DoDot:1
+7 WRITE !,"Earliest Date of Death found: "_$PIECE($$FMTE^XLFDT(FSTDT),"@")
End DoDot:1
+8 IF LSTDT>0000000.000000
Begin DoDot:1
+9 WRITE !,"Latest Date of Death found: "_$PIECE($$FMTE^XLFDT(LSTDT),"@")
End DoDot:1
+10 WRITE !!,"Total associated RECALL REMINDER records that were removed: ",RCNT
+11 WRITE !,"Total associated SDEC APPT REQUEST records that were closed: ",SCNT
+12 WRITE !,"Total unsuccessful updates: ",ECNT
+13 QUIT
+14 ;
DEVOPEN(POP) ;Prompt for device
+1 DO ^%ZIS
if POP
QUIT
+2 USE IO
+3 QUIT
+4 ;
DEVCLOSE ;Close device
+1 ;
+2 DO ^%ZISC
+3 QUIT
