SRSBOUT ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE ; [ 09/22/98 11:36 AM ]
;;3.0; Surgery ;**77,50,165**;24 Jun 93;Build 6
CNG S SRS1=$P(^SRS("R",SRSDAY,SRSOR,I,J),"^",3),EN1=$P(^(J),"^",4),SRS2=SRSST,EN2=SRSET
I (SRS1'<SRS2)&(SRS1<EN2)!((EN1>SRS2)&(EN1'>EN2))!((SRS2'<SRS1)&(SRS2<EN1)) I J=0!(SRSNUM=0)!((J<8)&(SRSNUM>5))!((J>5)&(SRSNUM<8))!(SRSNUM=J)!(((J=4)!(J=5)&(SRSNUM=4)!(SRSNUM=5))) D INT
Q
INT ; collision with service at the same time
S SRSSER1=^SRS("R",SRSDAY,SRSOR,I,J),STIME=$P(SRSSER1,"^",3),ETIME=$P(SRSSER1,"^",4),STIME=$E(STIME,1,2)_":"_$E(STIME,4,5),ETIME=$E(ETIME,1,2)_":"_$E(ETIME,4,5)
S SRSBANG=1 W !!,"Time collision with '"_$P(SRSSER1,"^",5)_"' which has reservations from "_STIME_" to "_ETIME_".",!
;;>>BEGIN 3*165-RJS
W:$G(SRBCHK(SRSDATE)) "The start date entered is not available for your ",SRSSER," Service Block.",!
W !,"I will search for available openings. Please wait."
N SRSDT S SRSDT=0 F S SRSDT=$O(SRBCHK(SRSDT)) Q:'SRSDT D
.I $G(SRBCHK(SRSDT)) W !,?5,$E(SRSDT,4,5),"-",$E(SRSDT,6,7),"-",$E(SRSDT,2,3)," is not available"
.I '$G(SRBCHK(SRSDT)) W !,?5,$E(SRSDT,4,5),"-",$E(SRSDT,6,7),"-",$E(SRSDT,2,3)," is available"
N DIR,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to use the available dates" D ^DIR Q:Y
S SRBFLG=1 W !!,"Your Service Block has not been set." ;;<<END 3*165-RJS
Q
S ; set up ^SRS
S ^SRS(SRSOR,"S",SRSDATE,1)=$E(SRSDATE,4,5)_"-"_$E(SRSDATE,6,7)_"-"_$E(SRSDATE,2,3)_" |____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|"
S ^SRS(SRSOR,"S",SRSDATE,0)=SRSDATE
I '$D(^SRS(SRSOR,"SS",SRSDATE,1)) S ^SRS(SRSOR,"SS",SRSDATE,1)=^SRS(SRSOR,"S",SRSDATE,1),^SRS(SRSOR,"SS",SRSDATE,0)=SRSDATE
Q
END W !!,"Press RETURN to continue " R X:DTIME
K SRBCHK,SRBFLG,SRBPRG,^TMP($J) ;; 3*165-RJS CLEANUP
D ^SRSKILL W @IOF
Q
MNTH ; one day each month
R !!,"Every month, last week of the month ? NO// ",Z1:DTIME I '$T!(Z1["^") S SRSOUT=1 Q
S Z1=$E(Z1) S:Z1="" Z1="N" S:$E(Z1)="y" Z1="Y" S:Z1["Y" Z=7
I "YyNn"'[Z1 W !!,"If this blockout should appear on the same day every month, on the last",!,"week of that month, enter 'YES'. Otherwise, enter RETURN." G MNTH
Q
SER ; select service
S SRBPRG=1 D CURRENT^SRSBUTL
R !!,"For what service ? (3-4 characters, do not use 'X' or '=') ",SRSSER:DTIME I '$T!(SRSSER["^") G END
I SRSSER="" G END
I SRSSER["=" W !!,"You service abbreviation cannot include the equal sign." G SER
I SRSSER'?3.4A W !!!,"Enter a 3 to 4 letter abbreviation for the service, i.e. card, gen, gi.",!! G SER
I SRSSER["X"!(SRSSER["x") W !!,"Your service abbreviation cannot include the letter 'X'." G SER
I $L(SRSSER)<3!($L(SRSSER)>4) W !!,"Abbreviation must be 3 to 4 characters. " G SER
F SRMM=1:1:$L(SRSSER) I $E(SRSSER,SRMM)?1U S SRSSER=$E(SRSSER,0,SRMM-1)_$C($A(SRSSER,SRMM)+32)_$E(SRSSER,SRMM+1,999)
ROOM ; select operating room
W !! K DIC S DIC="^SRS(",DIC(0)="QEAM",DIC("S")="I $$ORDIV^SROUTL0(+Y,$G(SRSITE(""DIV""))),('$P(^SRS(+Y,0),U,6))",DIC("A")="Select Operating Room: " D ^DIC K DIC G:Y'>0 END S SRSOR=+Y,SRBPRG=1
I $D(^SRS("SER",SRSSER,SRSOR)) W !!,?5,"A Service Block for """,SRSSER,""" already exists. Please try agian." G SER
DATE ; select date to begin
S %DT("A")="Select Starting Date: ",%DT="AEFX" W !! D ^%DT G:Y'>0 END S SRSDATE=Y I SRSDATE<DT W !!,"Past dates cannot be entered." G DATE
TIME ; select starting and ending times
S (SRSBANG,SRSOUT)=0 D ^SRSTIME I SRSOUT G END
;
PAT W !!,"1. Every week, same time ",!,"2. Every other week ",!,"3. Every month, same day of week & week of month " R !!,"Select Number: ",Z:DTIME I '$T!(Z["^") S SRSOUT=1 G END
I Z["?" D HELP G PAT
I Z<1!(Z>3) W !!,"Enter 1, 2, or 3." G PAT
I Z>2 S X1=SRSDATE,X2=$E(SRSDATE,1,5)_"01" D ^%DTC S Z=X\7+3
I Z>5 D MNTH Q:SRSOUT
S SRSNUM=$P("0^8^1^2^3^4^5","^",Z),X1=SRSDATE,X2=2830103 D ^%DTC S SRSDAY=$P("MO^TU^WE^TH^FR^SA^SU","^",X#7+1),Y=0 I SRSNUM=8 S:X#2 SRSNUM=9
S SRSST=$P(SRSTIME,"^"),SRSET=$P(SRSTIME,"^",2),SRSST=$E(SRSST,1,2)_"."_$E(SRSST,4,5),SRSET=$E(SRSET,1,2)_"."_$E(SRSET,4,5)
S SRBFLG=1 ;;>>BEGIN 3*165-RJS
D BLOCKED^SRSBUTL,CHK^SRSBUTL ;;<<END 3*165-RJS
S I="" F S I=$O(^SRS("R",SRSDAY,SRSOR,I)) Q:I=""!SRSBANG F J=0:1:9 I $D(^SRS("R",SRSDAY,SRSOR,I,J)) D CNG Q:SRSBANG
G:SRSBANG&SRBFLG END ;;<<3*165-RJS
W !!,"Updating Schedules...",!
MUL2 ;
K DIE,DR S DIE=131.7,DA=SRSOR,DR="8///"_SRSDAY,DR(2,131.703)="1///"_SRSSER,DR(3,131.704)="2////"_DUZ_";1///"_SRSST,DR(4,131.705)="2////"_SRSNUM_";1///"_SRSET D ^DIE K DR
S SRSBOUT=DUZ_"^"_SRSDAY_"0^"_$P(SRSTIME,"^")_"^"_$P(SRSTIME,"^",2)_"^"_SRSSER,X=0
I '$D(^SRS(SRSOR,"S",SRSDATE,1)) D S
D UPDATE
CK1 I SRSNUM=0 S X=7 D UPDATE G:X CK1
CK2 I SRSNUM>7 S X=14 D UPDATE G:X CK2
CK0 I SRSNUM>0,(SRSNUM<5) S X5=$E(SRSDATE,4,5),X1=SRSDATE,X2=7 D C^%DTC S SRSDATE=X G:$E(X,4,5)=X5 CK0
CK3 I SRSNUM>0,(SRSNUM<5) S X=SRSNUM-1*7 D UPDATE G:X CK0
CK5 I SRSNUM=5 S X1=SRSDATE,X2=21 D C^%DTC S SRSDATE=X
CK4 I SRSNUM=5 S X1=SRSDATE,X2=7,X5=$E(SRSDATE,4,5) D C^%DTC S SRSDATE=X G:$E(SRSDATE,4,5)=X5 CK4 S X=-7 D UPDATE G:X CK5
G END
UPDATE S X1=SRSDATE,X2=X D C^%DTC S SRSDATE=X D Q
.Q:$G(SRBCHK(SRSDATE))
.D:$D(^SRS(SRSOR,"S",SRSDATE)) PATRN^SRSUTL S X=1 S:$O(^SRS(SRSOR,"S",SRSDATE))="" X=0
Q
HELP W !!,"Enter '1' to create the blockout on the same day and time every week, '2' to",!,"create the blockout on the same day and time every other week, or '3' to "
W !,"create the blockout for the same day of the week and week of the month only."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRSBOUT 5569 printed Nov 22, 2024@17:56:54 Page 2
SRSBOUT ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE ; [ 09/22/98 11:36 AM ]
+1 ;;3.0; Surgery ;**77,50,165**;24 Jun 93;Build 6
CNG SET SRS1=$PIECE(^SRS("R",SRSDAY,SRSOR,I,J),"^",3)
SET EN1=$PIECE(^(J),"^",4)
SET SRS2=SRSST
SET EN2=SRSET
+1 IF (SRS1'<SRS2)&(SRS1<EN2)!((EN1>SRS2)&(EN1'>EN2))!((SRS2'<SRS1)&(SRS2<EN1))
IF J=0!(SRSNUM=0)!((J<8)&(SRSNUM>5))!((J>5)&(SRSNUM<8))!(SRSNUM=J)!(((J=4)!(J=5)&(SRSNUM=4)!(SRSNUM=5)))
DO INT
+2 QUIT
INT ; collision with service at the same time
+1 SET SRSSER1=^SRS("R",SRSDAY,SRSOR,I,J)
SET STIME=$PIECE(SRSSER1,"^",3)
SET ETIME=$PIECE(SRSSER1,"^",4)
SET STIME=$EXTRACT(STIME,1,2)_":"_$EXTRACT(STIME,4,5)
SET ETIME=$EXTRACT(ETIME,1,2)_":"_$EXTRACT(ETIME,4,5)
+2 SET SRSBANG=1
WRITE !!,"Time collision with '"_$PIECE(SRSSER1,"^",5)_"' which has reservations from "_STIME_" to "_ETIME_".",!
+3 ;;>>BEGIN 3*165-RJS
+4 if $GET(SRBCHK(SRSDATE))
WRITE "The start date entered is not available for your ",SRSSER," Service Block.",!
+5 WRITE !,"I will search for available openings. Please wait."
+6 NEW SRSDT
SET SRSDT=0
FOR
SET SRSDT=$ORDER(SRBCHK(SRSDT))
if 'SRSDT
QUIT
Begin DoDot:1
+7 IF $GET(SRBCHK(SRSDT))
WRITE !,?5,$EXTRACT(SRSDT,4,5),"-",$EXTRACT(SRSDT,6,7),"-",$EXTRACT(SRSDT,2,3)," is not available"
+8 IF '$GET(SRBCHK(SRSDT))
WRITE !,?5,$EXTRACT(SRSDT,4,5),"-",$EXTRACT(SRSDT,6,7),"-",$EXTRACT(SRSDT,2,3)," is available"
End DoDot:1
+9 NEW DIR,Y
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to use the available dates"
DO ^DIR
if Y
QUIT
+10 ;;<<END 3*165-RJS
SET SRBFLG=1
WRITE !!,"Your Service Block has not been set."
+11 QUIT
S ; set up ^SRS
+1 SET ^SRS(SRSOR,"S",SRSDATE,1)=$EXTRACT(SRSDATE,4,5)_"-"_$EXTRACT(SRSDATE,6,7)_"-"_$EXTRACT(SRSDATE,2,3)_" |____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|____|"
+2 SET ^SRS(SRSOR,"S",SRSDATE,0)=SRSDATE
+3 IF '$DATA(^SRS(SRSOR,"SS",SRSDATE,1))
SET ^SRS(SRSOR,"SS",SRSDATE,1)=^SRS(SRSOR,"S",SRSDATE,1)
SET ^SRS(SRSOR,"SS",SRSDATE,0)=SRSDATE
+4 QUIT
END WRITE !!,"Press RETURN to continue "
READ X:DTIME
+1 ;; 3*165-RJS CLEANUP
KILL SRBCHK,SRBFLG,SRBPRG,^TMP($JOB)
+2 DO ^SRSKILL
WRITE @IOF
+3 QUIT
MNTH ; one day each month
+1 READ !!,"Every month, last week of the month ? NO// ",Z1:DTIME
IF '$TEST!(Z1["^")
SET SRSOUT=1
QUIT
+2 SET Z1=$EXTRACT(Z1)
if Z1=""
SET Z1="N"
if $EXTRACT(Z1)="y"
SET Z1="Y"
if Z1["Y"
SET Z=7
+3 IF "YyNn"'[Z1
WRITE !!,"If this blockout should appear on the same day every month, on the last",!,"week of that month, enter 'YES'. Otherwise, enter RETURN."
GOTO MNTH
+4 QUIT
SER ; select service
+1 SET SRBPRG=1
DO CURRENT^SRSBUTL
+2 READ !!,"For what service ? (3-4 characters, do not use 'X' or '=') ",SRSSER:DTIME
IF '$TEST!(SRSSER["^")
GOTO END
+3 IF SRSSER=""
GOTO END
+4 IF SRSSER["="
WRITE !!,"You service abbreviation cannot include the equal sign."
GOTO SER
+5 IF SRSSER'?3.4A
WRITE !!!,"Enter a 3 to 4 letter abbreviation for the service, i.e. card, gen, gi.",!!
GOTO SER
+6 IF SRSSER["X"!(SRSSER["x")
WRITE !!,"Your service abbreviation cannot include the letter 'X'."
GOTO SER
+7 IF $LENGTH(SRSSER)<3!($LENGTH(SRSSER)>4)
WRITE !!,"Abbreviation must be 3 to 4 characters. "
GOTO SER
+8 FOR SRMM=1:1:$LENGTH(SRSSER)
IF $EXTRACT(SRSSER,SRMM)?1U
SET SRSSER=$EXTRACT(SRSSER,0,SRMM-1)_$CHAR($ASCII(SRSSER,SRMM)+32)_$EXTRACT(SRSSER,SRMM+1,999)
ROOM ; select operating room
+1 WRITE !!
KILL DIC
SET DIC="^SRS("
SET DIC(0)="QEAM"
SET DIC("S")="I $$ORDIV^SROUTL0(+Y,$G(SRSITE(""DIV""))),('$P(^SRS(+Y,0),U,6))"
SET DIC("A")="Select Operating Room: "
DO ^DIC
KILL DIC
if Y'>0
GOTO END
SET SRSOR=+Y
SET SRBPRG=1
+2 IF $DATA(^SRS("SER",SRSSER,SRSOR))
WRITE !!,?5,"A Service Block for """,SRSSER,""" already exists. Please try agian."
GOTO SER
DATE ; select date to begin
+1 SET %DT("A")="Select Starting Date: "
SET %DT="AEFX"
WRITE !!
DO ^%DT
if Y'>0
GOTO END
SET SRSDATE=Y
IF SRSDATE<DT
WRITE !!,"Past dates cannot be entered."
GOTO DATE
TIME ; select starting and ending times
+1 SET (SRSBANG,SRSOUT)=0
DO ^SRSTIME
IF SRSOUT
GOTO END
+2 ;
PAT WRITE !!,"1. Every week, same time ",!,"2. Every other week ",!,"3. Every month, same day of week & week of month "
READ !!,"Select Number: ",Z:DTIME
IF '$TEST!(Z["^")
SET SRSOUT=1
GOTO END
+1 IF Z["?"
DO HELP
GOTO PAT
+2 IF Z<1!(Z>3)
WRITE !!,"Enter 1, 2, or 3."
GOTO PAT
+3 IF Z>2
SET X1=SRSDATE
SET X2=$EXTRACT(SRSDATE,1,5)_"01"
DO ^%DTC
SET Z=X\7+3
+4 IF Z>5
DO MNTH
if SRSOUT
QUIT
+5 SET SRSNUM=$PIECE("0^8^1^2^3^4^5","^",Z)
SET X1=SRSDATE
SET X2=2830103
DO ^%DTC
SET SRSDAY=$PIECE("MO^TU^WE^TH^FR^SA^SU","^",X#7+1)
SET Y=0
IF SRSNUM=8
if X#2
SET SRSNUM=9
+6 SET SRSST=$PIECE(SRSTIME,"^")
SET SRSET=$PIECE(SRSTIME,"^",2)
SET SRSST=$EXTRACT(SRSST,1,2)_"."_$EXTRACT(SRSST,4,5)
SET SRSET=$EXTRACT(SRSET,1,2)_"."_$EXTRACT(SRSET,4,5)
+7 ;;>>BEGIN 3*165-RJS
SET SRBFLG=1
+8 ;;<<END 3*165-RJS
DO BLOCKED^SRSBUTL
DO CHK^SRSBUTL
+9 SET I=""
FOR
SET I=$ORDER(^SRS("R",SRSDAY,SRSOR,I))
if I=""!SRSBANG
QUIT
FOR J=0:1:9
IF $DATA(^SRS("R",SRSDAY,SRSOR,I,J))
DO CNG
if SRSBANG
QUIT
+10 ;;<<3*165-RJS
if SRSBANG&SRBFLG
GOTO END
+11 WRITE !!,"Updating Schedules...",!
MUL2 ;
+1 KILL DIE,DR
SET DIE=131.7
SET DA=SRSOR
SET DR="8///"_SRSDAY
SET DR(2,131.703)="1///"_SRSSER
SET DR(3,131.704)="2////"_DUZ_";1///"_SRSST
SET DR(4,131.705)="2////"_SRSNUM_";1///"_SRSET
DO ^DIE
KILL DR
+2 SET SRSBOUT=DUZ_"^"_SRSDAY_"0^"_$PIECE(SRSTIME,"^")_"^"_$PIECE(SRSTIME,"^",2)_"^"_SRSSER
SET X=0
+3 IF '$DATA(^SRS(SRSOR,"S",SRSDATE,1))
DO S
+4 DO UPDATE
CK1 IF SRSNUM=0
SET X=7
DO UPDATE
if X
GOTO CK1
CK2 IF SRSNUM>7
SET X=14
DO UPDATE
if X
GOTO CK2
CK0 IF SRSNUM>0
IF (SRSNUM<5)
SET X5=$EXTRACT(SRSDATE,4,5)
SET X1=SRSDATE
SET X2=7
DO C^%DTC
SET SRSDATE=X
if $EXTRACT(X,4,5)=X5
GOTO CK0
CK3 IF SRSNUM>0
IF (SRSNUM<5)
SET X=SRSNUM-1*7
DO UPDATE
if X
GOTO CK0
CK5 IF SRSNUM=5
SET X1=SRSDATE
SET X2=21
DO C^%DTC
SET SRSDATE=X
CK4 IF SRSNUM=5
SET X1=SRSDATE
SET X2=7
SET X5=$EXTRACT(SRSDATE,4,5)
DO C^%DTC
SET SRSDATE=X
if $EXTRACT(SRSDATE,4,5)=X5
GOTO CK4
SET X=-7
DO UPDATE
if X
GOTO CK5
+1 GOTO END
UPDATE SET X1=SRSDATE
SET X2=X
DO C^%DTC
SET SRSDATE=X
Begin DoDot:1
+1 if $GET(SRBCHK(SRSDATE))
QUIT
+2 if $DATA(^SRS(SRSOR,"S",SRSDATE))
DO PATRN^SRSUTL
SET X=1
if $ORDER(^SRS(SRSOR,"S",SRSDATE))=""
SET X=0
End DoDot:1
QUIT
+3 QUIT
HELP WRITE !!,"Enter '1' to create the blockout on the same day and time every week, '2' to",!,"create the blockout on the same day and time every other week, or '3' to "
+1 WRITE !,"create the blockout for the same day of the week and week of the month only."
+2 QUIT
