SDUNC ;ALB/MGD - RESTORE CLINIC AVAILABILITY ;Apr 12, 2022
;;5.3;Scheduling;**79,303,380,452,780,806,814,812**;Aug 13, 1993;Build 17
;;Per VHA Directive 6402, this routine should not be modified
;
D DT^DICRW S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X G:Y<0 SDUNC Q:'$D(^SC(+Y,"SL"))
S SC=+Y,SL=^("SL") ;NAKED REFERENCE - ^SC(IFN,"SL")
N SDRES S SDRES=$$CLNCK^SDUTL2(SC,1)
I 'SDRES W !,?5,"Clinic MUST be corrected before continuing." G SDUNC
S %DT="AEXF",%DT("A")="RESTORE '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT Q:Y<0
S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S(%:%,1:8)
K SDIN,SDIN1,SDRE,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDIN D DTS^SDUTL S SDIN1=Y,Y=SDRE D DTS^SDUTL S SDRE1=Y
I $S('$D(SDIN):0,'SDIN:0,SDIN>CDATE:0,SDRE'>CDATE&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),SDIN1,$S(SDRE:" to "_SDRE1,1:"") G SDUNC
K SDIN,SDIN1,SDRE,SDRE1 G:'$D(^SC(SC,"ST",SD,1)) NOWAY
I $D(^SC(SC,"ST",SD,1)),^(1)'["CANCELLED"&(^(1)'["X") G NOWAY
I $D(^SC(SC,"ST",SD,9)) I $D(^SC(SC,"OST",SD,1)) D FIX Q:"^"[$G(X) Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,1)=HOLD K:^(1)'["X" ^SC(SC,"ST",SD,"CAN") W !,"RESTORED!",*7 D CHK Q
I $D(^SC(SC,"ST",SD,9)),'$D(^SC(SC,"OST",SD,1)) G ERRM^SDUNC1
D B I '$D(DH) G NOPAT
Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,0)=SD,^SC(SC,"ST",SD,1)=DH G N
NOWAY W !,*7,"CLINIC HAS NOT BEEN CANCELLED FOR THAT DATE, SO IT CANNOT BE RESTORED",*7 G SDUNC
NOPAT W !,*7,"NO UPCOMING OR INDEFINITE APPOINTMENT PATTERN EXISTS FOR DAY OF WEEK,",!,"CREATE 'AVAILABILITY' PATTERN THRU 'CLINIC SETUP', THEN RESTORE AGAIN",*7 G SDUNC
B S X=SD D DOW^SDM0 S DOW=Y,SS=$O(^SC(SC,"T"_Y,X)) I SS'="",$D(^(SS,1)),^(1)]"" S DH=$P("SU^MO^TU^WE^TH^FR^SA","^",DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),DO=X+1,DA(1)=SC,HOLD=DH D FIX2
Q
N I '$F(^SC(SC,"ST",SD,1),"[") K ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDUNC
K:^SC(SC,"ST",SD,1)'["X" ^SC(SC,"ST",SD,"CAN") W !,"RESTORED!",*7 D:'$G(TMPP) TMPD D CHK K TMPP Q ;Added code to stop TMPD call if a partial day restore *812
FIX I ^SC(SC,"ST",SD,1)["X" S SDREST=^SC(SC,"OST",SD,1) D SEL Q
S HOLD=^SC(SC,"OST",SD,1)
Q
CHK F N1=SD:0 S N1=$O(^SC(SC,"S",N1)) Q:'N1!(N1\1-SD) I $D(^SC(SC,"S",N1,"MES")) D KMES I $D(SDFR1),'$D(^("MES")) Q
Q
FIX2 Q:^SC(SC,"ST",SD,1)'["X"
S SDREST=DH D SEL Q:'$D(SDFR1) S DH=HOLD
Q
SEL K SDFR1 Q:'$D(^SC(SC,"SL")) S SL=^("SL"),%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S(%:%,1:8)
W !,"Clinic has been cancelled for the following periods:",!
K SDTEMP,SDZZ S SDZZ=0 F I=SD:0 S I=$O(^SC(SC,"SDCAN",I)) Q:'I!(I\1-SD) S SDZZ=SDZZ+1,X=I D TM S SDFR=X,SDFRX=X1,X="."_$P(^(I,0),"^",2) D TM S SDTO=X,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO,SDZZ(SDZZ)=SDFRX_"-"_X1
F I=SD:0 S I=$O(^SC(SC,"S",I)) Q:'I!(I\1-SD) I $D(^SC(SC,"S",I,"MES")),'$D(^SC(SC,"SDCAN",I)) S X=I D TM S SDFRX=X1,SDFR=X,X="."_$E(^SC(SC,"S",I,"MES"),17,20) D TM S SDZZ=SDZZ+1,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X,SDZZ(SDZZ)=SDFRX_"-"_X1
F I1=0:0 S I1=$O(SDZZ(I1)) Q:'I1 S I=SDTEMP(SDZZ(I1)) W !,?9,"(",$J(I1,2),") ","From: ",$J($P(I,"^",1),8)," To: ",$J($P(I,"^",2),8)
A K SDFRX,X1,SDFR,SDTO R !!,"RESTORE WHICH PERIOD?: ",X:DTIME Q:"^"[X
I X?1"?".E W !,"Enter the # that precedes the time period you want to restore." G A
S SDR=X I $D(SDZZ(SDR)),$D(SDTEMP(SDZZ(SDR))) W " ",$P(SDTEMP(SDZZ(SDR)),"^",1)," - ",$P(SDTEMP(SDZZ(SDR)),"^",2) G ROK
W !,*7,"INVALID CHOICE, TRY AGAIN" G A
ROK S X=$P(SDZZ(SDR),"-",1) D TC S FR=X,SDBEG=%+SI+SI,X=$P(SDZZ(SDR),"-",2) D TC S TO=X,SDEND=%+SI+SI
S SDFR1=CDATE+(FR/10000) K SDTEMP,SDZZ,SDR
S HOLD=^SC(SC,"ST",SD,1),HOLD=$E(HOLD,1,SDBEG-1)_$E(SDREST,SDBEG,SDEND)_$E(HOLD,SDEND+1,80) D TMPP K ^SC(SC,"SDCAN",SDFR1) I $D(^SC(SC,"SDCAN",0)) S CNT=$P(^(0),U,4),CNT=$S(CNT>0:CNT-1,1:0),^(0)=$P(^(0),U,1,3)_U_CNT K CNT
I HOLD'["[" S I5=$F(HOLD,"|"),HOLD=$E(HOLD,1,(I5-2))_"["_$E(HOLD,I5,999) K I5
K SDBEG,SDEND,SDANS,SI,STARTDAY,FR,TO Q
KMES I '$D(SDFR1) K ^("MES") Q ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
I $D(SDFR1),N1=SDFR1 K ^("MES") Q ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
Q
TC S %=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2
Q
TM S X=$E($P(X,".",2)_"0000",1,4),X1=X,%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
TMPD D EN^SDTMPHLC(SC,SD,,"UC","RESTORED - DAY") Q ;780
TMPP N F,T S F=+(SD_"."_FR),T=+(SD_"."_TO) D EN^SDTMPHLC(SC,F,T,"UP","RESTORED - PARTIAL DAY") S TMPP=1 Q ;780
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUNC 4646 printed Oct 16, 2024@19:02:12 Page 2
SDUNC ;ALB/MGD - RESTORE CLINIC AVAILABILITY ;Apr 12, 2022
+1 ;;5.3;Scheduling;**79,303,380,452,780,806,814,812**;Aug 13, 1993;Build 17
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 DO DT^DICRW
SET DIC=44
SET DIC(0)="MEQA"
SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
SET DIC("A")="Select CLINIC NAME: "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
if Y<0
GOTO SDUNC
if '$DATA(^SC(+Y,"SL"))
QUIT
+5 ;NAKED REFERENCE - ^SC(IFN,"SL")
SET SC=+Y
SET SL=^("SL")
+6 NEW SDRES
SET SDRES=$$CLNCK^SDUTL2(SC,1)
+7 IF 'SDRES
WRITE !,?5,"Clinic MUST be corrected before continuing."
GOTO SDUNC
+8 SET %DT="AEXF"
SET %DT("A")="RESTORE '"_$PIECE(Y,U,2)_"' FOR WHAT DATE: "
DO ^%DT
KILL %DT
if Y<0
QUIT
+9 SET (SD,CDATE)=Y
SET %=$PIECE(SL,U,6)
SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
SET %=$PIECE(SL,U,3)
SET STARTDAY=$SELECT(%:%,1:8)
+10 KILL SDIN,SDIN1,SDRE,SDRE1
IF $DATA(^SC(SC,"I"))
SET SDIN=+^("I")
SET SDRE=+$PIECE(^("I"),"^",2)
SET Y=SDIN
DO DTS^SDUTL
SET SDIN1=Y
SET Y=SDRE
DO DTS^SDUTL
SET SDRE1=Y
+11 IF $SELECT('$DATA(SDIN):0,'SDIN:0,SDIN>CDATE:0,SDRE'>CDATE&(SDRE):0,1:1)
WRITE !,*7,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),SDIN1,$SELECT(SDRE:" to "_SDRE1,1:"")
GOTO SDUNC
+12 KILL SDIN,SDIN1,SDRE,SDRE1
if '$DATA(^SC(SC,"ST",SD,1))
GOTO NOWAY
+13 IF $DATA(^SC(SC,"ST",SD,1))
IF ^(1)'["CANCELLED"&(^(1)'["X")
GOTO NOWAY
+14 IF $DATA(^SC(SC,"ST",SD,9))
IF $DATA(^SC(SC,"OST",SD,1))
DO FIX
if "^"[$GET(X)
QUIT
if ^SC(SC,"ST",SD,1)["X"&('$DATA(SDFR1))
QUIT
SET ^SC(SC,"ST",SD,1)=HOLD
if ^(1)'["X"
KILL ^SC(SC,"ST",SD,"CAN")
WRITE !,"RESTORED!",*7
DO CHK
QUIT
+15 IF $DATA(^SC(SC,"ST",SD,9))
IF '$DATA(^SC(SC,"OST",SD,1))
GOTO ERRM^SDUNC1
+16 DO B
IF '$DATA(DH)
GOTO NOPAT
+17 if ^SC(SC,"ST",SD,1)["X"&('$DATA(SDFR1))
QUIT
SET ^SC(SC,"ST",SD,0)=SD
SET ^SC(SC,"ST",SD,1)=DH
GOTO N
NOWAY WRITE !,*7,"CLINIC HAS NOT BEEN CANCELLED FOR THAT DATE, SO IT CANNOT BE RESTORED",*7
GOTO SDUNC
NOPAT WRITE !,*7,"NO UPCOMING OR INDEFINITE APPOINTMENT PATTERN EXISTS FOR DAY OF WEEK,",!,"CREATE 'AVAILABILITY' PATTERN THRU 'CLINIC SETUP', THEN RESTORE AGAIN",*7
GOTO SDUNC
B SET X=SD
DO DOW^SDM0
SET DOW=Y
SET SS=$ORDER(^SC(SC,"T"_Y,X))
IF SS'=""
IF $DATA(^(SS,1))
IF ^(1)]""
SET DH=$PIECE("SU^MO^TU^WE^TH^FR^SA","^",DOW+1)_" "_$EXTRACT(SD,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET DO=X+1
SET DA(1)=SC
SET HOLD=DH
DO FIX2
+1 QUIT
N IF '$FIND(^SC(SC,"ST",SD,1),"[")
KILL ^SC(SC,"ST",SD)
WRITE !,*7,"CLINIC DOES NOT MEET ON THAT DAY"
GOTO SDUNC
+1 ;Added code to stop TMPD call if a partial day restore *812
if ^SC(SC,"ST",SD,1)'["X"
KILL ^SC(SC,"ST",SD,"CAN")
WRITE !,"RESTORED!",*7
if '$GET(TMPP)
DO TMPD
DO CHK
KILL TMPP
QUIT
FIX IF ^SC(SC,"ST",SD,1)["X"
SET SDREST=^SC(SC,"OST",SD,1)
DO SEL
QUIT
+1 SET HOLD=^SC(SC,"OST",SD,1)
+2 QUIT
CHK FOR N1=SD:0
SET N1=$ORDER(^SC(SC,"S",N1))
if 'N1!(N1\1-SD)
QUIT
IF $DATA(^SC(SC,"S",N1,"MES"))
DO KMES
IF $DATA(SDFR1)
IF '$DATA(^("MES"))
QUIT
+1 QUIT
FIX2 if ^SC(SC,"ST",SD,1)'["X"
QUIT
+1 SET SDREST=DH
DO SEL
if '$DATA(SDFR1)
QUIT
SET DH=HOLD
+2 QUIT
SEL KILL SDFR1
if '$DATA(^SC(SC,"SL"))
QUIT
SET SL=^("SL")
SET %=$PIECE(SL,U,6)
SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
SET %=$PIECE(SL,U,3)
SET STARTDAY=$SELECT(%:%,1:8)
+1 WRITE !,"Clinic has been cancelled for the following periods:",!
+2 KILL SDTEMP,SDZZ
SET SDZZ=0
FOR I=SD:0
SET I=$ORDER(^SC(SC,"SDCAN",I))
if 'I!(I\1-SD)
QUIT
SET SDZZ=SDZZ+1
SET X=I
DO TM
SET SDFR=X
SET SDFRX=X1
SET X="."_$PIECE(^(I,0),"^",2)
DO TM
SET SDTO=X
SET SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO
SET SDZZ(SDZZ)=SDFRX_"-"_X1
+3 FOR I=SD:0
SET I=$ORDER(^SC(SC,"S",I))
if 'I!(I\1-SD)
QUIT
IF $DATA(^SC(SC,"S",I,"MES"))
IF '$DATA(^SC(SC,"SDCAN",I))
SET X=I
DO TM
SET SDFRX=X1
SET SDFR=X
SET X="."_$EXTRACT(^SC(SC,"S",I,"MES"),17,20)
DO TM
SET SDZZ=SDZZ+1
SET SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X
SET SDZZ(SDZZ)=SDFRX_"-"_X1
+4 FOR I1=0:0
SET I1=$ORDER(SDZZ(I1))
if 'I1
QUIT
SET I=SDTEMP(SDZZ(I1))
WRITE !,?9,"(",$JUSTIFY(I1,2),") ","From: ",$JUSTIFY($PIECE(I,"^",1),8)," To: ",$JUSTIFY($PIECE(I,"^",2),8)
A KILL SDFRX,X1,SDFR,SDTO
READ !!,"RESTORE WHICH PERIOD?: ",X:DTIME
if "^"[X
QUIT
+1 IF X?1"?".E
WRITE !,"Enter the # that precedes the time period you want to restore."
GOTO A
+2 SET SDR=X
IF $DATA(SDZZ(SDR))
IF $DATA(SDTEMP(SDZZ(SDR)))
WRITE " ",$PIECE(SDTEMP(SDZZ(SDR)),"^",1)," - ",$PIECE(SDTEMP(SDZZ(SDR)),"^",2)
GOTO ROK
+3 WRITE !,*7,"INVALID CHOICE, TRY AGAIN"
GOTO A
ROK SET X=$PIECE(SDZZ(SDR),"-",1)
DO TC
SET FR=X
SET SDBEG=%+SI+SI
SET X=$PIECE(SDZZ(SDR),"-",2)
DO TC
SET TO=X
SET SDEND=%+SI+SI
+1 SET SDFR1=CDATE+(FR/10000)
KILL SDTEMP,SDZZ,SDR
+2 SET HOLD=^SC(SC,"ST",SD,1)
SET HOLD=$EXTRACT(HOLD,1,SDBEG-1)_$EXTRACT(SDREST,SDBEG,SDEND)_$EXTRACT(HOLD,SDEND+1,80)
DO TMPP
KILL ^SC(SC,"SDCAN",SDFR1)
IF $DATA(^SC(SC,"SDCAN",0))
SET CNT=$PIECE(^(0),U,4)
SET CNT=$SELECT(CNT>0:CNT-1,1:0)
SET ^(0)=$PIECE(^(0),U,1,3)_U_CNT
KILL CNT
+3 IF HOLD'["["
SET I5=$FIND(HOLD,"|")
SET HOLD=$EXTRACT(HOLD,1,(I5-2))_"["_$EXTRACT(HOLD,I5,999)
KILL I5
+4 KILL SDBEG,SDEND,SDANS,SI,STARTDAY,FR,TO
QUIT
KMES ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
IF '$DATA(SDFR1)
KILL ^("MES")
QUIT
+1 ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
IF $DATA(SDFR1)
IF N1=SDFR1
KILL ^("MES")
QUIT
+2 QUIT
TC SET %=$EXTRACT(X,3,4)
SET %=X\100-STARTDAY*SI+(%*SI\60)*2
+1 QUIT
TM SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET X1=X
SET %=X>1159
if X>1259
SET X=X-1200
SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M"
QUIT
TMPD ;780
DO EN^SDTMPHLC(SC,SD,,"UC","RESTORED - DAY")
QUIT
TMPP ;780
NEW F,T
SET F=+(SD_"."_FR)
SET T=+(SD_"."_TO)
DO EN^SDTMPHLC(SC,F,T,"UP","RESTORED - PARTIAL DAY")
SET TMPP=1
QUIT
