SRSBOUT ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE ; [ 09/22/98 11:36 AM ]
;;3.0; Surgery ;**77,50**;24 Jun 93
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_".",!
W !!,"Press RETURN to continue " R X:DTIME 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 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
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
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 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 END
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:$D(^SRS(SRSOR,"S",SRSDATE)) PATRN^SRSUTL S X=1 S:$O(^SRS(SRSOR,"S",SRSDATE))="" X=0 Q
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
SRSBOUT ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE ; [ 09/22/98 11:36 AM ]
+1 ;;3.0; Surgery ;**77,50**;24 Jun 93
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 WRITE !!,"Press RETURN to continue "
READ X:DTIME
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 DO ^SRSKILL
WRITE @IOF
+1 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 READ !!,"For what service ? (3-4 characters, do not use 'X' or '=') ",SRSSER:DTIME
IF '$TEST!(SRSSER["^")
GOTO END
+2 IF SRSSER=""
GOTO END
+3 IF SRSSER["="
WRITE !!,"You service abbreviation cannot include the equal sign."
GOTO SER
+4 IF SRSSER'?3.4A
WRITE !!!,"Enter a 3 to 4 letter abbreviation for the service, i.e. card, gen, gi.",!!
GOTO SER
+5 IF SRSSER["X"!(SRSSER["x")
WRITE !!,"Your service abbreviation cannot include the letter 'X'."
GOTO SER
+6 IF $LENGTH(SRSSER)<3!($LENGTH(SRSSER)>4)
WRITE !!,"Abbreviation must be 3 to 4 characters. "
GOTO SER
+7 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
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 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
+8 IF SRSBANG
GOTO END
+9 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
IF $DATA(^SRS(SRSOR,"S",SRSDATE))
DO PATRN^SRSUTL
SET X=1
IF $ORDER(^SRS(SRSOR,"S",SRSDATE))=""
SET X=0
QUIT
+1 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
