SRSBUTL ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE UTILITY; [ 08/14/09 11:36 AM ]
;;3.0; Surgery ;**165**;24 Jun 93;Build 6
BLOCKED ; find blocked OPERATING ROOMS
S SRBDT=DT,SRBCNT=0,SRBOR=SRSOR,SRBDAY=SRSDAY
S X1=SRBDT,X2=-1 D C^%DTC S SRBDT=X
F S SRBDT=$O(^SRS(SRBOR,"S",SRBDT)) Q:SRBDT="" D
.S SRBCNT=SRBCNT+1
.Q:'$D(^SRS(SRBOR,"S",SRBDT,1))
.S SRBST=""
.F S SRBST=$O(^SRS("R",SRBDAY,SRBOR,SRBST)) Q:SRBST="" D
..S SRBN=""
..F S SRBN=$O(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN)) Q:SRBN="" D
...S SRBET=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",4)
...S SRBSERV=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",5)
...S SRB1=+SRBST,SRB2=+SRBET
...D PTRNALG ; algorithm for setting start and end of pattern
...S SRBNUM=$S(SRBN=0:3,SRBN>7&(SRBN<10):2,1:1)
...I $G(^SRS(SRBOR,"S",SRBDT,1))[SRBS S ^TMP($J,"SRSBOUT",SRBDT,SRBNUM,SRBST)=SRBSERV_"^"_SRBN_"^"_SRBET
K SRB1,SRB2,SRBCNT,SRBDAY,SRBDT,SRBET,SRBI,SRBNUM,SRBN,SRBS,SRBSERV,SRBST,X,X1,X2
Q
CHK ;; CHECK FOR EXISTING BLOCKS
S SRBOR=SRSOR,SRBDT=SRSDATE,SRBTIME=SRSTIME,SRBNUM=SRSNUM
S SRB1=$P(SRBTIME,"^"),SRB2=$P(SRBTIME,"^",2),SRB1=$E(SRB1,1,2)_"."_$E(SRB1,4,5),SRB2=$E(SRB2,1,2)_"."_$E(SRB2,4,5)
S SRBEN1=SRB1,SRBEN2=SRB2,SRBFLG=1,X=0 D CHKD
CK1 I SRBNUM=0 S X=7 D CHKD G:X CK1
CK2 I SRBNUM>7 S X=14 D CHKD G:X CK2
CK0 I SRBNUM>0,(SRBNUM<5) S X5=$E(SRBDT,4,5),X1=SRBDT,X2=7 D C^%DTC S SRBDT=X G:$E(X,4,5)=X5 CK0
CK3 I SRBNUM>0,(SRBNUM<5) S X=SRBNUM-1*7 D CHKD G:X CK0
CK5 I SRBNUM=5 S X1=SRBDT,X2=21 D C^%DTC S SRBDT=X
CK4 I SRBNUM=5 S X1=SRBDT,X2=7,X5=$E(SRBDT,4,5) D C^%DTC S SRBDT=X G:$E(SRBDT,4,5)=X5 CK4 S X=-7 D CHKD G:X CK5
END S SRBDT="" F S SRBDT=$O(SRBCHK(SRBDT)) Q:'SRBDT S:SRBCHK(SRBDT)=0 SRBFLG=0
K SRB1,SRB2,SRBDT,SRBEN1,SRBEN2,SRBNMB,SRBNUM,SRBST,SRBET,SRBTIME,X5
Q
CHKD S X1=SRBDT,X2=X D C^%DTC S SRBDT=X
S:'$G(^SRS(SRBOR,"S",SRBDT,0)) X=0
S SRBCHK(SRBDT)=0
I $D(^TMP($J,"SRSBOUT",SRBDT)) D
.S SRBNMB=""
.F S SRBNMB=$O(^TMP($J,"SRSBOUT",SRBDT,SRBNMB)) Q:'SRBNMB D
..S (SRBST,SRBET)=""
..F S SRBST=$O(^TMP($J,"SRSBOUT",SRBDT,SRBNMB,SRBST)) Q:'SRBST D
...S SRBET=$P(^TMP($J,"SRSBOUT",SRBDT,SRBNMB,SRBST),"^",3)
...I (SRBST'<SRBEN1)&(SRBST<SRBEN2)!((SRBET>SRBEN1)&(SRBET'>SRBEN2))!((SRBEN1'<SRBST)&(SRBEN1<SRBET)) S SRBCHK(SRBDT)=1
Q
DIS1 ;CHECK AND SET NEW SERVICE BLOCK
S SRBOR=SROR,SRBDT=SRSDATE
S X1=SRBDT,X2=2830103 D ^%DTC S SRBDAY=$P("MO^TU^WE^TH^FR^SA^SU","^",X#7+1),X3=X#2+8 S X1=SRBDT,X2=$E(SRBDT,1,5)_"01" D ^%DTC S SRBDY=X\7+1
S:'$G(SRBSER1) SRBSER1=""
S SRBCNTR=0
S SRBST=0 F S SRBST=$O(^SRS("R",SRBDAY,SRBOR,SRBST)) Q:SRBST="" D
.S SRBN="" F S SRBN=$O(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN)) Q:SRBN="" D
..S SRBET=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",4),SRBSER=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",5)
..S:SRBSER1'=SRBSER SRBCNTR=SRBCNTR+1,SRBSTM(SRBCNTR)=SRBST,SRBETM(SRBCNTR)=SRBET,SRBS1(SRBCNTR)=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",2)
S SRBCTR3=0,SRB=0
F SRBCTR1=1:1:3 D
.F SRBCTR2=1:1:SRBCNTR D
..S SRBNUMB=$E(SRBS1(SRBCTR2),3)
..I SRBCTR1=3,SRBNUMB=0 D UPDATE
..I SRBCTR1=2,SRBNUMB=X3 D UPDATE
..I SRBCTR1=1,SRBNUMB=SRBDY D UPDATE
I '$G(SRBPRG) K SRBCNT,SRBDT,SRBOR,SRBPRG,SRBSER1
K SRB,SRBCNTR,SRBCTR1,SRBCTR2,SRBCTR3,SRBDAY,SRBDY,SRBET,SRBET1,X3
K SRBARRY,SRBETM,SRBN,SRBNUMB,SRBS,SRBS1,SRBS2,SRBSER,SRBSERV,SRBST,SRBST1,SRBSTM
Q
UPDATE ;CHECK AND SET SERVICE BLOCK
I $D(^SRS(SRBOR,"S",SRBDT)),$G(^SRS(SRBOR,"S",SRBDT,1))["X" S SRBCTR3=1,SRB=1
I '$G(SRBCTR3),'$D(^SRS(SRBOR,"S",SRBDT)) D S^SRSBOUT
S SRBST1=SRBSTM(SRBCTR2),SRBET1=SRBETM(SRBCTR2),SRSNUM=SRBNUMB,(SRBCTR3,SRBFLG)=1
S SRBSERV=$P(^SRS("R",SRBDAY,SRBOR,SRBST1,SRBNUMB),"^",5)
S SRBARRY(SRBDT,SRBSERV)=SRBST1_"^"_SRBET1
D CHECK I 'SRB D SET
I SRBFLG,SRB S SRB1=SRBST1,SRB2=SRBET1 D PATRN
Q
SET ;SET SERVICE BLOCK GRAPH
I 'SRBFLG Q
S SRB1=SRBST1,SRB2=SRBET1,SRBI=""
D PTRNALG ;; algorithm for setting start and end of pattern
S SRBX1=^SRS(SROR,"S",SRSDATE,1),^(1)=$E(SRBX1,1,SRB1)_SRBS_$E(SRBX1,SRB2+1,200),^SRS(SROR,"SS",SRSDATE,1)=^(1),^SRS(SROR,"S",SRSDATE,0)=SRSDATE,^SRS(SROR,"SS",SRSDATE,0)=SRSDATE
K SRB1,SRB2,SRBI,SRBX1
Q
CHECK ;CHECK FOR TIME COLLISION
S SRBSER2="" F S SRBSER2=$O(SRBARRY(SRBDT,SRBSER2)) Q:SRBSER2="" D
.S SRBS1=$P(SRBARRY(SRBDT,SRBSER2),"^",1),SRBS2=$P(SRBARRY(SRBDT,SRBSER2),"^",2)
.Q:SRBSER2=SRBSERV
.I (SRBS1'<SRBST1)&(SRBS1<SRBET1)!((SRBS2>SRBST1)&(SRBS2'>SRBET1))!((SRBST1'<SRBS1)&(SRBST1<SRBS2)) S SRBFLG=0
K SRBSER2
Q
DELCHK(SRBDAY) ; CHECK FOR OVERLAPING BLOCK FOR THE DELETED DAY
S SRBDT=SRSDATE,SRBOR=SRSOR,SRBNUM=SRSNUM,SRBST=""
F S SRBST=$O(^SRS("R",SRBDAY,SRBOR,SRBST)) Q:SRBST="" D
.Q:'$D(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM))
.S SRBSERV=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM),"^",5),SRBET=$P(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM),"^",4)
.S SRB1=+SRBST,SRB2=+SRBET
.D PTRNALG
.I SRBS'=SRBCKH,$G(^SRS(SRBOR,"S",SRBDT,1))'[SRBS S SRB1=+SRBST,SRB2=+SRBET D PATRN
K SRB1,SRB2,SRBDAY,SRBDT,SRBNUM,SRBOR,SRBET,SRBST,SRBSERV,SRBS,SRBI,SRBTS,SRBTE,X,X0,X1
Q
PATRN ; set pattern in OPERATING ROOM file
D PTRNALG ;; algorithm for setting start and end of pattern
S SRBX0=^SRS(SRBOR,"SS",SRBDT,1),(SRBX0,^(1))=$E(SRBX0,1,SRB1)_SRBS_$E(SRBX0,SRB2+1,200),^SRS(SRBOR,"SS",SRBDT,0)=SRBDT
S SRBX1=^SRS(SRBOR,"S",SRBDT,1) F SRBI=SRB1:1:SRB2 I "X="'[$E(SRBX1,SRBI) S SRBX1=$E(SRBX1,1,SRBI-1)_$E(SRBX0,SRBI)_$E(SRBX1,SRBI+1,200)
S ^SRS(SRBOR,"S",SRBDT,1)=SRBX1,^SRS(SRBOR,"S",SRBDT,0)=SRBDT
K SRB1,SRB2,SRBX0,SRBX1
Q
PTRNALG ; set pattern in OPERATING ROOM file
; algorithm for setting start and end of pattern
S SRB1=11+((SRB1\1)*5)+(SRB1-(SRB1\1)*100\15),SRB2=11+((SRB2\1)*5)+(SRB2-(SRB2\1)*100\15)
S SRBS="" F SRBI=SRB1:1:SRB2-1 S SRBS=SRBS_$S('(SRBI#5):"|",$E(SRBSERV,SRBI#5)'="":$E(SRBSERV,SRBI#5),1:".")
Q
CURRENT ; ENSURE SERVICE BLOCK GRAPH IS UP TO DATE
S SRBOR=0 F S SRBOR=$O(^SRS(SRBOR)) Q:'SRBOR D
.Q:$P(^SRS(SRBOR,0),"^",6)=1
.S SRBCNT=0 F SRBCNT=0:1:90 S X1=DT,X2=SRBCNT D C^%DTC S SRBDT=X D:'$D(^SRS(SRBOR,"S",SRBDT,1)) GRAPH^SRSDIS1(SRBDT,SRBOR)
K SRBCNT,SRBDT,SRBOR,X,X1,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRSBUTL 6092 printed Dec 13, 2024@02:46:56 Page 2
SRSBUTL ;B'HAM ISC/MAM - BLOCK OUT TIME ON OR SCHEDULE UTILITY; [ 08/14/09 11:36 AM ]
+1 ;;3.0; Surgery ;**165**;24 Jun 93;Build 6
BLOCKED ; find blocked OPERATING ROOMS
+1 SET SRBDT=DT
SET SRBCNT=0
SET SRBOR=SRSOR
SET SRBDAY=SRSDAY
+2 SET X1=SRBDT
SET X2=-1
DO C^%DTC
SET SRBDT=X
+3 FOR
SET SRBDT=$ORDER(^SRS(SRBOR,"S",SRBDT))
if SRBDT=""
QUIT
Begin DoDot:1
+4 SET SRBCNT=SRBCNT+1
+5 if '$DATA(^SRS(SRBOR,"S",SRBDT,1))
QUIT
+6 SET SRBST=""
+7 FOR
SET SRBST=$ORDER(^SRS("R",SRBDAY,SRBOR,SRBST))
if SRBST=""
QUIT
Begin DoDot:2
+8 SET SRBN=""
+9 FOR
SET SRBN=$ORDER(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN))
if SRBN=""
QUIT
Begin DoDot:3
+10 SET SRBET=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",4)
+11 SET SRBSERV=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",5)
+12 SET SRB1=+SRBST
SET SRB2=+SRBET
+13 ; algorithm for setting start and end of pattern
DO PTRNALG
+14 SET SRBNUM=$SELECT(SRBN=0:3,SRBN>7&(SRBN<10):2,1:1)
+15 IF $GET(^SRS(SRBOR,"S",SRBDT,1))[SRBS
SET ^TMP($JOB,"SRSBOUT",SRBDT,SRBNUM,SRBST)=SRBSERV_"^"_SRBN_"^"_SRBET
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL SRB1,SRB2,SRBCNT,SRBDAY,SRBDT,SRBET,SRBI,SRBNUM,SRBN,SRBS,SRBSERV,SRBST,X,X1,X2
+17 QUIT
CHK ;; CHECK FOR EXISTING BLOCKS
+1 SET SRBOR=SRSOR
SET SRBDT=SRSDATE
SET SRBTIME=SRSTIME
SET SRBNUM=SRSNUM
+2 SET SRB1=$PIECE(SRBTIME,"^")
SET SRB2=$PIECE(SRBTIME,"^",2)
SET SRB1=$EXTRACT(SRB1,1,2)_"."_$EXTRACT(SRB1,4,5)
SET SRB2=$EXTRACT(SRB2,1,2)_"."_$EXTRACT(SRB2,4,5)
+3 SET SRBEN1=SRB1
SET SRBEN2=SRB2
SET SRBFLG=1
SET X=0
DO CHKD
CK1 IF SRBNUM=0
SET X=7
DO CHKD
if X
GOTO CK1
CK2 IF SRBNUM>7
SET X=14
DO CHKD
if X
GOTO CK2
CK0 IF SRBNUM>0
IF (SRBNUM<5)
SET X5=$EXTRACT(SRBDT,4,5)
SET X1=SRBDT
SET X2=7
DO C^%DTC
SET SRBDT=X
if $EXTRACT(X,4,5)=X5
GOTO CK0
CK3 IF SRBNUM>0
IF (SRBNUM<5)
SET X=SRBNUM-1*7
DO CHKD
if X
GOTO CK0
CK5 IF SRBNUM=5
SET X1=SRBDT
SET X2=21
DO C^%DTC
SET SRBDT=X
CK4 IF SRBNUM=5
SET X1=SRBDT
SET X2=7
SET X5=$EXTRACT(SRBDT,4,5)
DO C^%DTC
SET SRBDT=X
if $EXTRACT(SRBDT,4,5)=X5
GOTO CK4
SET X=-7
DO CHKD
if X
GOTO CK5
END SET SRBDT=""
FOR
SET SRBDT=$ORDER(SRBCHK(SRBDT))
if 'SRBDT
QUIT
if SRBCHK(SRBDT)=0
SET SRBFLG=0
+1 KILL SRB1,SRB2,SRBDT,SRBEN1,SRBEN2,SRBNMB,SRBNUM,SRBST,SRBET,SRBTIME,X5
+2 QUIT
CHKD SET X1=SRBDT
SET X2=X
DO C^%DTC
SET SRBDT=X
+1 if '$GET(^SRS(SRBOR,"S",SRBDT,0))
SET X=0
+2 SET SRBCHK(SRBDT)=0
+3 IF $DATA(^TMP($JOB,"SRSBOUT",SRBDT))
Begin DoDot:1
+4 SET SRBNMB=""
+5 FOR
SET SRBNMB=$ORDER(^TMP($JOB,"SRSBOUT",SRBDT,SRBNMB))
if 'SRBNMB
QUIT
Begin DoDot:2
+6 SET (SRBST,SRBET)=""
+7 FOR
SET SRBST=$ORDER(^TMP($JOB,"SRSBOUT",SRBDT,SRBNMB,SRBST))
if 'SRBST
QUIT
Begin DoDot:3
+8 SET SRBET=$PIECE(^TMP($JOB,"SRSBOUT",SRBDT,SRBNMB,SRBST),"^",3)
+9 IF (SRBST'<SRBEN1)&(SRBST<SRBEN2)!((SRBET>SRBEN1)&(SRBET'>SRBEN2))!((SRBEN1'<SRBST)&(SRBEN1<SRBET))
SET SRBCHK(SRBDT)=1
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
DIS1 ;CHECK AND SET NEW SERVICE BLOCK
+1 SET SRBOR=SROR
SET SRBDT=SRSDATE
+2 SET X1=SRBDT
SET X2=2830103
DO ^%DTC
SET SRBDAY=$PIECE("MO^TU^WE^TH^FR^SA^SU","^",X#7+1)
SET X3=X#2+8
SET X1=SRBDT
SET X2=$EXTRACT(SRBDT,1,5)_"01"
DO ^%DTC
SET SRBDY=X\7+1
+3 if '$GET(SRBSER1)
SET SRBSER1=""
+4 SET SRBCNTR=0
+5 SET SRBST=0
FOR
SET SRBST=$ORDER(^SRS("R",SRBDAY,SRBOR,SRBST))
if SRBST=""
QUIT
Begin DoDot:1
+6 SET SRBN=""
FOR
SET SRBN=$ORDER(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN))
if SRBN=""
QUIT
Begin DoDot:2
+7 SET SRBET=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",4)
SET SRBSER=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",5)
+8 if SRBSER1'=SRBSER
SET SRBCNTR=SRBCNTR+1
SET SRBSTM(SRBCNTR)=SRBST
SET SRBETM(SRBCNTR)=SRBET
SET SRBS1(SRBCNTR)=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBN),"^",2)
End DoDot:2
End DoDot:1
+9 SET SRBCTR3=0
SET SRB=0
+10 FOR SRBCTR1=1:1:3
Begin DoDot:1
+11 FOR SRBCTR2=1:1:SRBCNTR
Begin DoDot:2
+12 SET SRBNUMB=$EXTRACT(SRBS1(SRBCTR2),3)
+13 IF SRBCTR1=3
IF SRBNUMB=0
DO UPDATE
+14 IF SRBCTR1=2
IF SRBNUMB=X3
DO UPDATE
+15 IF SRBCTR1=1
IF SRBNUMB=SRBDY
DO UPDATE
End DoDot:2
End DoDot:1
+16 IF '$GET(SRBPRG)
KILL SRBCNT,SRBDT,SRBOR,SRBPRG,SRBSER1
+17 KILL SRB,SRBCNTR,SRBCTR1,SRBCTR2,SRBCTR3,SRBDAY,SRBDY,SRBET,SRBET1,X3
+18 KILL SRBARRY,SRBETM,SRBN,SRBNUMB,SRBS,SRBS1,SRBS2,SRBSER,SRBSERV,SRBST,SRBST1,SRBSTM
+19 QUIT
UPDATE ;CHECK AND SET SERVICE BLOCK
+1 IF $DATA(^SRS(SRBOR,"S",SRBDT))
IF $GET(^SRS(SRBOR,"S",SRBDT,1))["X"
SET SRBCTR3=1
SET SRB=1
+2 IF '$GET(SRBCTR3)
IF '$DATA(^SRS(SRBOR,"S",SRBDT))
DO S^SRSBOUT
+3 SET SRBST1=SRBSTM(SRBCTR2)
SET SRBET1=SRBETM(SRBCTR2)
SET SRSNUM=SRBNUMB
SET (SRBCTR3,SRBFLG)=1
+4 SET SRBSERV=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST1,SRBNUMB),"^",5)
+5 SET SRBARRY(SRBDT,SRBSERV)=SRBST1_"^"_SRBET1
+6 DO CHECK
IF 'SRB
DO SET
+7 IF SRBFLG
IF SRB
SET SRB1=SRBST1
SET SRB2=SRBET1
DO PATRN
+8 QUIT
SET ;SET SERVICE BLOCK GRAPH
+1 IF 'SRBFLG
QUIT
+2 SET SRB1=SRBST1
SET SRB2=SRBET1
SET SRBI=""
+3 ;; algorithm for setting start and end of pattern
DO PTRNALG
+4 SET SRBX1=^SRS(SROR,"S",SRSDATE,1)
SET ^(1)=$EXTRACT(SRBX1,1,SRB1)_SRBS_$EXTRACT(SRBX1,SRB2+1,200)
SET ^SRS(SROR,"SS",SRSDATE,1)=^(1)
SET ^SRS(SROR,"S",SRSDATE,0)=SRSDATE
SET ^SRS(SROR,"SS",SRSDATE,0)=SRSDATE
+5 KILL SRB1,SRB2,SRBI,SRBX1
+6 QUIT
CHECK ;CHECK FOR TIME COLLISION
+1 SET SRBSER2=""
FOR
SET SRBSER2=$ORDER(SRBARRY(SRBDT,SRBSER2))
if SRBSER2=""
QUIT
Begin DoDot:1
+2 SET SRBS1=$PIECE(SRBARRY(SRBDT,SRBSER2),"^",1)
SET SRBS2=$PIECE(SRBARRY(SRBDT,SRBSER2),"^",2)
+3 if SRBSER2=SRBSERV
QUIT
+4 IF (SRBS1'<SRBST1)&(SRBS1<SRBET1)!((SRBS2>SRBST1)&(SRBS2'>SRBET1))!((SRBST1'<SRBS1)&(SRBST1<SRBS2))
SET SRBFLG=0
End DoDot:1
+5 KILL SRBSER2
+6 QUIT
DELCHK(SRBDAY) ; CHECK FOR OVERLAPING BLOCK FOR THE DELETED DAY
+1 SET SRBDT=SRSDATE
SET SRBOR=SRSOR
SET SRBNUM=SRSNUM
SET SRBST=""
+2 FOR
SET SRBST=$ORDER(^SRS("R",SRBDAY,SRBOR,SRBST))
if SRBST=""
QUIT
Begin DoDot:1
+3 if '$DATA(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM))
QUIT
+4 SET SRBSERV=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM),"^",5)
SET SRBET=$PIECE(^SRS("R",SRBDAY,SRBOR,SRBST,SRBNUM),"^",4)
+5 SET SRB1=+SRBST
SET SRB2=+SRBET
+6 DO PTRNALG
+7 IF SRBS'=SRBCKH
IF $GET(^SRS(SRBOR,"S",SRBDT,1))'[SRBS
SET SRB1=+SRBST
SET SRB2=+SRBET
DO PATRN
End DoDot:1
+8 KILL SRB1,SRB2,SRBDAY,SRBDT,SRBNUM,SRBOR,SRBET,SRBST,SRBSERV,SRBS,SRBI,SRBTS,SRBTE,X,X0,X1
+9 QUIT
PATRN ; set pattern in OPERATING ROOM file
+1 ;; algorithm for setting start and end of pattern
DO PTRNALG
+2 SET SRBX0=^SRS(SRBOR,"SS",SRBDT,1)
SET (SRBX0,^(1))=$EXTRACT(SRBX0,1,SRB1)_SRBS_$EXTRACT(SRBX0,SRB2+1,200)
SET ^SRS(SRBOR,"SS",SRBDT,0)=SRBDT
+3 SET SRBX1=^SRS(SRBOR,"S",SRBDT,1)
FOR SRBI=SRB1:1:SRB2
IF "X="'[$EXTRACT(SRBX1,SRBI)
SET SRBX1=$EXTRACT(SRBX1,1,SRBI-1)_$EXTRACT(SRBX0,SRBI)_$EXTRACT(SRBX1,SRBI+1,200)
+4 SET ^SRS(SRBOR,"S",SRBDT,1)=SRBX1
SET ^SRS(SRBOR,"S",SRBDT,0)=SRBDT
+5 KILL SRB1,SRB2,SRBX0,SRBX1
+6 QUIT
PTRNALG ; set pattern in OPERATING ROOM file
+1 ; algorithm for setting start and end of pattern
+2 SET SRB1=11+((SRB1\1)*5)+(SRB1-(SRB1\1)*100\15)
SET SRB2=11+((SRB2\1)*5)+(SRB2-(SRB2\1)*100\15)
+3 SET SRBS=""
FOR SRBI=SRB1:1:SRB2-1
SET SRBS=SRBS_$SELECT('(SRBI#5):"|",$EXTRACT(SRBSERV,SRBI#5)'="":$EXTRACT(SRBSERV,SRBI#5),1:".")
+4 QUIT
CURRENT ; ENSURE SERVICE BLOCK GRAPH IS UP TO DATE
+1 SET SRBOR=0
FOR
SET SRBOR=$ORDER(^SRS(SRBOR))
if 'SRBOR
QUIT
Begin DoDot:1
+2 if $PIECE(^SRS(SRBOR,0),"^",6)=1
QUIT
+3 SET SRBCNT=0
FOR SRBCNT=0:1:90
SET X1=DT
SET X2=SRBCNT
DO C^%DTC
SET SRBDT=X
if '$DATA(^SRS(SRBOR,"S",SRBDT,1))
DO GRAPH^SRSDIS1(SRBDT,SRBOR)
End DoDot:1
+4 KILL SRBCNT,SRBDT,SRBOR,X,X1,X
+5 QUIT
