- 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 Mar 13, 2025@21:52:07 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
