- SDB1 ;ALB/GRR,BWF,BLB - SET UP A CLINIC ;MAY 22, 2023
- ;;5.3;Scheduling;**20,183,221,567,627,726,775,806,843,861**;Aug 13, 1993;Build 17
- ;;Per VHA Directive 6402, this routine should not be modified
- ;
- ;DH=PATTERN DO=EXPIRATION DATE X=START DATE
- B1 S DR=0,SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDONE=1
- N SDX,SDSL,SL,SI,SDSI,SDSOH,STARTDAY,HSI
- SETX Q:'$D(^SC(DA,"SL")) S SDSL=^("SL"),SL=+^("SL"),SDX=$P(SDSL,U,3),STARTDAY=$S($L(SDX):SDX,1:8),SDX=$P(SDSL,U,6),HSI=$S('SDX:4,SDX<3:8/SDX,1:2),SI=$S(SDX:SDX,1:4),SDSI=SI S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1)
- X I X'>DO,$G(^SC(DA,"ST",X,1))["**CANCELLED**"!($G(^SC(DA,"ST",X,1))["X") S ^TMP("SDAVAIL",$J,X)=^(1)
- Q:(X'<DO)!(X'<(DT+50000)) I $D(^SC(DA,"ST",X,9)) S DR=X,SDSAV=0 G SM
- D SEND^SDTMPHLC(DA,X,"") K ^SC(DA,"ST",X) I DR<0,'$O(^(X)) Q
- G X2:X+1<DR
- S DR=+$O(^SC(DA,"S",X)),SDSAV=0 G X2:DR\1-X
- 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)) S:'SDSAV SDSAV=1,SDPAT=SM
- 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)
- F Y=0:0 S Y=$O(^SC(DA,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C",((+$E($P(DR,".",2)_"000",1,4)>=($S($P($G(^SC(DA,"SL")),U,3)>0:+$P(^SC(DA,"SL"),U,3)_"00",1:800)))) D ;Ignore appts prior to Begin time, SD*5.3*726
- .S SDSL=$P(^SC(DA,"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) D OB ;SD*5.3*775 - Correct overbooks >10
- S SM=SM_S,DR=+$O(^SC(DA,"S",DR)) I DR\1=X G I
- I $L(SM)>SM D SEND^SDTMPHLC(DA,X,SM) S ^SC(DA,"ST",X,0)=X,^(1)=SM S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" I $D(^SC(DA,"ST",X,9)) S ^SC(DA,"OST",X,1)=SDPAT,^(0)=X S:'$D(^SC(DA,"OST",0)) ^(0)="^44.0002DA^^" ;806
- N SDCNT F SDCAN=X:0 S SDCAN=$O(^SC(DA,"SDCAN",SDCAN)) Q:(SDCAN\1-(X\1))!'SDCAN D ;SD*5.3*726 - Update subfile counter and remove "MES" node when removing "SDCAN" node
- .K ^SC(DA,"SDCAN",SDCAN),^SC(DA,"S",SDCAN,"MES") I $D(^SC(DA,"SDCAN",0)) S SDCNT=$P(^(0),U,4),SDCNT=$S(SDCNT>0:SDCNT-1,1:0),^(0)=$P(^(0),U,1,3)_U_SDCNT
- X2 I X#100<22 S X=X+7
- E S X1=X,X2=7 D C^%DTC
- G X
- ;
- DEL1 S (DH,DO,X)="" W !,*7,*7,"DELETE " S SDEL=1
- D I $D(SDIN),SDIN>D0 S SDRE1=$S(SDRE:SDRE,1:9999999)
- W $P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAYS " S DH=X,OK=0,CTR=0
- S SDSOH=$S('$D(^SC(DA,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1)
- F X=D0:0 S X=+$O(^SC(DA,"T",X)) Q:X'>0 D DOW^SDM0 I Y=DOW S Y=X,DO=Y W "UNTIL " D DT^DIO2 G R
- I X'>0,$D(SDIN),SDIN>D0 S SDRE1=$S(SDRE=0:9999999,1:SDRE) S X=SDIN F I=0:1:6 D DOW^SDM0 S:Y=DOW OK=1 Q:OK S X1=X,X2=1 D C^%DTC Q:X>SDRE1
- I OK S Y=X,DO=D0 W " UNTIL " D DT^DIO2 G R
- S DO=9999999 W "INDEFINITELY"
- R K OK S %="" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G R
- EN1 S D=D0 G 1:((%-1)>0),G1^SDB:%<0
- S Y="" I '$D(^SC(DA,"T"_DOW,D0,1)) S Y=+$O(^SC(DA,"T"_DOW,D0)) I Y>D0 S X=^(Y,1),POP=0 D CHK1 K:'POP ^SC(DA,"T"_DOW,Y) S ^SC(DA,"T"_DOW,D0,1)=X,^(0)=D0 D TX
- I Y<0,'$D(^SC(DA,"T"_DOW,D0)) S ^(D0,1)="",^(0)=D0 D TX
- S ^SC(DA,"T"_DOW,DO,1)=DH,^(0)=DO D TX
- S X=D0 D B1 S MAX=$$DAYSINFUTURE(DA,SD),SC=DA,SDSTRTDT=SD G:'CNT G1^SDB D WAIT^DICD,OVR^SDAUT1 W !,"PATTERN FILED!",! Q:'SDZQ G G1^SDB
- ;
- DAYSINFUTURE(CLINICIEN,STARTDATE) ;
- N FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
- ;
- S FUTUREBOOKINGNUM=$S($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
- S FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
- S HOLIDAYFILEDATE="",HOLIDAYFILEDATE=$O(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
- ;
- I FUTUREBOOKDATE<HOLIDAYFILEDATE Q FUTUREBOOKINGNUM
- Q $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
- ;
- 1 I SDEL S POP=0 D APPCK I POP D DELERR G OVR
- 11 G:$D(^HOLIDAY(D,0))&('SDSOH) OVR S POP=0 D:$D(SDIN) CHK2 G:POP OVR W !,"...FOR " S Y=D D DT^DIO2 S %=2 D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G 11
- I %<0 D ;alb/sat 627
- .D SDRES^SDECUTL2(DA)
- G G1^SDB:(%<0) I (%-1) G OVR
- S (POP,SDREB)=0 D APPCK I POP D APPERR G:(%-1) OVR S SDREB=1
- W " ...OK" S X=D,DO=X+1,^SC(DA,"ST",X,9)=D,SDREACT=1 S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" D B1 ;SD*567 change set of 9 node to selected date
- OVR I D#100<22 S D=D+7 S POP=0 D:$D(SDIN) CHK2 G G1^SDB:POP=1,1
- S X1=D,X2=7 D C^%DTC S D=X S POP=0 D:$D(SDIN) CHK2 G G1^SDB:POP=1,1
- ;
- APPCK F A=D:0 S A=+$O(^SC(DA,"S",A)) Q:A'>0!(A\1-D) F SDA1=0:0 S SDA1=+$O(^SC(DA,"S",A,1,SDA1)) Q:SDA1'>0 I $P(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C" S POP=1 Q
- Q
- APPERR W *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY" S %=2 D YN^DICN
- I '% W !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO" G APPERR
- Q
- DELERR S Y=D W !,"... " D DT^DIQ W " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED" Q
- CHK1 Q:'$D(SDIN)
- I Y=SDIN S POP=1
- Q
- ;
- CHK2 I SDIN<D,SDRE,SDRE'>D K SDIN Q
- I SDIN<D,SDRE=0 S POP=1 Q
- I SDIN<D,SDRE>D S POP=2,D=SDRE,X=D F I=0:1:6 D DOW^SDM0 Q:Y=DOW S X1=D,X2=1 D C^%DTC S D=X
- S Y=SDIN D DTS^SDUTL S Y1=Y,Y=SDRE1 D DTS^SDUTL W:POP=2&('CTR) !!," Clinic is inactive from ",Y1," to ",Y,! S:POP=2 CTR=1
- Q
- OB S SDSLOT=$S("{}&%?#"[ST:ST,1:$E(STR,$F(STR,ST)-2)) I SDSLOT?1P,SDSLOT'?1" " S ^SC(DA,"S",DR,1,Y,"OB")="O" K SDSLOT Q ;SD*5.3*775 - Correct overbooks >10
- K ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT Q
- HLPD W !,"ENTER THE DATE THIS CLINIC BECOMES AVAILABLE TO SEE PATIENTS"
- W !,"THE DATE ENTERED WILL BE THE FIRST DATE THAT APPOINTMENTS CAN",!,"BE MADE FOR THIS CLINIC" G G1^SDB
- TX S:'$D(^SC(DA,"T"_DOW,0)) ^(0)="^44.0"_$S(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDB1 5698 printed Feb 19, 2025@00:15:03 Page 2
- SDB1 ;ALB/GRR,BWF,BLB - SET UP A CLINIC ;MAY 22, 2023
- +1 ;;5.3;Scheduling;**20,183,221,567,627,726,775,806,843,861**;Aug 13, 1993;Build 17
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 ;
- +4 ;DH=PATTERN DO=EXPIRATION DATE X=START DATE
- B1 SET DR=0
- SET SB=STARTDAY-1/100
- SET STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
- SET SDONE=1
- +1 NEW SDX,SDSL,SL,SI,SDSI,SDSOH,STARTDAY,HSI
- SETX if '$DATA(^SC(DA,"SL"))
- QUIT
- SET SDSL=^("SL")
- SET SL=+^("SL")
- SET SDX=$PIECE(SDSL,U,3)
- SET STARTDAY=$SELECT($LENGTH(SDX):SDX,1:8)
- SET SDX=$PIECE(SDSL,U,6)
- SET HSI=$SELECT('SDX:4,SDX<3:8/SDX,1:2)
- SET SI=$SELECT(SDX:SDX,1:4)
- SET SDSI=SI
- if SI=1
- SET SI=4
- if SI=2
- SET SI=4
- SET SDSOH=$SELECT($PIECE(SDSL,U,8)']"":0,1:1)
- X IF X'>DO
- IF $GET(^SC(DA,"ST",X,1))["**CANCELLED**"!($GET(^SC(DA,"ST",X,1))["X")
- SET ^TMP("SDAVAIL",$JOB,X)=^(1)
- +1 if (X'<DO)!(X'<(DT+50000))
- QUIT
- IF $DATA(^SC(DA,"ST",X,9))
- SET DR=X
- SET SDSAV=0
- GOTO SM
- +2 DO SEND^SDTMPHLC(DA,X,"")
- KILL ^SC(DA,"ST",X)
- IF DR<0
- IF '$ORDER(^(X))
- QUIT
- +3 if X+1<DR
- GOTO X2
- +4 SET DR=+$ORDER(^SC(DA,"S",X))
- SET SDSAV=0
- if DR\1-X
- GOTO X2
- 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))
- if 'SDSAV
- SET SDSAV=1
- SET SDPAT=SM
- 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 ;Ignore appts prior to Begin time, SD*5.3*726
- FOR Y=0:0
- SET Y=$ORDER(^SC(DA,"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(DA,"SL")),U,3)>0:+$PIECE(^SC(DA,"SL"),U,3)_"00",1:800))))
- Begin DoDot:1
- +2 ;SD*5.3*775 - Correct overbooks >10
- SET SDSL=$PIECE(^SC(DA,"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)
- DO OB
- End DoDot:1
- +3 SET SM=SM_S
- SET DR=+$ORDER(^SC(DA,"S",DR))
- IF DR\1=X
- GOTO I
- +4 ;806
- IF $LENGTH(SM)>SM
- DO SEND^SDTMPHLC(DA,X,SM)
- SET ^SC(DA,"ST",X,0)=X
- SET ^(1)=SM
- if '$DATA(^SC(DA,"ST",0))
- SET ^(0)="^44.005DA^^"
- IF $DATA(^SC(DA,"ST",X,9))
- SET ^SC(DA,"OST",X,1)=SDPAT
- SET ^(0)=X
- if '$DATA(^SC(DA,"OST",0))
- SET ^(0)="^44.0002DA^^"
- +5 ;SD*5.3*726 - Update subfile counter and remove "MES" node when removing "SDCAN" node
- NEW SDCNT
- FOR SDCAN=X:0
- SET SDCAN=$ORDER(^SC(DA,"SDCAN",SDCAN))
- if (SDCAN\1-(X\1))!'SDCAN
- QUIT
- Begin DoDot:1
- +6 KILL ^SC(DA,"SDCAN",SDCAN),^SC(DA,"S",SDCAN,"MES")
- IF $DATA(^SC(DA,"SDCAN",0))
- SET SDCNT=$PIECE(^(0),U,4)
- SET SDCNT=$SELECT(SDCNT>0:SDCNT-1,1:0)
- SET ^(0)=$PIECE(^(0),U,1,3)_U_SDCNT
- End DoDot:1
- X2 IF X#100<22
- SET X=X+7
- +1 IF '$TEST
- SET X1=X
- SET X2=7
- DO C^%DTC
- +2 GOTO X
- +3 ;
- DEL1 SET (DH,DO,X)=""
- WRITE !,*7,*7,"DELETE "
- SET SDEL=1
- D IF $DATA(SDIN)
- IF SDIN>D0
- SET SDRE1=$SELECT(SDRE:SDRE,1:9999999)
- +1 WRITE $PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAYS "
- SET DH=X
- SET OK=0
- SET CTR=0
- +2 SET SDSOH=$SELECT('$DATA(^SC(DA,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
- +3 FOR X=D0:0
- SET X=+$ORDER(^SC(DA,"T",X))
- if X'>0
- QUIT
- DO DOW^SDM0
- IF Y=DOW
- SET Y=X
- SET DO=Y
- WRITE "UNTIL "
- DO DT^DIO2
- GOTO R
- +4 IF X'>0
- IF $DATA(SDIN)
- IF SDIN>D0
- SET SDRE1=$SELECT(SDRE=0:9999999,1:SDRE)
- SET X=SDIN
- FOR I=0:1:6
- DO DOW^SDM0
- if Y=DOW
- SET OK=1
- if OK
- QUIT
- SET X1=X
- SET X2=1
- DO C^%DTC
- if X>SDRE1
- QUIT
- +5 IF OK
- SET Y=X
- SET DO=D0
- WRITE " UNTIL "
- DO DT^DIO2
- GOTO R
- +6 SET DO=9999999
- WRITE "INDEFINITELY"
- R KILL OK
- SET %=""
- DO YN^DICN
- IF '%
- WRITE !,"REPLY YES (Y) OR NO (N)"
- GOTO R
- EN1 SET D=D0
- if ((%-1)>0)
- GOTO 1
- if %<0
- GOTO G1^SDB
- +1 SET Y=""
- IF '$DATA(^SC(DA,"T"_DOW,D0,1))
- SET Y=+$ORDER(^SC(DA,"T"_DOW,D0))
- IF Y>D0
- SET X=^(Y,1)
- SET POP=0
- DO CHK1
- if 'POP
- KILL ^SC(DA,"T"_DOW,Y)
- SET ^SC(DA,"T"_DOW,D0,1)=X
- SET ^(0)=D0
- DO TX
- +2 IF Y<0
- IF '$DATA(^SC(DA,"T"_DOW,D0))
- SET ^(D0,1)=""
- SET ^(0)=D0
- DO TX
- +3 SET ^SC(DA,"T"_DOW,DO,1)=DH
- SET ^(0)=DO
- DO TX
- +4 SET X=D0
- DO B1
- SET MAX=$$DAYSINFUTURE(DA,SD)
- SET SC=DA
- SET SDSTRTDT=SD
- if 'CNT
- GOTO G1^SDB
- DO WAIT^DICD
- DO OVR^SDAUT1
- WRITE !,"PATTERN FILED!",!
- if 'SDZQ
- QUIT
- GOTO G1^SDB
- +5 ;
- DAYSINFUTURE(CLINICIEN,STARTDATE) ;
- +1 NEW FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
- +2 ;
- +3 SET FUTUREBOOKINGNUM=$SELECT($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
- +4 SET FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
- +5 SET HOLIDAYFILEDATE=""
- SET HOLIDAYFILEDATE=$ORDER(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
- +6 ;
- +7 IF FUTUREBOOKDATE<HOLIDAYFILEDATE
- QUIT FUTUREBOOKINGNUM
- +8 QUIT $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
- +9 ;
- 1 IF SDEL
- SET POP=0
- DO APPCK
- IF POP
- DO DELERR
- GOTO OVR
- 11 if $DATA(^HOLIDAY(D,0))&('SDSOH)
- GOTO OVR
- SET POP=0
- if $DATA(SDIN)
- DO CHK2
- if POP
- GOTO OVR
- WRITE !,"...FOR "
- SET Y=D
- DO DT^DIO2
- SET %=2
- DO YN^DICN
- IF '%
- WRITE !,"REPLY YES (Y) OR NO (N)"
- GOTO 11
- +1 ;alb/sat 627
- IF %<0
- Begin DoDot:1
- +2 DO SDRES^SDECUTL2(DA)
- End DoDot:1
- +3 if (%<0)
- GOTO G1^SDB
- IF (%-1)
- GOTO OVR
- +4 SET (POP,SDREB)=0
- DO APPCK
- IF POP
- DO APPERR
- if (%-1)
- GOTO OVR
- SET SDREB=1
- +5 ;SD*567 change set of 9 node to selected date
- WRITE " ...OK"
- SET X=D
- SET DO=X+1
- SET ^SC(DA,"ST",X,9)=D
- SET SDREACT=1
- if '$DATA(^SC(DA,"ST",0))
- SET ^(0)="^44.005DA^^"
- DO B1
- OVR IF D#100<22
- SET D=D+7
- SET POP=0
- if $DATA(SDIN)
- DO CHK2
- if POP=1
- GOTO G1^SDB
- GOTO 1
- +1 SET X1=D
- SET X2=7
- DO C^%DTC
- SET D=X
- SET POP=0
- if $DATA(SDIN)
- DO CHK2
- if POP=1
- GOTO G1^SDB
- GOTO 1
- +2 ;
- APPCK FOR A=D:0
- SET A=+$ORDER(^SC(DA,"S",A))
- if A'>0!(A\1-D)
- QUIT
- FOR SDA1=0:0
- SET SDA1=+$ORDER(^SC(DA,"S",A,1,SDA1))
- if SDA1'>0
- QUIT
- IF $PIECE(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C"
- SET POP=1
- QUIT
- +1 QUIT
- APPERR WRITE *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY"
- SET %=2
- DO YN^DICN
- +1 IF '%
- WRITE !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO"
- GOTO APPERR
- +2 QUIT
- DELERR SET Y=D
- WRITE !,"... "
- DO DT^DIQ
- WRITE " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED"
- QUIT
- CHK1 if '$DATA(SDIN)
- QUIT
- +1 IF Y=SDIN
- SET POP=1
- +2 QUIT
- +3 ;
- CHK2 IF SDIN<D
- IF SDRE
- IF SDRE'>D
- KILL SDIN
- QUIT
- +1 IF SDIN<D
- IF SDRE=0
- SET POP=1
- QUIT
- +2 IF SDIN<D
- IF SDRE>D
- SET POP=2
- SET D=SDRE
- SET X=D
- FOR I=0:1:6
- DO DOW^SDM0
- if Y=DOW
- QUIT
- SET X1=D
- SET X2=1
- DO C^%DTC
- SET D=X
- +3 SET Y=SDIN
- DO DTS^SDUTL
- SET Y1=Y
- SET Y=SDRE1
- DO DTS^SDUTL
- if POP=2&('CTR)
- WRITE !!," Clinic is inactive from ",Y1," to ",Y,!
- if POP=2
- SET CTR=1
- +4 QUIT
- OB ;SD*5.3*775 - Correct overbooks >10
- SET SDSLOT=$SELECT("{}&%?#"[ST:ST,1:$EXTRACT(STR,$FIND(STR,ST)-2))
- IF SDSLOT?1P
- IF SDSLOT'?1" "
- SET ^SC(DA,"S",DR,1,Y,"OB")="O"
- KILL SDSLOT
- QUIT
- +1 KILL ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
- QUIT
- HLPD WRITE !,"ENTER THE DATE THIS CLINIC BECOMES AVAILABLE TO SEE PATIENTS"
- +1 WRITE !,"THE DATE ENTERED WILL BE THE FIRST DATE THAT APPOINTMENTS CAN",!,"BE MADE FOR THIS CLINIC"
- GOTO G1^SDB
- TX if '$DATA(^SC(DA,"T"_DOW,0))
- SET ^(0)="^44.0"_$SELECT(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^"
- QUIT