SDES846PENC ;ALB/BWF - SD*5.3*846 Post Init Routine ; June 15, 2023
;;5.3;SCHEDULING;**846**;AUG 13, 1993;Build 12
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
TASK ;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*846 Post-Install to remove orphaned encounters for")
D MES^XPDUTL(" appointments that were cancelled by VAOS.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*846 Post Install Routine - Encounter Cleanup"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="FIXENC^SDES846PENC",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
FIXENC ;
N DFN,APPTDTTM,ENCOUNTER,CLINIC,IEN44,ENCFOUND,TOTCNT,CANRES,ENCLINKED,APPTIEN,RESOURCE,ENCLINKED
N CANREASON,APPTCLIN,ENCCLIN,TOTAPPTS,SDESOITEASTOT,CANBY,CANDTTM,ORPHANENC,APPTENC,APPTCAN
K ^XTMP("SDES846PENC")
S ^XTMP("SDES846PENC",0)=$$FMADD^XLFDT(DT,30)_"^"_DT_"^SD*5.3*846 Post Install Orphaned Encounter Data report"
S (TOTCNT,TOTAPPTS,SDESOITEASTOT)=0
S TOTCNT=TOTCNT+1 S ^XTMP("SDES846PENC",TOTCNT)="APPT DATE/TIME^APPT IEN^PATIENT IEN^ENCOUNTER IEN^CANCELLED BY^UPDATE STATUS"
S CANDTTM=3230509.99
F S CANDTTM=$O(^SDEC(409.84,"AD",CANDTTM)) Q:'CANDTTM D
.S APPTIEN=0 F S APPTIEN=$O(^SDEC(409.84,"AD",CANDTTM,APPTIEN)) Q:'APPTIEN D
..S APPTDTTM=$$GET1^DIQ(409.84,APPTIEN,.01,"I")
..S DFN=$$GET1^DIQ(409.84,APPTIEN,.05,"I")
..S CANBY=$$GET1^DIQ(409.84,APPTIEN,.121,"E")
..; only process encounters for appointments that have been CANCELLED by SDESOITEAS,SRV
..Q:CANBY'="SDESOITEAS,SRV"
..S RESOURCE=$$GET1^DIQ(409.84,APPTIEN,.07,"I") Q:'RESOURCE
..S CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I") Q:'CLINIC
..S TOTAPPTS=TOTAPPTS+1
..S (ENCLINKED,ENCFOUND)=0
..S ENCOUNTER=0 F S ENCOUNTER=$O(^SCE("C",DFN,ENCOUNTER)) Q:'ENCOUNTER!(ENCFOUND) D
...; must match date/time
...I $$GET1^DIQ(409.68,ENCOUNTER,.01,"I")'=APPTDTTM Q
...; encounter clinic must match the appointment clinic
...S ENCCLIN=$$GET1^DIQ(409.68,ENCOUNTER,.04,"I")
...I CLINIC'=ENCCLIN Q
...S APPTENC=$$GET1^DIQ(2.98,APPTDTTM_","_DFN_",",21,"I")
...S APPTCAN=$$GET1^DIQ(2.98,APPTDTTM_","_DFN_",",15,"I")
...; if the encounter is still on the appointment and this is not the correct encounter, quit
...I APPTENC'="",APPTENC'=ENCOUNTER Q
...; if the patient appointment is linked to the encounter and the appointment is not cancelled, quit
...I APPTENC'="",APPTENC=ENCOUNTER,APPTCAN="" Q
...; if there is an encounter on the appointment, it is not this encounter and the appointment is cancelled, set ENCLINKED/ENCFOUND and quit
...I APPTENC'="",APPTENC=ENCOUNTER,APPTCAN'="" S ENCFOUND=ENCOUNTER,ENCLINKED=1 Q
...; this means if the appointment is linked to the encounter and the appointment IS cancelled, we want to close this encounter
...S ENCFOUND=ENCOUNTER
..; if there is no encounter found for this cancelled or no-show appointment, quit
..Q:'ENCFOUND
..S TOTCNT=TOTCNT+1
..; get the appointment from file 44, if it cannot be found log it.
..S IEN44=$$SCIEN(DFN,CLINIC,APPTDTTM)
..I 'IEN44 D Q
...S ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_"0;Could not locate clinic appointment in the HOSPITAL LOCATION file (#44)."
...M ^XTMP("SDES846PENC",TOTCNT)=^SCE(ENCFOUND)
..; if checked-in?? - do we cancel the checkin and proceed to clean up, or report that this entry needs to be handled manually?
..I $$CI^SDECU2(DFN,CLINIC,APPTDTTM,IEN44) D
...D CANCHECKIN^SDESCANCHECKIN(.CANRES,APPTIEN)
..; check again before updating the record - if we could not cancel the check-in log it and quit
..I $$CI^SDECU2(DFN,CLINIC,APPTDTTM,IEN44) D Q
...S ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_"0;Could not cancel Check-in. Encounter not updated."
..I ENCLINKED S FDA(2.98,APPTDTTM_","_DFN_",",21)="@" D FILE^DIE(,"FDA") K FDA
..S ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_1
..S SDESOITEASTOT=$G(SDESOITEASTOT)+1
..D EN^SDCODEL(ENCFOUND,2,"","CANCEL") ;remove OUTPATIENT ENCOUNTER link
S ORPHANENC=$G(TOTCNT)
S TOTCNT=TOTCNT+1
S $P(^XTMP("SDES846PENC",TOTCNT),"-",80)=""
S TOTCNT=TOTCNT+1
S ^XTMP("SDES846PENC",TOTCNT)="TOTAL ORPHANED ENCOUNTERS: "_ORPHANENC
S TOTCNT=TOTCNT+1
S ^XTMP("SDES846PENC",TOTCNT)="TOTAL APPOINTMENTS SEARCHED: "_TOTAPPTS
S TOTCNT=TOTCNT+1
S ^XTMP("SDES846PENC",TOTCNT)="TOTAL ORPHANED ENCOUNTERS REMOVED: "_SDESOITEASTOT
D MAIL
Q
SCIEN(PAT,CLINIC,DATE) ;returns ien for appt in ^SC
N X,IEN
S X=0 F S X=$O(^SC(CLINIC,"S",DATE,1,X)) Q:'X Q:$G(IEN) D
.; only look at cancelled appts
.Q:$P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,9)'="C"
.I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
Q $G(IEN)
MAIL ;
; Get Station Number
;
N STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
S STANUM=$$KSP^XUPARAM("INST")_","
S STANUM=$$GET1^DIQ(4,STANUM,99)
S MESS1="Station: "_STANUM_" - "
;
; Send MailMan message
S XMDUZ=DUZ
S XMTEXT="^XTMP(""SDES846PENC"","
S XMSUB=MESS1_"SD*5.3*846 post install - Orphaned Encounter Clean-up Report"
S XMDUZ=.5,XMY(DUZ)="",XMY(XMDUZ)=""
S XMY("DUNNAM.DAVID W@DOMAIN.EXT")=""
S XMY("REESE,DARRYL M@DOMAIN.EXT")=""
S XMY("FISHER.BRADLEY@DOMAIN.EXT")=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES846PENC 5465 printed Sep 23, 2025@20:31:50 Page 2
SDES846PENC ;ALB/BWF - SD*5.3*846 Post Init Routine ; June 15, 2023
+1 ;;5.3;SCHEDULING;**846**;AUG 13, 1993;Build 12
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
TASK ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*846 Post-Install to remove orphaned encounters for")
+3 DO MES^XPDUTL(" appointments that were cancelled by VAOS.")
+4 DO MES^XPDUTL("")
+5 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+6 SET ZTDESC="SD*5.3*846 Post Install Routine - Encounter Cleanup"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="FIXENC^SDES846PENC"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+8 IF $DATA(ZTSK)
Begin DoDot:1
+9 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+10 DO MES^XPDUTL("")
End DoDot:1
+11 IF '$DATA(ZTSK)
Begin DoDot:1
+12 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+13 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+14 QUIT
+15 ;
FIXENC ;
+1 NEW DFN,APPTDTTM,ENCOUNTER,CLINIC,IEN44,ENCFOUND,TOTCNT,CANRES,ENCLINKED,APPTIEN,RESOURCE,ENCLINKED
+2 NEW CANREASON,APPTCLIN,ENCCLIN,TOTAPPTS,SDESOITEASTOT,CANBY,CANDTTM,ORPHANENC,APPTENC,APPTCAN
+3 KILL ^XTMP("SDES846PENC")
+4 SET ^XTMP("SDES846PENC",0)=$$FMADD^XLFDT(DT,30)_"^"_DT_"^SD*5.3*846 Post Install Orphaned Encounter Data report"
+5 SET (TOTCNT,TOTAPPTS,SDESOITEASTOT)=0
+6 SET TOTCNT=TOTCNT+1
SET ^XTMP("SDES846PENC",TOTCNT)="APPT DATE/TIME^APPT IEN^PATIENT IEN^ENCOUNTER IEN^CANCELLED BY^UPDATE STATUS"
+7 SET CANDTTM=3230509.99
+8 FOR
SET CANDTTM=$ORDER(^SDEC(409.84,"AD",CANDTTM))
if 'CANDTTM
QUIT
Begin DoDot:1
+9 SET APPTIEN=0
FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"AD",CANDTTM,APPTIEN))
if 'APPTIEN
QUIT
Begin DoDot:2
+10 SET APPTDTTM=$$GET1^DIQ(409.84,APPTIEN,.01,"I")
+11 SET DFN=$$GET1^DIQ(409.84,APPTIEN,.05,"I")
+12 SET CANBY=$$GET1^DIQ(409.84,APPTIEN,.121,"E")
+13 ; only process encounters for appointments that have been CANCELLED by SDESOITEAS,SRV
+14 if CANBY'="SDESOITEAS,SRV"
QUIT
+15 SET RESOURCE=$$GET1^DIQ(409.84,APPTIEN,.07,"I")
if 'RESOURCE
QUIT
+16 SET CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I")
if 'CLINIC
QUIT
+17 SET TOTAPPTS=TOTAPPTS+1
+18 SET (ENCLINKED,ENCFOUND)=0
+19 SET ENCOUNTER=0
FOR
SET ENCOUNTER=$ORDER(^SCE("C",DFN,ENCOUNTER))
if 'ENCOUNTER!(ENCFOUND)
QUIT
Begin DoDot:3
+20 ; must match date/time
+21 IF $$GET1^DIQ(409.68,ENCOUNTER,.01,"I")'=APPTDTTM
QUIT
+22 ; encounter clinic must match the appointment clinic
+23 SET ENCCLIN=$$GET1^DIQ(409.68,ENCOUNTER,.04,"I")
+24 IF CLINIC'=ENCCLIN
QUIT
+25 SET APPTENC=$$GET1^DIQ(2.98,APPTDTTM_","_DFN_",",21,"I")
+26 SET APPTCAN=$$GET1^DIQ(2.98,APPTDTTM_","_DFN_",",15,"I")
+27 ; if the encounter is still on the appointment and this is not the correct encounter, quit
+28 IF APPTENC'=""
IF APPTENC'=ENCOUNTER
QUIT
+29 ; if the patient appointment is linked to the encounter and the appointment is not cancelled, quit
+30 IF APPTENC'=""
IF APPTENC=ENCOUNTER
IF APPTCAN=""
QUIT
+31 ; if there is an encounter on the appointment, it is not this encounter and the appointment is cancelled, set ENCLINKED/ENCFOUND and quit
+32 IF APPTENC'=""
IF APPTENC=ENCOUNTER
IF APPTCAN'=""
SET ENCFOUND=ENCOUNTER
SET ENCLINKED=1
QUIT
+33 ; this means if the appointment is linked to the encounter and the appointment IS cancelled, we want to close this encounter
+34 SET ENCFOUND=ENCOUNTER
End DoDot:3
+35 ; if there is no encounter found for this cancelled or no-show appointment, quit
+36 if 'ENCFOUND
QUIT
+37 SET TOTCNT=TOTCNT+1
+38 ; get the appointment from file 44, if it cannot be found log it.
+39 SET IEN44=$$SCIEN(DFN,CLINIC,APPTDTTM)
+40 IF 'IEN44
Begin DoDot:3
+41 SET ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_"0;Could not locate clinic appointment in the HOSPITAL LOCATION file (#44)."
+42 MERGE ^XTMP("SDES846PENC",TOTCNT)=^SCE(ENCFOUND)
End DoDot:3
QUIT
+43 ; if checked-in?? - do we cancel the checkin and proceed to clean up, or report that this entry needs to be handled manually?
+44 IF $$CI^SDECU2(DFN,CLINIC,APPTDTTM,IEN44)
Begin DoDot:3
+45 DO CANCHECKIN^SDESCANCHECKIN(.CANRES,APPTIEN)
End DoDot:3
+46 ; check again before updating the record - if we could not cancel the check-in log it and quit
+47 IF $$CI^SDECU2(DFN,CLINIC,APPTDTTM,IEN44)
Begin DoDot:3
+48 SET ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_"0;Could not cancel Check-in. Encounter not updated."
End DoDot:3
QUIT
+49 IF ENCLINKED
SET FDA(2.98,APPTDTTM_","_DFN_",",21)="@"
DO FILE^DIE(,"FDA")
KILL FDA
+50 SET ^XTMP("SDES846PENC",TOTCNT)=APPTDTTM_U_APPTIEN_U_DFN_U_ENCFOUND_U_CANBY_U_1
+51 SET SDESOITEASTOT=$GET(SDESOITEASTOT)+1
+52 ;remove OUTPATIENT ENCOUNTER link
DO EN^SDCODEL(ENCFOUND,2,"","CANCEL")
End DoDot:2
End DoDot:1
+53 SET ORPHANENC=$GET(TOTCNT)
+54 SET TOTCNT=TOTCNT+1
+55 SET $PIECE(^XTMP("SDES846PENC",TOTCNT),"-",80)=""
+56 SET TOTCNT=TOTCNT+1
+57 SET ^XTMP("SDES846PENC",TOTCNT)="TOTAL ORPHANED ENCOUNTERS: "_ORPHANENC
+58 SET TOTCNT=TOTCNT+1
+59 SET ^XTMP("SDES846PENC",TOTCNT)="TOTAL APPOINTMENTS SEARCHED: "_TOTAPPTS
+60 SET TOTCNT=TOTCNT+1
+61 SET ^XTMP("SDES846PENC",TOTCNT)="TOTAL ORPHANED ENCOUNTERS REMOVED: "_SDESOITEASTOT
+62 DO MAIL
+63 QUIT
SCIEN(PAT,CLINIC,DATE) ;returns ien for appt in ^SC
+1 NEW X,IEN
+2 SET X=0
FOR
SET X=$ORDER(^SC(CLINIC,"S",DATE,1,X))
if 'X
QUIT
if $GET(IEN)
QUIT
Begin DoDot:1
+3 ; only look at cancelled appts
+4 if $PIECE($GET(^SC(CLINIC,"S",DATE,1,X,0)),U,9)'="C"
QUIT
+5 IF +$GET(^SC(CLINIC,"S",DATE,1,X,0))=PAT
SET IEN=X
End DoDot:1
+6 QUIT $GET(IEN)
MAIL ;
+1 ; Get Station Number
+2 ;
+3 NEW STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM
+4 SET STANUM=$$KSP^XUPARAM("INST")_","
+5 SET STANUM=$$GET1^DIQ(4,STANUM,99)
+6 SET MESS1="Station: "_STANUM_" - "
+7 ;
+8 ; Send MailMan message
+9 SET XMDUZ=DUZ
+10 SET XMTEXT="^XTMP(""SDES846PENC"","
+11 SET XMSUB=MESS1_"SD*5.3*846 post install - Orphaned Encounter Clean-up Report"
+12 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(XMDUZ)=""
+13 SET XMY("DUNNAM.DAVID W@DOMAIN.EXT")=""
+14 SET XMY("REESE,DARRYL M@DOMAIN.EXT")=""
+15 SET XMY("FISHER.BRADLEY@DOMAIN.EXT")=""
+16 DO ^XMD
+17 QUIT
