- 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
