SDECUT1A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
;;5.3;Scheduling;**627,658**;Aug 13, 1993;Build 23
;
Q
;
A(STA,SDCL,SDBEG,SDSI,SDCLS) ;get array of start times
N HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE,SDTAR
S SDTDONE=0
S SDTDAY=$$GETDAY^SDECUTL1($P(SDBEG,".",1))
S SDAY=$$FMADD^XLFDT(SDBEG,1) F S SDAY=$O(^SC(SDCL,"T",SDAY),-1) Q:SDAY'>0 D Q:+SDTDONE
.Q:$$GETDAY^SDECUTL1(SDAY)'=SDTDAY
.I SDAY'=$P(SDBEG,".",1),$D(^SC(SDCL,"ST",SDAY,9)) Q
.K SDTAR
.M SDTAR=^SC(SDCL,"T",SDAY)
.S SDTDONE=1
D @("A"_SDSI)
Q
A1 ;
S SDI=0 F S SDI=$O(SDTAR(2,SDI)) Q:SDI="" D
.S OFFSET="" ;alb/sat 658 initialize OFFSET for each iteration
.S NOD=SDTAR(2,SDI,0)
.S HR=$E($P(NOD,U,1),1,2)
.S MIN=$E($P(NOD,U,1),3,4)
.I +MIN'<0,+MIN<15 S OFFSET=+MIN
.I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
.I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
.I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
.D B1(.STA,HR,OFFSET)
S HR1=""
S HR="" F S HR=$O(STA(HR)) Q:HR="" D
.I HR1="" S HR1=HR
.E S:+HR<+HR1 HR1=HR
I SDCLS<(+HR1) D ;fill in gaps
.S HR=HR1
.F Q:SDCLS=+HR D
..S HR=(+HR)-1
..S HR=$S($L(HR)=1:0_HR,1:HR)
..D B1(.STA,HR,OFFSET)
Q
B1(STA,HR,OFFSET) ;
N MIN
S MIN=15+OFFSET
S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=30+OFFSET
S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=45+OFFSET
S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=+OFFSET
S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
Q
A2 ;
;S OFFSET=""
S SDI=0 F S SDI=$O(SDTAR(2,SDI)) Q:SDI="" D
.S OFFSET="" ;alb/sat 658 initialize OFFSET for each iteration
.S NOD=SDTAR(2,SDI,0)
.S HR=$E($P(NOD,U,1),1,2)
.S MIN=$E($P(NOD,U,1),3,4)
.I +MIN'<0,+MIN<15 S OFFSET=+MIN
.I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
.I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
.I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
.D B2(.STA,HR,OFFSET)
S HR1=""
S HR="" F S HR=$O(STA(HR)) Q:HR="" D
.I HR1="" S HR1=HR
.E S:+HR<+HR1 HR1=HR
I SDCLS<(+HR1) D ;fill in gaps
.S HR=HR1
.F Q:SDCLS=+HR D
..S HR=(+HR)-1
..S HR=$S($L(HR)=1:0_HR,1:HR)
..D B2(.STA,HR,OFFSET)
Q
B2(STA,HR,OFFSET) ;
N MIN
S MIN=15+OFFSET
S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=30+OFFSET
S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=45+OFFSET
S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=+OFFSET
S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
Q
A3 ;get array of start times
N HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE
S SDTDONE=0
S SDTDAY=$$GETDAY^SDECUTL1($P(SDBEG,".",1))
S SDAY=$$FMADD^XLFDT(SDBEG,1) F S SDAY=$O(^SC(SDCL,"T",SDAY),-1) Q:SDAY'>0 D Q:+SDTDONE
.Q:$$GETDAY^SDECUTL1(SDAY)'=SDTDAY
.I SDAY'=$P(SDBEG,".",1),$D(^SC(SDCL,"ST",SDAY,9)) Q
.K SDTAR
.M SDTAR=^SC(SDCL,"T",SDAY)
.S SDTDONE=1
;S OFFSET=""
S SDI=0 F S SDI=$O(SDTAR(2,SDI)) Q:SDI="" D
.S OFFSET="" ;alb/sat 658 initialize OFFSET for each iteration
.S NOD=SDTAR(2,SDI,0)
.S HR=$E($P(NOD,U,1),1,2)
.S MIN=$E($P(NOD,U,1),3,4)
.I +MIN'<0,+MIN<20 S OFFSET=+MIN
.I OFFSET="",+MIN'<20,+MIN<40 S OFFSET=(+MIN)-20 ; S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
.I OFFSET="",+MIN'<40,+MIN'>59 S OFFSET=(+MIN)-40 S STA(HR,2)=MIN_U_$S(MIN="00":"",$E(MIN,2)=0:$E(MIN,1),1:MIN)
.D B3(.STA,HR,OFFSET)
S HR1=""
S HR="" F S HR=$O(STA(HR)) Q:HR="" D
.I HR1="" S HR1=HR
.E S:+HR<+HR1 HR1=HR
I SDCLS<(+HR1) D ;fill in gaps
.S HR=HR1
.F Q:SDCLS=+HR D
..S HR=(+HR)-1
..S HR=$S($L(HR)=1:0_HR,1:HR)
..D B3(.STA,HR,OFFSET)
Q
B3(STA,HR,OFFSET) ;
N MIN
S MIN=20+OFFSET
S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=40+OFFSET
S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=+OFFSET
S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
Q
A4 ;
;S OFFSET=""
S SDI=0 F S SDI=$O(SDTAR(2,SDI)) Q:SDI="" D
.S OFFSET="" ;alb/sat 658 initialize OFFSET for each iteration
.S NOD=SDTAR(2,SDI,0)
.S HR=$E($P(NOD,U,1),1,2)
.S MIN=$E($P(NOD,U,1),3,4)
.I +MIN'<0,+MIN<15 S OFFSET=+MIN
.I OFFSET="",+MIN'<15,+MIN<30 S OFFSET=(+MIN)-15
.I OFFSET="",+MIN'<30,+MIN<45 S OFFSET=(+MIN)-30
.I OFFSET="",+MIN'<45,+MIN'>59 S OFFSET=(+MIN)-45
.D B4(.STA,HR,OFFSET)
S HR1=""
S HR="" F S HR=$O(STA(HR)) Q:HR="" D
.I HR1="" S HR1=HR
.E S:+HR<+HR1 HR1=HR
I SDCLS<(+HR1) D ;fill in gaps
.S HR=HR1
.F Q:SDCLS=+HR D
..S HR=(+HR)-1
..S HR=$S($L(HR)=1:0_HR,1:HR)
..D B4(.STA,HR,OFFSET)
Q
B4(STA,HR,OFFSET) ;
N MIN
S MIN=15+OFFSET
S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=30+OFFSET
S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=45+OFFSET
S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=+OFFSET
S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
Q
A6 ;
;S OFFSET=""
S SDI=0 F S SDI=$O(SDTAR(2,SDI)) Q:SDI="" D
.S OFFSET="" ;alb/sat 658 initialize OFFSET for each iteration
.S NOD=SDTAR(2,SDI,0)
.S HR=$E($P(NOD,U,1),1,2)
.S MIN=$E($P(NOD,U,1),3,4)
.I +MIN'<0,+MIN<10 S OFFSET=+MIN
.I OFFSET="",+MIN'<10,+MIN<20 S OFFSET=(+MIN)-10
.I OFFSET="",+MIN'<20,+MIN<30 S OFFSET=(+MIN)-20
.I OFFSET="",+MIN'<30,+MIN<40 S OFFSET=(+MIN)-30
.I OFFSET="",+MIN'<40,+MIN<50 S OFFSET=(+MIN)-40
.I OFFSET="",+MIN'<50,+MIN'>59 S OFFSET=(+MIN)-50
.D B6(.STA,HR,OFFSET)
S HR1=""
S HR="" F S HR=$O(STA(HR)) Q:HR="" D
.I HR1="" S HR1=HR
.E S:+HR<+HR1 HR1=HR
I SDCLS<(+HR1) D ;fill in gaps
.S HR=HR1
.F Q:SDCLS=+HR D
..S HR=(+HR)-1
..S HR=$S($L(HR)=1:0_HR,1:HR)
..D B6(.STA,HR,OFFSET)
Q
B6(STA,HR,OFFSET) ;
N MIN
S MIN=10+OFFSET
S STA(HR,4)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=20+OFFSET
S STA(HR,6)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=30+OFFSET
S STA(HR,8)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=40+OFFSET
S STA(HR,10)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=50+OFFSET
S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
S MIN=+OFFSET
S STA(HR,2)=$S(+MIN=0:"00",1:$S($L(MIN)=1:"0"_MIN,1:MIN))_U_$S(+MIN=0:"",$L(MIN)=1:"0"_MIN,$E(MIN,2)=0:$E(MIN,1),1:MIN)
Q
MAKE(SDBLKS,SDI,START,STOP,SLOT) ;make block
N SDATAV,SDATUN
S SDATAV=$O(^SDEC(409.823,"B","AVAILABLE",0))
S SDATUN=$O(^SDEC(409.823,"B","UNAVAILABLE",0))
S SDI=SDI+1 S SDBLKS(SDI)=START_U_STOP_U_SLOT_U_$S(+SLOT:SDATAV,1:SDATUN)
Q
;
RESNB(SDAB,SDBLKS,SDCL,SDAY,SDRES) ;create/update access blocks for 1 day
N SDI,SDJ,SDNOD,SDRESP
Q:'$D(SDBLKS)
Q:$G(SDAY)'?7N
S SDRESP=$G(SDRES)
;delete all related access blocks
;build new access blocks with calls to RESNB1
S SDI="" F S SDI=$O(SDBLKS(SDI)) Q:SDI="" D
.S SDNOD=SDBLKS(SDI)
.Q:$P($P(SDNOD,U,1),".",1)'=SDAY
.D RESNB1(SDAB,SDCL,$P(SDNOD,U,1),$P(SDNOD,U,2),$P(SDNOD,U,3),$P(SDNOD,U,4))
Q
;
RESNBD(SDCL,SDAY,SDRESP) ;delete access blocks for the day
Q
;
RESNB1(SDAB,SDCL,SDSTART,SDSTOP,SDSLOTS,SDAT,SDRES) ;create/update 1 access block
;INPUT:
; SDAB - global name for access blocks - "^TMP("_$J_",""SDEC"",""BLKS"")"
; SDCL - clinic ID pointer to HOSPITAL LOCATION file
; not used if SDRES is passed in
; SDSTART - start time in FM format
; SDSTOP - stop time in FM format
; SDSLOTS - number of slots
; SDAT - access type ID pointer to SDEC ACCESS TYPE file
; SDRES - resource ID pointer to SDEC RESOURCE file
; only update this resource if passed in
; calling routine needs to make sure SDRES belongs to the proper HOSPITAL LOCATION (sdcl)
S SDRES=$G(SDRES)
D RESNBR
Q
;only update passed in resource
I SDRES'="" I $D(^SDEC(409.831,"ALOC",SDCL,SDRES)) D RESNBR Q
;update all resources if no resource passed in
I SDRES="" S SDRES=0 F S SDRES=$O(^SDEC(409.831,"ALOC",SDCL,SDRES)) Q:SDRES'>0 D RESNBR
Q
RESNBR ;create access block for 1 resource
N SDCNT,SDFDA,SDIEN,SDIENS,SDMSG
S (SDCNT,@SDAB@("CNT"))=$G(@SDAB@("CNT"))+1
S @SDAB@(SDCNT)=SDRES_U_SDSTART_U_SDSTOP_U_SDSLOTS_U_SDAT
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
GETDAY(DATE) ;return day of the week
N DOW,RET
S RET=""
S DATE=$P($G(DATE),".",1)
Q:DATE'?7N RET
S DOW="S %=$E(DATE,1,3),I=$E(DATE,4,5),I=I>2&'(%#4)+$E(""144025036146"",I) X ""F %=%:-1:281 S I=%#4=1+1+I"" S RET=$P(""SUN^MON^TUES^WEDNES^THURS^FRI^SATUR"",U,$E(DATE,6,7)+I#7+1)_""DAY"""
X DOW
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECUT1A 8653 printed Apr 09, 2024@21:59:55 Page 2
SDECUT1A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
+1 ;;5.3;Scheduling;**627,658**;Aug 13, 1993;Build 23
+2 ;
+3 QUIT
+4 ;
A(STA,SDCL,SDBEG,SDSI,SDCLS) ;get array of start times
+1 NEW HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE,SDTAR
+2 SET SDTDONE=0
+3 SET SDTDAY=$$GETDAY^SDECUTL1($PIECE(SDBEG,".",1))
+4 SET SDAY=$$FMADD^XLFDT(SDBEG,1)
FOR
SET SDAY=$ORDER(^SC(SDCL,"T",SDAY),-1)
if SDAY'>0
QUIT
Begin DoDot:1
+5 if $$GETDAY^SDECUTL1(SDAY)'=SDTDAY
QUIT
+6 IF SDAY'=$PIECE(SDBEG,".",1)
IF $DATA(^SC(SDCL,"ST",SDAY,9))
QUIT
+7 KILL SDTAR
+8 MERGE SDTAR=^SC(SDCL,"T",SDAY)
+9 SET SDTDONE=1
End DoDot:1
if +SDTDONE
QUIT
+10 DO @("A"_SDSI)
+11 QUIT
A1 ;
+1 SET SDI=0
FOR
SET SDI=$ORDER(SDTAR(2,SDI))
if SDI=""
QUIT
Begin DoDot:1
+2 ;alb/sat 658 initialize OFFSET for each iteration
SET OFFSET=""
+3 SET NOD=SDTAR(2,SDI,0)
+4 SET HR=$EXTRACT($PIECE(NOD,U,1),1,2)
+5 SET MIN=$EXTRACT($PIECE(NOD,U,1),3,4)
+6 IF +MIN'<0
IF +MIN<15
SET OFFSET=+MIN
+7 IF OFFSET=""
IF +MIN'<15
IF +MIN<30
SET OFFSET=(+MIN)-15
+8 IF OFFSET=""
IF +MIN'<30
IF +MIN<45
SET OFFSET=(+MIN)-30
+9 IF OFFSET=""
IF +MIN'<45
IF +MIN'>59
SET OFFSET=(+MIN)-45
+10 DO B1(.STA,HR,OFFSET)
End DoDot:1
+11 SET HR1=""
+12 SET HR=""
FOR
SET HR=$ORDER(STA(HR))
if HR=""
QUIT
Begin DoDot:1
+13 IF HR1=""
SET HR1=HR
+14 IF '$TEST
if +HR<+HR1
SET HR1=HR
End DoDot:1
+15 ;fill in gaps
IF SDCLS<(+HR1)
Begin DoDot:1
+16 SET HR=HR1
+17 FOR
if SDCLS=+HR
QUIT
Begin DoDot:2
+18 SET HR=(+HR)-1
+19 SET HR=$SELECT($LENGTH(HR)=1:0_HR,1:HR)
+20 DO B1(.STA,HR,OFFSET)
End DoDot:2
End DoDot:1
+21 QUIT
B1(STA,HR,OFFSET) ;
+1 NEW MIN
+2 SET MIN=15+OFFSET
+3 SET STA(HR,4)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+4 SET MIN=30+OFFSET
+5 SET STA(HR,6)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+6 SET MIN=45+OFFSET
+7 SET STA(HR,0)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+8 SET MIN=+OFFSET
+9 SET STA(HR,2)=$SELECT(+MIN=0:"00",1:$SELECT($LENGTH(MIN)=1:"0"_MIN,1:MIN))_U_$SELECT(+MIN=0:"",$LENGTH(MIN)=1:"0"_MIN,$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+10 QUIT
A2 ;
+1 ;S OFFSET=""
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDTAR(2,SDI))
if SDI=""
QUIT
Begin DoDot:1
+3 ;alb/sat 658 initialize OFFSET for each iteration
SET OFFSET=""
+4 SET NOD=SDTAR(2,SDI,0)
+5 SET HR=$EXTRACT($PIECE(NOD,U,1),1,2)
+6 SET MIN=$EXTRACT($PIECE(NOD,U,1),3,4)
+7 IF +MIN'<0
IF +MIN<15
SET OFFSET=+MIN
+8 IF OFFSET=""
IF +MIN'<15
IF +MIN<30
SET OFFSET=(+MIN)-15
+9 IF OFFSET=""
IF +MIN'<30
IF +MIN<45
SET OFFSET=(+MIN)-30
+10 IF OFFSET=""
IF +MIN'<45
IF +MIN'>59
SET OFFSET=(+MIN)-45
+11 DO B2(.STA,HR,OFFSET)
End DoDot:1
+12 SET HR1=""
+13 SET HR=""
FOR
SET HR=$ORDER(STA(HR))
if HR=""
QUIT
Begin DoDot:1
+14 IF HR1=""
SET HR1=HR
+15 IF '$TEST
if +HR<+HR1
SET HR1=HR
End DoDot:1
+16 ;fill in gaps
IF SDCLS<(+HR1)
Begin DoDot:1
+17 SET HR=HR1
+18 FOR
if SDCLS=+HR
QUIT
Begin DoDot:2
+19 SET HR=(+HR)-1
+20 SET HR=$SELECT($LENGTH(HR)=1:0_HR,1:HR)
+21 DO B2(.STA,HR,OFFSET)
End DoDot:2
End DoDot:1
+22 QUIT
B2(STA,HR,OFFSET) ;
+1 NEW MIN
+2 SET MIN=15+OFFSET
+3 SET STA(HR,4)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+4 SET MIN=30+OFFSET
+5 SET STA(HR,6)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+6 SET MIN=45+OFFSET
+7 SET STA(HR,0)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+8 SET MIN=+OFFSET
+9 SET STA(HR,2)=$SELECT(+MIN=0:"00",1:$SELECT($LENGTH(MIN)=1:"0"_MIN,1:MIN))_U_$SELECT(+MIN=0:"",$LENGTH(MIN)=1:"0"_MIN,$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+10 QUIT
A3 ;get array of start times
+1 NEW HR,HR1,MIN,NOD,OFFSET,SDAY,SDI,SDTDAY,SDTDONE
+2 SET SDTDONE=0
+3 SET SDTDAY=$$GETDAY^SDECUTL1($PIECE(SDBEG,".",1))
+4 SET SDAY=$$FMADD^XLFDT(SDBEG,1)
FOR
SET SDAY=$ORDER(^SC(SDCL,"T",SDAY),-1)
if SDAY'>0
QUIT
Begin DoDot:1
+5 if $$GETDAY^SDECUTL1(SDAY)'=SDTDAY
QUIT
+6 IF SDAY'=$PIECE(SDBEG,".",1)
IF $DATA(^SC(SDCL,"ST",SDAY,9))
QUIT
+7 KILL SDTAR
+8 MERGE SDTAR=^SC(SDCL,"T",SDAY)
+9 SET SDTDONE=1
End DoDot:1
if +SDTDONE
QUIT
+10 ;S OFFSET=""
+11 SET SDI=0
FOR
SET SDI=$ORDER(SDTAR(2,SDI))
if SDI=""
QUIT
Begin DoDot:1
+12 ;alb/sat 658 initialize OFFSET for each iteration
SET OFFSET=""
+13 SET NOD=SDTAR(2,SDI,0)
+14 SET HR=$EXTRACT($PIECE(NOD,U,1),1,2)
+15 SET MIN=$EXTRACT($PIECE(NOD,U,1),3,4)
+16 IF +MIN'<0
IF +MIN<20
SET OFFSET=+MIN
+17 ; S STA(HR,0)=MIN_U_$S($E(MIN,2)=0:$E(MIN,1),1:MIN)
IF OFFSET=""
IF +MIN'<20
IF +MIN<40
SET OFFSET=(+MIN)-20
+18 IF OFFSET=""
IF +MIN'<40
IF +MIN'>59
SET OFFSET=(+MIN)-40
SET STA(HR,2)=MIN_U_$SELECT(MIN="00":"",$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+19 DO B3(.STA,HR,OFFSET)
End DoDot:1
+20 SET HR1=""
+21 SET HR=""
FOR
SET HR=$ORDER(STA(HR))
if HR=""
QUIT
Begin DoDot:1
+22 IF HR1=""
SET HR1=HR
+23 IF '$TEST
if +HR<+HR1
SET HR1=HR
End DoDot:1
+24 ;fill in gaps
IF SDCLS<(+HR1)
Begin DoDot:1
+25 SET HR=HR1
+26 FOR
if SDCLS=+HR
QUIT
Begin DoDot:2
+27 SET HR=(+HR)-1
+28 SET HR=$SELECT($LENGTH(HR)=1:0_HR,1:HR)
+29 DO B3(.STA,HR,OFFSET)
End DoDot:2
End DoDot:1
+30 QUIT
B3(STA,HR,OFFSET) ;
+1 NEW MIN
+2 SET MIN=20+OFFSET
+3 SET STA(HR,4)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+4 SET MIN=40+OFFSET
+5 SET STA(HR,0)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+6 SET MIN=+OFFSET
+7 SET STA(HR,2)=$SELECT(+MIN=0:"00",1:$SELECT($LENGTH(MIN)=1:"0"_MIN,1:MIN))_U_$SELECT(+MIN=0:"",$LENGTH(MIN)=1:"0"_MIN,$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+8 QUIT
A4 ;
+1 ;S OFFSET=""
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDTAR(2,SDI))
if SDI=""
QUIT
Begin DoDot:1
+3 ;alb/sat 658 initialize OFFSET for each iteration
SET OFFSET=""
+4 SET NOD=SDTAR(2,SDI,0)
+5 SET HR=$EXTRACT($PIECE(NOD,U,1),1,2)
+6 SET MIN=$EXTRACT($PIECE(NOD,U,1),3,4)
+7 IF +MIN'<0
IF +MIN<15
SET OFFSET=+MIN
+8 IF OFFSET=""
IF +MIN'<15
IF +MIN<30
SET OFFSET=(+MIN)-15
+9 IF OFFSET=""
IF +MIN'<30
IF +MIN<45
SET OFFSET=(+MIN)-30
+10 IF OFFSET=""
IF +MIN'<45
IF +MIN'>59
SET OFFSET=(+MIN)-45
+11 DO B4(.STA,HR,OFFSET)
End DoDot:1
+12 SET HR1=""
+13 SET HR=""
FOR
SET HR=$ORDER(STA(HR))
if HR=""
QUIT
Begin DoDot:1
+14 IF HR1=""
SET HR1=HR
+15 IF '$TEST
if +HR<+HR1
SET HR1=HR
End DoDot:1
+16 ;fill in gaps
IF SDCLS<(+HR1)
Begin DoDot:1
+17 SET HR=HR1
+18 FOR
if SDCLS=+HR
QUIT
Begin DoDot:2
+19 SET HR=(+HR)-1
+20 SET HR=$SELECT($LENGTH(HR)=1:0_HR,1:HR)
+21 DO B4(.STA,HR,OFFSET)
End DoDot:2
End DoDot:1
+22 QUIT
B4(STA,HR,OFFSET) ;
+1 NEW MIN
+2 SET MIN=15+OFFSET
+3 SET STA(HR,4)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+4 SET MIN=30+OFFSET
+5 SET STA(HR,6)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+6 SET MIN=45+OFFSET
+7 SET STA(HR,0)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+8 SET MIN=+OFFSET
+9 SET STA(HR,2)=$SELECT(+MIN=0:"00",1:$SELECT($LENGTH(MIN)=1:"0"_MIN,1:MIN))_U_$SELECT(+MIN=0:"",$LENGTH(MIN)=1:"0"_MIN,$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+10 QUIT
A6 ;
+1 ;S OFFSET=""
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDTAR(2,SDI))
if SDI=""
QUIT
Begin DoDot:1
+3 ;alb/sat 658 initialize OFFSET for each iteration
SET OFFSET=""
+4 SET NOD=SDTAR(2,SDI,0)
+5 SET HR=$EXTRACT($PIECE(NOD,U,1),1,2)
+6 SET MIN=$EXTRACT($PIECE(NOD,U,1),3,4)
+7 IF +MIN'<0
IF +MIN<10
SET OFFSET=+MIN
+8 IF OFFSET=""
IF +MIN'<10
IF +MIN<20
SET OFFSET=(+MIN)-10
+9 IF OFFSET=""
IF +MIN'<20
IF +MIN<30
SET OFFSET=(+MIN)-20
+10 IF OFFSET=""
IF +MIN'<30
IF +MIN<40
SET OFFSET=(+MIN)-30
+11 IF OFFSET=""
IF +MIN'<40
IF +MIN<50
SET OFFSET=(+MIN)-40
+12 IF OFFSET=""
IF +MIN'<50
IF +MIN'>59
SET OFFSET=(+MIN)-50
+13 DO B6(.STA,HR,OFFSET)
End DoDot:1
+14 SET HR1=""
+15 SET HR=""
FOR
SET HR=$ORDER(STA(HR))
if HR=""
QUIT
Begin DoDot:1
+16 IF HR1=""
SET HR1=HR
+17 IF '$TEST
if +HR<+HR1
SET HR1=HR
End DoDot:1
+18 ;fill in gaps
IF SDCLS<(+HR1)
Begin DoDot:1
+19 SET HR=HR1
+20 FOR
if SDCLS=+HR
QUIT
Begin DoDot:2
+21 SET HR=(+HR)-1
+22 SET HR=$SELECT($LENGTH(HR)=1:0_HR,1:HR)
+23 DO B6(.STA,HR,OFFSET)
End DoDot:2
End DoDot:1
+24 QUIT
B6(STA,HR,OFFSET) ;
+1 NEW MIN
+2 SET MIN=10+OFFSET
+3 SET STA(HR,4)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+4 SET MIN=20+OFFSET
+5 SET STA(HR,6)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+6 SET MIN=30+OFFSET
+7 SET STA(HR,8)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+8 SET MIN=40+OFFSET
+9 SET STA(HR,10)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+10 SET MIN=50+OFFSET
+11 SET STA(HR,0)=MIN_U_$SELECT($EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+12 SET MIN=+OFFSET
+13 SET STA(HR,2)=$SELECT(+MIN=0:"00",1:$SELECT($LENGTH(MIN)=1:"0"_MIN,1:MIN))_U_$SELECT(+MIN=0:"",$LENGTH(MIN)=1:"0"_MIN,$EXTRACT(MIN,2)=0:$EXTRACT(MIN,1),1:MIN)
+14 QUIT
MAKE(SDBLKS,SDI,START,STOP,SLOT) ;make block
+1 NEW SDATAV,SDATUN
+2 SET SDATAV=$ORDER(^SDEC(409.823,"B","AVAILABLE",0))
+3 SET SDATUN=$ORDER(^SDEC(409.823,"B","UNAVAILABLE",0))
+4 SET SDI=SDI+1
SET SDBLKS(SDI)=START_U_STOP_U_SLOT_U_$SELECT(+SLOT:SDATAV,1:SDATUN)
+5 QUIT
+6 ;
RESNB(SDAB,SDBLKS,SDCL,SDAY,SDRES) ;create/update access blocks for 1 day
+1 NEW SDI,SDJ,SDNOD,SDRESP
+2 if '$DATA(SDBLKS)
QUIT
+3 if $GET(SDAY)'?7N
QUIT
+4 SET SDRESP=$GET(SDRES)
+5 ;delete all related access blocks
+6 ;build new access blocks with calls to RESNB1
+7 SET SDI=""
FOR
SET SDI=$ORDER(SDBLKS(SDI))
if SDI=""
QUIT
Begin DoDot:1
+8 SET SDNOD=SDBLKS(SDI)
+9 if $PIECE($PIECE(SDNOD,U,1),".",1)'=SDAY
QUIT
+10 DO RESNB1(SDAB,SDCL,$PIECE(SDNOD,U,1),$PIECE(SDNOD,U,2),$PIECE(SDNOD,U,3),$PIECE(SDNOD,U,4))
End DoDot:1
+11 QUIT
+12 ;
RESNBD(SDCL,SDAY,SDRESP) ;delete access blocks for the day
+1 QUIT
+2 ;
RESNB1(SDAB,SDCL,SDSTART,SDSTOP,SDSLOTS,SDAT,SDRES) ;create/update 1 access block
+1 ;INPUT:
+2 ; SDAB - global name for access blocks - "^TMP("_$J_",""SDEC"",""BLKS"")"
+3 ; SDCL - clinic ID pointer to HOSPITAL LOCATION file
+4 ; not used if SDRES is passed in
+5 ; SDSTART - start time in FM format
+6 ; SDSTOP - stop time in FM format
+7 ; SDSLOTS - number of slots
+8 ; SDAT - access type ID pointer to SDEC ACCESS TYPE file
+9 ; SDRES - resource ID pointer to SDEC RESOURCE file
+10 ; only update this resource if passed in
+11 ; calling routine needs to make sure SDRES belongs to the proper HOSPITAL LOCATION (sdcl)
+12 SET SDRES=$GET(SDRES)
+13 DO RESNBR
+14 QUIT
+15 ;only update passed in resource
+16 IF SDRES'=""
IF $DATA(^SDEC(409.831,"ALOC",SDCL,SDRES))
DO RESNBR
QUIT
+17 ;update all resources if no resource passed in
+18 IF SDRES=""
SET SDRES=0
FOR
SET SDRES=$ORDER(^SDEC(409.831,"ALOC",SDCL,SDRES))
if SDRES'>0
QUIT
DO RESNBR
+19 QUIT
RESNBR ;create access block for 1 resource
+1 NEW SDCNT,SDFDA,SDIEN,SDIENS,SDMSG
+2 SET (SDCNT,@SDAB@("CNT"))=$GET(@SDAB@("CNT"))+1
+3 SET @SDAB@(SDCNT)=SDRES_U_SDSTART_U_SDSTOP_U_SDSLOTS_U_SDAT
+4 QUIT
+5 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
GETDAY(DATE) ;return day of the week
+1 NEW DOW,RET
+2 SET RET=""
+3 SET DATE=$PIECE($GET(DATE),".",1)
+4 if DATE'?7N
QUIT RET
+5 SET DOW="S %=$E(DATE,1,3),I=$E(DATE,4,5),I=I>2&'(%#4)+$E(""144025036146"",I) X ""F %=%:-1:281 S I=%#4=1+1+I"" S RET=$P(""SUN^MON^TUES^WEDNES^THURS^FRI^SATUR"",U,$E(DATE,6,7)+I#7+1)_""DAY"""
+6 XECUTE DOW
+7 QUIT RET
