SDAUT1 ;MAN/GRR - AUTO REBOOK SET REQUIRED AVAILABILITY NODES ;28 MAR 84 1:46 pm
;;5.3;Scheduling;**140,674,806**;Aug 13, 1993;Build 4
K SDXXX S MAX=$S($D(^SC(SC,"SDP")):$P(^("SDP"),"^",4),1:0)
Q:MAX=0 S STIME=$S($D(^SC(SC,"SDP")):$P(^("SDP"),"^",3),1:"0800"),X1=CDATE,X2=DT D ^%DTC
I X<10 S X1=$S(CDATE<DT:DT,1:CDATE),X2=10 D C^%DTC S SDSTRTDT=X G OVR
S SDSTRTDT=CDATE
OVR S SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1)
S X1=SDSTRTDT,X2=MAX D C^%DTC S ENDATE=$S('$D(SDIN):X,SDIN>SDSTRTDT&(SDIN<X):SDIN,1:X),X=SDSTRTDT
N SDX,SDIEN,SDBEG,SDDOW,SDBDT ;New variables for SD*5.3*674 changes
;Set beginning date to use for indefinite clinic availabilities
S SDX=0 F S SDX=$O(^SC(SC,"T",SDX)) Q:'SDX S SDBEG=$G(^SC(SC,"T",SDX,0)) I '$D(^SC(SC,"OST",SDX))!($D(^SC(SC,"T"_$$DOW^XLFDT(SDBEG,1),SDX))) S SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)="" ;SD*5.3*674
F SDX=0:1:6 S:'$D(SDDOW(SDX)) SDDOW(SDX,9999999)="" ;SD*5.3*674
EN1 S:$O(^SC(+SC,"T",0))>X X=$O(^(0)) D DOW S I=Y+32,SM=X,D=Y D WM ;Change $N to $O, SD*5.3*674
K J F Y=0:1:6 I $D(^SC(+SC,"T"_Y)) S J(Y)="",DA=+SC,DOW=Y D:'$D(^SC(+SC,"T"_Y,0)) TX^SDB1
Q:'$D(J)
X1 Q:X>ENDATE S X1=X\100_28
W S X=X\1 I '$D(^SC(+SC,"ST",X,1)) S SDBDT=$O(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1) I X>=($S(SDBDT:SDBDT,1:9999999)) S Y=D#7 G L:'$D(J(Y)),H:$D(^HOLIDAY(X))&('SDSOH) D ;check beginning date, SD*5.3*674
.S SS=$O(^SC(+SC,"T"_Y,X)) G L:SS="",L:^(SS,1)=""
.K SDST1 S SDST1=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(X,6,7)_$J("",SI+SI-6)_^SC(+SC,"T"_Y,SS,1) ;SD*5.3*806
.D SEND^SDTMPHLC(+SC,X\1,SDST1)
.S ^SC(+SC,"ST",X\1,1)=SDST1,^(0)=X\1 ;SD*5.3*674
I $D(SDXXX) S SDXXX=SDXXX+1 W:'(SDXXX#100) "."
D WM:X>SM
L I X>ENDATE Q
S X=X+1,D=D+1 G W:X'>X1 S X2=X-X1 D C^%DTC G X1
;
H K SDST1 S SDST1=" "_$E(X,6,7)_" "_$P($G(^HOLIDAY(X,0)),U,2) D SEND^SDTMPHLC(+SC,X\1,SDST1) S ^SC(+SC,"ST",X,1)=SDST1,^(0)=X S:'$D(^SC(+SC,"ST",0)) ^(0)="^44.005DA^^" G W ;806
;
WM S SM=$S($E(X,4,5)[12:$E(X,1,3)+1_"01",1:$E(X,1,3)_$E(X,4,5)+1)_"00" Q
;
DOW ;
S Y=$$DOW^XLFDT(X,1)
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAUT1 2100 printed Dec 13, 2024@02:48:32 Page 2
SDAUT1 ;MAN/GRR - AUTO REBOOK SET REQUIRED AVAILABILITY NODES ;28 MAR 84 1:46 pm
+1 ;;5.3;Scheduling;**140,674,806**;Aug 13, 1993;Build 4
+2 KILL SDXXX
SET MAX=$SELECT($DATA(^SC(SC,"SDP")):$PIECE(^("SDP"),"^",4),1:0)
+3 if MAX=0
QUIT
SET STIME=$SELECT($DATA(^SC(SC,"SDP")):$PIECE(^("SDP"),"^",3),1:"0800")
SET X1=CDATE
SET X2=DT
DO ^%DTC
+4 IF X<10
SET X1=$SELECT(CDATE<DT:DT,1:CDATE)
SET X2=10
DO C^%DTC
SET SDSTRTDT=X
GOTO OVR
+5 SET SDSTRTDT=CDATE
OVR SET SDSOH=$SELECT('$DATA(^SC(SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
+1 SET X1=SDSTRTDT
SET X2=MAX
DO C^%DTC
SET ENDATE=$SELECT('$DATA(SDIN):X,SDIN>SDSTRTDT&(SDIN<X):SDIN,1:X)
SET X=SDSTRTDT
+2 ;New variables for SD*5.3*674 changes
NEW SDX,SDIEN,SDBEG,SDDOW,SDBDT
+3 ;Set beginning date to use for indefinite clinic availabilities
+4 ;SD*5.3*674
SET SDX=0
FOR
SET SDX=$ORDER(^SC(SC,"T",SDX))
if 'SDX
QUIT
SET SDBEG=$GET(^SC(SC,"T",SDX,0))
IF '$DATA(^SC(SC,"OST",SDX))!($DATA(^SC(SC,"T"_$$DOW^XLFDT(SDBEG,1),SDX)))
SET SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)=""
+5 ;SD*5.3*674
FOR SDX=0:1:6
if '$DATA(SDDOW(SDX))
SET SDDOW(SDX,9999999)=""
EN1 ;Change $N to $O, SD*5.3*674
if $ORDER(^SC(+SC,"T",0))>X
SET X=$ORDER(^(0))
DO DOW
SET I=Y+32
SET SM=X
SET D=Y
DO WM
+1 KILL J
FOR Y=0:1:6
IF $DATA(^SC(+SC,"T"_Y))
SET J(Y)=""
SET DA=+SC
SET DOW=Y
if '$DATA(^SC(+SC,"T"_Y,0))
DO TX^SDB1
+2 if '$DATA(J)
QUIT
X1 if X>ENDATE
QUIT
SET X1=X\100_28
W ;check beginning date, SD*5.3*674
SET X=X\1
IF '$DATA(^SC(+SC,"ST",X,1))
SET SDBDT=$ORDER(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1)
IF X>=($SELECT(SDBDT:SDBDT,1:9999999))
SET Y=D#7
if '$DATA(J(Y))
GOTO L
if $DATA(^HOLIDAY(X))&('SDSOH)
GOTO H
Begin DoDot:1
+1 SET SS=$ORDER(^SC(+SC,"T"_Y,X))
if SS=""
GOTO L
if ^(SS,1)=""
GOTO L
+2 ;SD*5.3*806
KILL SDST1
SET SDST1=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_^SC(+SC,"T"_Y,SS,1)
+3 DO SEND^SDTMPHLC(+SC,X\1,SDST1)
+4 ;SD*5.3*674
SET ^SC(+SC,"ST",X\1,1)=SDST1
SET ^(0)=X\1
End DoDot:1
+5 IF $DATA(SDXXX)
SET SDXXX=SDXXX+1
if '(SDXXX#100)
WRITE "."
+6 if X>SM
DO WM
L IF X>ENDATE
QUIT
+1 SET X=X+1
SET D=D+1
if X'>X1
GOTO W
SET X2=X-X1
DO C^%DTC
GOTO X1
+2 ;
H ;806
KILL SDST1
SET SDST1=" "_$EXTRACT(X,6,7)_" "_$PIECE($GET(^HOLIDAY(X,0)),U,2)
DO SEND^SDTMPHLC(+SC,X\1,SDST1)
SET ^SC(+SC,"ST",X,1)=SDST1
SET ^(0)=X
if '$DATA(^SC(+SC,"ST",0))
SET ^(0)="^44.005DA^^"
GOTO W
+1 ;
WM SET SM=$SELECT($EXTRACT(X,4,5)[12:$EXTRACT(X,1,3)+1_"01",1:$EXTRACT(X,1,3)_$EXTRACT(X,4,5)+1)_"00"
QUIT
+1 ;
DOW ;
+1 SET Y=$$DOW^XLFDT(X,1)
+2 QUIT
+3 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
