SD53726P ;MNT/BJR - REMAP CLINICS 726 POST INSTALL ;4/2/19 10:04am
;;5.3;Scheduling;**726**;Aug 13, 1993;Build 36
;
Q
;Calls to XLFDT supported by ICR #10103
;Call to %ZTLOAD supported by ICR #10063
;Call to %ZISC supported by ICR #10089
;Call to BMES^XPDUTL supported by ICR #10141
;
EN ;Entry point for post install to remap clinics
D RMVMES,ADDT,CANC
N BEGDATE,ENDDATE,VAUTD,VAUTC,SDBD,SDED,SDIEN,SDQMES
S BEGDATE=DT,ENDDATE=$$FMADD^XLFDT(DT,365),SDBD=DT,SDED=ENDDATE,VAUTD=1
S SDVAR1="SDBD^SDED^VAUTD#^VAUTC#^DUZ^BEGDATE^ENDDATE",SDPGM="START^SDD",SDFZIS=1
S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN D
.I $G(^SC(SDIEN,"I")) I +^SC(SDIEN,"I")>=DT!(+^SC(SDIEN,"I")<=DT&(($P(^SC(SDIEN,"I"),U,2)>=DT)!($P(^SC(SDIEN,"I"),U,2)=""))) Q
.S ZTIO=$G(XPDQUES("POS1")),ZTDTH=$$NOW^XLFDT
.S ZTDESC=SDPGM,ZTRTN=SDPGM,SDZTSAVE=SDVAR1
.S VAUTC=0,VAUTC($P(^SC(SDIEN,0),U))=SDIEN D
..I $D(SDPGM),'$D(ZTSAVE("SDPGM")) S ZTSAVE("SDPGM")="" D SAVE
D ^%ZTLOAD
S SDQMES=$S($D(ZTSK):"Request Queued!",1:"Request Failed!") D BMES^XPDUTL(SDQMES) D CLOSE:$D(ZTSK)
D END1
Q
RMVMES ;Remove MESSAGE (#1400) fields w/o corresponding SDCAN to ensure clinic grid builds properly
N SDIEN,SDDT,SDMES
S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN S SDDT=0 F S SDDT=$O(^SC(SDIEN,"S",SDDT)) Q:'SDDT D
.I $D(^SC(SDIEN,"S",SDDT,"MES")),'$D(^SC(SDIEN,"SDCAN",SDDT,0)),SDDT>=DT K ^SC(SDIEN,"S",SDDT,"MES") D
..S SDMES=$P(^SC(SDIEN,0),U)_" message field removed for "_$$FMTE^XLFDT(SDDT) D BMES^XPDUTL(SDMES)
Q
ADDT ;Add any missing "T" zero nodes to ensure clinic grid builds properly
N SDIEN,SDDT,SDMES
S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN S SDDT=0 F S SDDT=$O(^SC(SDIEN,"T",SDDT)) Q:'SDDT D
.I $D(^SC(SDIEN,"T",SDDT)),'$D(^SC(SDIEN,"T",SDDT,0)) S ^SC(SDIEN,"T",SDDT,0)=SDDT
Q
CANC ; Cancel appt in 44 that are canceled in 2
N SDIEN,SDDT,SDCLIN,SDAPPT,SDMES,DIE,DA,DR
S SDIEN=0 F S SDIEN=$O(^DPT(SDIEN)) Q:'SDIEN S SDDT=DT F S SDDT=$O(^DPT(SDIEN,"S",SDDT)) Q:'SDDT D
.I $P(^DPT(SDIEN,"S",SDDT,0),U,2)["C" S SDCLIN=$P(^DPT(SDIEN,"S",SDDT,0),U) I $D(^SC(SDCLIN,"S",SDDT,0)) D
..S SDAPPT=0 F S SDAPPT=$O(^SC(SDCLIN,"S",SDDT,1,SDAPPT)) Q:'SDAPPT D
...I +^SC(SDCLIN,"S",SDDT,1,SDAPPT,0)=SDIEN,$P(^SC(SDCLIN,"S",SDDT,1,SDAPPT,0),U,9)'="C" D
....S DIE="^SC("_SDCLIN_",""S"","_SDDT_",1,",DA(2)=SDCLIN,DA(1)=SDDT,DA=SDAPPT,DR="310///C;3///Canceled by patch SD*5.3*726" D ^DIE
....S SDMES="Appointment for patient "_$P(^DPT(SDIEN,0),U)_" at "_$P(^SC(SDCLIN,0),U)_" at "_$$FMTE^XLFDT(SDDT)_" has been canceled in the Hospital Location file."
....D BMES^XPDUTL(SDMES)
Q
SAVE ;Set up save variable for routine
D:SDZTSAVE["#" ARRAY F SDI=1:1 S SDVAR=$P(SDZTSAVE,"^",SDI) Q:SDVAR']"" I '$D(ZTSAVE(SDVAR)) S ZTSAVE(SDVAR)="" S:$E(SDVAR,$L(SDVAR))="(" ZTSAVE($E(SDVAR,1,($L(SDVAR)-1)))=""
Q
ARRAY ;Set up routine array
F SDJ=1:1:$L(SDZTSAVE) I $E(SDZTSAVE,SDJ)="#" S SDZTSAVE=$E(SDZTSAVE,1,(SDJ-1))_"("_$E(SDZTSAVE,SDJ+1,$L(SDZTSAVE))
Q
CLOSE Q:$D(ZTQUEUED) N POP D ^%ZISC
END ;Clean up variables
K ZTSK,ZTDESCZTREQ,ZTSAVE,ZTUCI,ZTQUEUED Q
END1 ;Clean up Variables
K SDVAR,SDPGM,SDZTSAVE,SDI,SDJ,SDFZIS,ZTIO,ZTDTH,ZTRTN,ZTDESC,%ZIS,XPDQUES,IO("Q"),IO("C"),SDVAR1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53726P 3242 printed Sep 23, 2025@20:21:48 Page 2
SD53726P ;MNT/BJR - REMAP CLINICS 726 POST INSTALL ;4/2/19 10:04am
+1 ;;5.3;Scheduling;**726**;Aug 13, 1993;Build 36
+2 ;
+3 QUIT
+4 ;Calls to XLFDT supported by ICR #10103
+5 ;Call to %ZTLOAD supported by ICR #10063
+6 ;Call to %ZISC supported by ICR #10089
+7 ;Call to BMES^XPDUTL supported by ICR #10141
+8 ;
EN ;Entry point for post install to remap clinics
+1 DO RMVMES
DO ADDT
DO CANC
+2 NEW BEGDATE,ENDDATE,VAUTD,VAUTC,SDBD,SDED,SDIEN,SDQMES
+3 SET BEGDATE=DT
SET ENDDATE=$$FMADD^XLFDT(DT,365)
SET SDBD=DT
SET SDED=ENDDATE
SET VAUTD=1
+4 SET SDVAR1="SDBD^SDED^VAUTD#^VAUTC#^DUZ^BEGDATE^ENDDATE"
SET SDPGM="START^SDD"
SET SDFZIS=1
+5 SET SDIEN=0
FOR
SET SDIEN=$ORDER(^SC(SDIEN))
if 'SDIEN
QUIT
Begin DoDot:1
+6 IF $GET(^SC(SDIEN,"I"))
IF +^SC(SDIEN,"I")>=DT!(+^SC(SDIEN,"I")<=DT&(($PIECE(^SC(SDIEN,"I"),U,2)>=DT)!($PIECE(^SC(SDIEN,"I"),U,2)="")))
QUIT
+7 SET ZTIO=$GET(XPDQUES("POS1"))
SET ZTDTH=$$NOW^XLFDT
+8 SET ZTDESC=SDPGM
SET ZTRTN=SDPGM
SET SDZTSAVE=SDVAR1
+9 SET VAUTC=0
SET VAUTC($PIECE(^SC(SDIEN,0),U))=SDIEN
Begin DoDot:2
+10 IF $DATA(SDPGM)
IF '$DATA(ZTSAVE("SDPGM"))
SET ZTSAVE("SDPGM")=""
DO SAVE
End DoDot:2
End DoDot:1
+11 DO ^%ZTLOAD
+12 SET SDQMES=$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Failed!")
DO BMES^XPDUTL(SDQMES)
if $DATA(ZTSK)
DO CLOSE
+13 DO END1
+14 QUIT
RMVMES ;Remove MESSAGE (#1400) fields w/o corresponding SDCAN to ensure clinic grid builds properly
+1 NEW SDIEN,SDDT,SDMES
+2 SET SDIEN=0
FOR
SET SDIEN=$ORDER(^SC(SDIEN))
if 'SDIEN
QUIT
SET SDDT=0
FOR
SET SDDT=$ORDER(^SC(SDIEN,"S",SDDT))
if 'SDDT
QUIT
Begin DoDot:1
+3 IF $DATA(^SC(SDIEN,"S",SDDT,"MES"))
IF '$DATA(^SC(SDIEN,"SDCAN",SDDT,0))
IF SDDT>=DT
KILL ^SC(SDIEN,"S",SDDT,"MES")
Begin DoDot:2
+4 SET SDMES=$PIECE(^SC(SDIEN,0),U)_" message field removed for "_$$FMTE^XLFDT(SDDT)
DO BMES^XPDUTL(SDMES)
End DoDot:2
End DoDot:1
+5 QUIT
ADDT ;Add any missing "T" zero nodes to ensure clinic grid builds properly
+1 NEW SDIEN,SDDT,SDMES
+2 SET SDIEN=0
FOR
SET SDIEN=$ORDER(^SC(SDIEN))
if 'SDIEN
QUIT
SET SDDT=0
FOR
SET SDDT=$ORDER(^SC(SDIEN,"T",SDDT))
if 'SDDT
QUIT
Begin DoDot:1
+3 IF $DATA(^SC(SDIEN,"T",SDDT))
IF '$DATA(^SC(SDIEN,"T",SDDT,0))
SET ^SC(SDIEN,"T",SDDT,0)=SDDT
End DoDot:1
+4 QUIT
CANC ; Cancel appt in 44 that are canceled in 2
+1 NEW SDIEN,SDDT,SDCLIN,SDAPPT,SDMES,DIE,DA,DR
+2 SET SDIEN=0
FOR
SET SDIEN=$ORDER(^DPT(SDIEN))
if 'SDIEN
QUIT
SET SDDT=DT
FOR
SET SDDT=$ORDER(^DPT(SDIEN,"S",SDDT))
if 'SDDT
QUIT
Begin DoDot:1
+3 IF $PIECE(^DPT(SDIEN,"S",SDDT,0),U,2)["C"
SET SDCLIN=$PIECE(^DPT(SDIEN,"S",SDDT,0),U)
IF $DATA(^SC(SDCLIN,"S",SDDT,0))
Begin DoDot:2
+4 SET SDAPPT=0
FOR
SET SDAPPT=$ORDER(^SC(SDCLIN,"S",SDDT,1,SDAPPT))
if 'SDAPPT
QUIT
Begin DoDot:3
+5 IF +^SC(SDCLIN,"S",SDDT,1,SDAPPT,0)=SDIEN
IF $PIECE(^SC(SDCLIN,"S",SDDT,1,SDAPPT,0),U,9)'="C"
Begin DoDot:4
+6 SET DIE="^SC("_SDCLIN_",""S"","_SDDT_",1,"
SET DA(2)=SDCLIN
SET DA(1)=SDDT
SET DA=SDAPPT
SET DR="310///C;3///Canceled by patch SD*5.3*726"
DO ^DIE
+7 SET SDMES="Appointment for patient "_$PIECE(^DPT(SDIEN,0),U)_" at "_$PIECE(^SC(SDCLIN,0),U)_" at "_$$FMTE^XLFDT(SDDT)_" has been canceled in the Hospital Location file."
+8 DO BMES^XPDUTL(SDMES)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
SAVE ;Set up save variable for routine
+1 if SDZTSAVE["#"
DO ARRAY
FOR SDI=1:1
SET SDVAR=$PIECE(SDZTSAVE,"^",SDI)
if SDVAR']""
QUIT
IF '$DATA(ZTSAVE(SDVAR))
SET ZTSAVE(SDVAR)=""
if $EXTRACT(SDVAR,$LENGTH(SDVAR))="("
SET ZTSAVE($EXTRACT(SDVAR,1,($LENGTH(SDVAR)-1)))=""
+2 QUIT
ARRAY ;Set up routine array
+1 FOR SDJ=1:1:$LENGTH(SDZTSAVE)
IF $EXTRACT(SDZTSAVE,SDJ)="#"
SET SDZTSAVE=$EXTRACT(SDZTSAVE,1,(SDJ-1))_"("_$EXTRACT(SDZTSAVE,SDJ+1,$LENGTH(SDZTSAVE))
+2 QUIT
CLOSE if $DATA(ZTQUEUED)
QUIT
NEW POP
DO ^%ZISC
END ;Clean up variables
+1 KILL ZTSK,ZTDESCZTREQ,ZTSAVE,ZTUCI,ZTQUEUED
QUIT
END1 ;Clean up Variables
+1 KILL SDVAR,SDPGM,SDZTSAVE,SDI,SDJ,SDFZIS,ZTIO,ZTDTH,ZTRTN,ZTDESC,%ZIS,XPDQUES,IO("Q"),IO("C"),SDVAR1
+2 QUIT
