SDD0 ;SF/GFT,ALB/BOK,JSH,LDB,BWF - REMAP A CLINIC ;26 JAN 84 3:00 pm
;;5.3;Scheduling;**167,401,529,674,726,753,775,780,894**;Aug 13, 1993;Build 8
;;Per VHA Directive 6402, this routine should not be modified
SETX ;
N SDDIV
S SDDIV=$P($G(SD0),"^",15) Q:SDDIV=""
I '$D(VAUTD(SDDIV)),VAUTD=0 Q
Q:'$D(^SC(SC,"SL")) S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI
S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1)
K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y
N SDX,SDIEN,SDBEG,SDDOW,SDBEGO,SDBEGZ,SDHOLX ;New variables for SD*5.3*674 and SD*5.3*726 changes
;Set beginning date to use for indefinite clinic availabilities
F SDX=0:1:6 S SDDOW(SDX,9999999)="" ;SD*5.3*674
S SDBEGO="" F SDDAY=0:1:6 S SDCNT=0 F S SDCNT=$O(^SC(+SC,"T"_SDDAY,SDCNT)) Q:'SDCNT S SDBEGO=SDBEGO_U_SDCNT
S SDX=0 F S SDX=$O(^SC(SC,"T",SDX)) Q:'SDX!(SDX>ENDDATE) S SDBEGZ=$O(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999),-1) D ;Add SDBEGZ to check for duplicate OST entry
.I '$D(^SC(SC,"OST",SDX))!(SDBEGO[SDX)!(SDBEGZ=0)!($G(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999))=""&(SDBEGZ>0)) S SDBEG=$G(^SC(SC,"T",SDX,0),SDX) S SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)="" ;SD*5.3*674 and SD*5.3*726
F DATE=$$FMADD^XLFDT(SDBD,-1):0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED) I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK ;changed 1st part of For loop SD*529
Q
CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y
D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT
I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q
I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT
N SAVECAN S SAVECAN=""
I $D(^SC(SC,"ST",DATE,"CAN")) S SAVECAN=$G(^SC(SC,"ST",DATE,"CAN"))
K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G I
G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q
S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1)
HOLIDAY S SDHOLX=" "_$E(DATE,6,7)_" "_X ;set variable to the before image to compare it before sending HL7 message to TMP
I $G(^SC(SC,"ST",DATE,1))'=SDHOLX D EN^SDTMPHLC(SC,DATE,,"C",X) ;894 - send HL7 message to TMP if new holiday to be added
S ^SC(SC,"ST",DATE,1)=SDHOLX,^(0)=DATE
Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT
Q
END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q
FIX ;DH=PATTERN X=DATE
D SM G:('SDAPPT&('$D(^SC(SC,"S",DR,"MES")))) OVR ;SD*5.3*753, add check for canceled appointments
I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1)
I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR
F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C",((+$E($P(DR,".",2)_"000",1,4)>=($S($P($G(^SC(SC,"SL")),U,3)>0:+$P(^SC(SC,"SL"),U,3)_"00",1:800)))) D ;Ignore appts prior to Begin time, SD*5.3*726
.S SDSL=$P(^SC(SC,"S",DR,1,Y,0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$S("{}&%?#"[ST:ST,1:$E(STR,$F(STR,ST)-2))_$E(S,I+3,999) ;SD*5.3*775 - Correct overbooks >10
S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I
OVR I $L(SM)>SM,(X>=$O(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1)&($O(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1)))!($D(^SC(SC,"OST",X))) D
.S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=X S:$G(SAVECAN)]"" ^("CAN")=$G(SAVECAN) ;Verify indefinite schedule after start date, SD*5.3*674
G Z
SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q
APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q
F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT) S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0 I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1) Q:SDAPPT
Q
CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0)) S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y=""
F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X<ST:S_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:S)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(S="]":"",S="[":S,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
N SDIF S:'$F(I,"[") SDIF=$F(I,"X"),I=$E(I,1,(SDIF-2))_"["_$E(I,SDIF,999) ;SD*5.3*753 - Ensure "[" if all appointments canceled
S SM=I Q
TT S %=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2 Q
PRNT U IO S YP=YP+1 D:YP>(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q
ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDD0 5304 printed Sep 23, 2025@20:26:09 Page 2
SDD0 ;SF/GFT,ALB/BOK,JSH,LDB,BWF - REMAP A CLINIC ;26 JAN 84 3:00 pm
+1 ;;5.3;Scheduling;**167,401,529,674,726,753,775,780,894**;Aug 13, 1993;Build 8
+2 ;;Per VHA Directive 6402, this routine should not be modified
SETX ;
+1 NEW SDDIV
+2 SET SDDIV=$PIECE($GET(SD0),"^",15)
if SDDIV=""
QUIT
+3 IF '$DATA(VAUTD(SDDIV))
IF VAUTD=0
QUIT
+4 if '$DATA(^SC(SC,"SL"))
QUIT
SET SDSL=^("SL")
SET SL=+^("SL")
SET X=$PIECE(SDSL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET X=$PIECE(SDSL,U,6)
SET HSI=$SELECT('X:4,X<3:8/X,1:2)
SET SI=$SELECT(X:X,1:4)
SET SDSI=SI
+5 if SI=1
SET SI=4
if SI=2
SET SI=4
SET SDSOH=$SELECT($PIECE(SDSL,U,8)']"":0,1:1)
+6 KILL SDIN,SDRE,SDRE1
NEW SDNODE
IF $DATA(^SC(SC,"I"))
SET SDIN=+^("I")
SET SDRE=+$PIECE(^("I"),"^",2)
SET Y=SDRE
DO DTS^SDUTL
SET SDRE1=Y
+7 ;New variables for SD*5.3*674 and SD*5.3*726 changes
NEW SDX,SDIEN,SDBEG,SDDOW,SDBEGO,SDBEGZ,SDHOLX
+8 ;Set beginning date to use for indefinite clinic availabilities
+9 ;SD*5.3*674
FOR SDX=0:1:6
SET SDDOW(SDX,9999999)=""
+10 SET SDBEGO=""
FOR SDDAY=0:1:6
SET SDCNT=0
FOR
SET SDCNT=$ORDER(^SC(+SC,"T"_SDDAY,SDCNT))
if 'SDCNT
QUIT
SET SDBEGO=SDBEGO_U_SDCNT
+11 ;Add SDBEGZ to check for duplicate OST entry
SET SDX=0
FOR
SET SDX=$ORDER(^SC(SC,"T",SDX))
if 'SDX!(SDX>ENDDATE)
QUIT
SET SDBEGZ=$ORDER(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999),-1)
Begin DoDot:1
+12 ;SD*5.3*674 and SD*5.3*726
IF '$DATA(^SC(SC,"OST",SDX))!(SDBEGO[SDX)!(SDBEGZ=0)!($GET(^SC(+SC,"T"_$$DOW^XLFDT(SDX,1),9999999))=""&(SDBEGZ>0))
SET SDBEG=$GET(^SC(SC,"T",SDX,0),SDX)
SET SDDOW($$DOW^XLFDT(SDBEG,1),SDBEG)=""
End DoDot:1
+13 ;changed 1st part of For loop SD*529
FOR DATE=$$FMADD^XLFDT(SDBD,-1):0
SET X1=DATE
SET X2=1
NEW X
DO C^%DTC
SET DATE=X
SET SDNODE=$DATA(^SC(SC,"ST",DATE))
if DATE'>0!(DATE>SDED)
QUIT
IF $SELECT('$DATA(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0)
KILL SM,SDHOL
DO CHECK
+14 QUIT
CHECK SET X=DATE
DO DW^%DTC
SET DAY=$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1)
SET DOW=Y
+1 DO APPT
IF $DATA(^SC(SC,"ST",DATE,1))
IF ^(1)'[$EXTRACT(DAY,1,2)&(^(1)["]")
SET MSG="Bogus clinic day"_$SELECT(SDAPPT:"- Appts!",1:"")
DO PRNT
+2 IF $DATA(^SC(SC,"ST",DATE,1))
IF ^(1)["CANCEL"!($EXTRACT(^(1),$FIND(^(1),"["),999)?."X")
SET MSG="Cancelled"
DO PRNT
QUIT
+3 IF $DATA(^HOLIDAY(DATE,0))
IF 'SDSOH
SET SDHOL=1
SET X=$PIECE(^(0),U,2)
if 'SDAPPT
GOTO HOLIDAY
if SDAPPT
GOTO Z
+4 NEW SAVECAN
SET SAVECAN=""
+5 IF $DATA(^SC(SC,"ST",DATE,"CAN"))
SET SAVECAN=$GET(^SC(SC,"ST",DATE,"CAN"))
+6 KILL ^SC(SC,"ST",DATE)
SET SS=+$ORDER(^SC(SC,"T"_DOW,DATE))
SET SB=STARTDAY-1/100
SET STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
+7 IF $DATA(^SC(SC,"OST",DATE,1))
IF ^(1)]""
SET (X,DR)=DATE
DO DOW^SDM0
SET DOW=Y
SET SM=^SC(SC,"OST",DATE,1)
SET SS=0
GOTO I
+8 if '$DATA(^SC(SC,"T"_DOW,SS,1))
GOTO Z
IF ^(1)=""
SET MSG="no master pattern for this day"
if SDNODE
DO PRNT
QUIT
+9 ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1)
SET DH=^(1)
SET X=DATE
GOTO FIX
HOLIDAY ;set variable to the before image to compare it before sending HL7 message to TMP
SET SDHOLX=" "_$EXTRACT(DATE,6,7)_" "_X
+1 ;894 - send HL7 message to TMP if new holiday to be added
IF $GET(^SC(SC,"ST",DATE,1))'=SDHOLX
DO EN^SDTMPHLC(SC,DATE,,"C",X)
+2 SET ^SC(SC,"ST",DATE,1)=SDHOLX
SET ^(0)=DATE
Z SET MSG=$SELECT($DATA(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$DATA(SDHOL):"- Inserted",1:"")
IF MSG]""
SET MSG=X_MSG
DO PRNT
+1 QUIT
END KILL %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE
DO CLOSE^DGUTQ
QUIT
FIX ;DH=PATTERN X=DATE
+1 ;SD*5.3*753, add check for canceled appointments
DO SM
if ('SDAPPT&('$DATA(^SC(SC,"S",DR,"MES"))))
GOTO OVR
I SET I=DR#1-SB*100
SET I=I#1*SI\.6+(I\1*SI)*2
SET S=$EXTRACT(SM,I,999)
SET SM=$EXTRACT(SM,1,I-1)
+1 IF $DATA(^SC(SC,"S",DR,"MES"))
DO CAN
SET X=SDSAVX
KILL SDSAVX
SET DR=+$ORDER(^SC(SC,"S",DR))
if DR\1=X
GOTO I
GOTO OVR
+2 ;Ignore appts prior to Begin time, SD*5.3*726
FOR Y=0:0
SET Y=$ORDER(^SC(SC,"S",DR,1,Y))
if Y'>0
QUIT
IF $PIECE(^(Y,0),"^",9)'["C"
IF ((+$EXTRACT($PIECE(DR,".",2)_"000",1,4)>=($SELECT($PIECE($GET(^SC(SC,"SL")),U,3)>0:+$PIECE(^SC(SC,"SL"),U,3)_"00",1:800))))
Begin DoDot:1
+3 ;SD*5.3*775 - Correct overbooks >10
SET SDSL=$PIECE(^SC(SC,"S",DR,1,Y,0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI
FOR I=0:HSI:SDSL
SET ST=$EXTRACT(S,I+2)
if ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I+2-1)_$SELECT("{}&%?#"[ST:ST,1:$EXTRACT(STR,$FIND(STR,ST)-2))_$EXTRACT(S,I+3,999)
End DoDot:1
+4 SET SM=SM_S
SET DR=$ORDER(^SC(SC,"S",DR))
IF DR\1=X
GOTO I
OVR IF $LENGTH(SM)>SM
IF (X>=$ORDER(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1)&($ORDER(SDDOW($$DOW^XLFDT(X,1),(X+1)),-1)))!($DATA(^SC(SC,"OST",X)))
Begin DoDot:1
+1 ;Verify indefinite schedule after start date, SD*5.3*674
SET ^SC(SC,"ST",X,0)=X
SET ^(1)=SM
if SS'>0
SET ^(9)=X
if $GET(SAVECAN)]""
SET ^("CAN")=$GET(SAVECAN)
End DoDot:1
+2 GOTO Z
SM SET SM=$PIECE("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_DH_$JUSTIFY("",64-$LENGTH(DH))
QUIT
APPT SET DR=+$ORDER(^SC(SC,"S",DATE))
SET SDAPPT=0
IF DR>(DATE_.9)
SET DR=DATE
QUIT
+1 FOR DR1=DATE:0
SET DR1=$ORDER(^SC(SC,"S",DR1))
if DR1'>0!(DR1>(DATE+1))!(SDAPPT)
QUIT
if $DATA(^(DR1,"MES"))
SET SDAPPT=1
FOR SDAPPT1=0:0
SET SDAPPT1=$ORDER(^SC(SC,"S",DR1,1,SDAPPT1))
if SDAPPT1'>0
QUIT
IF $DATA(^(SDAPPT1,0))
SET SDAPPT=$SELECT($PIECE(^(0),"^",9)="C":0,1:1)
if SDAPPT
QUIT
+2 QUIT
CAN SET SDSAVX=X
if '$DATA(^SC(SC,"SDCAN",DR,0))
QUIT
SET X=$EXTRACT($PIECE(DR,".",2)_"0000",1,4)
SET I=SM_S
DO TT
SET ST=%
SET X=$PIECE(^SC(SC,"SDCAN",DR,0),"^",2)
DO TT
SET I=I_$JUSTIFY("",%-$LENGTH(I))
SET Y=""
+1 FOR X=0:2:%
SET S=$EXTRACT(I,X+SI+SI)
SET P=$SELECT(X<ST:S_$EXTRACT(I,X+1+SI+SI),X=%:$SELECT(Y="[":Y,1:S)_$EXTRACT(I,X+1+SI+SI),1:$SELECT(Y="["&(X=ST):"]",1:"X")_"X")
SET Y=$SELECT(S="]":"",S="[":S,1:Y)
SET I=$EXTRACT(I,1,X-1+SI+SI)_P_$EXTRACT(I,X+2+SI+SI,999)
+2 ;SD*5.3*753 - Ensure "[" if all appointments canceled
NEW SDIF
if '$FIND(I,"[")
SET SDIF=$FIND(I,"X")
SET I=$EXTRACT(I,1,(SDIF-2))_"["_$EXTRACT(I,SDIF,999)
+3 SET SM=I
QUIT
TT SET %=$EXTRACT(X,3,4)
SET %=X\100-STARTDAY*SI+(%*SI\60)*2
QUIT
PRNT USE IO
SET YP=YP+1
if YP>(IOSL-4)
DO ESC^SDD
WRITE !,$EXTRACT(SDNM,1,25),?27,$EXTRACT(DAY,1,3)_" "
SET Y=DATE
DO DT^DIO2
WRITE ?45,MSG
QUIT
ESC SET SDU=0
IF $EXTRACT(IOST,1,2)="C-"
WRITE *7
READ ESC:DTIME
if U=ESC
SET SDU=1
