SDECUTL2 ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
;;5.3;Scheduling;**627,642,658,665**;Aug 13, 1993;Build 14
;
Q
;
RESAB(SDAB,SDCL,SDBEG,SDEND,SDECRES) ;build access blocks for 1 clinic
; SDECRES (optional) Resource pointer to SDEC RESOURCE file
; used to build access blocks from clinic availability
; for only this resource; all resources are build if null
; .01 name
; 2 type (clinic)
; 1912 length of app't
; 1914 hour clinic display begins default is 8am; whole number 0-16
; 1917 display increments per hour
; 2505 inactive date
; 2506 reactivate date
N SDAY,SDCLS,SDDATA,SDFIELDS,SDIN,SDLEN,SDRA,SDSI,SDT
I $P($G(SDBEG),".",1)'?7N S SDBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1)
I $P($G(SDEND),".",1)'?7N S SDEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),365)
S SDECRES=$G(SDECRES) I SDECRES'="",'$D(^SDEC(409.831,+SDECRES,0)) S SDECRES=""
S SDFIELDS=".01;2;1912;1914;1917;2505;2506"
D GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA","SDMSG")
Q:SDDATA(44,SDCL_",",2,"I")'="C" ;only clinic
I $$INACTIVE(SDCL,.SDBEG,.SDEND,SDDATA(44,SDCL_",",2505,"I"),SDDATA(44,SDCL_",",2506,"I")) Q ;only active
S SDLEN=SDDATA(44,SDCL_",",1912,"I") ;length of app't is required in file 44
S SDCLS=SDDATA(44,SDCL_",",1914,"I") ;hour clinic display begins
S:SDCLS="" SDCLS=8
S SDSI=SDDATA(44,SDCL_",",1917,"I")
;add to SDEC ACCESS BLOCK from AVAILABILITY in file 44
I 0 S SDAY=$$FMADD^XLFDT(SDBEG,-1) F S SDAY=$O(^SC(SDCL,"T",SDAY)) Q:SDAY'>0 Q:SDAY>SDEND D
.D RESABDAY(SDAB,SDCL,SDAY,SDLEN,SDCLS,+SDECRES)
;add to SDEC ACCESS BLOCK from day templates in file 44
;F SDT="T0","T1","T2","T3","T4","T5","T6" D
D TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND)
Q
;
TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND) ;add/update access blocks for day template SDT
;SDBEG = (optional) Start date in fileman format; defaults to 'today'
;SDEND = (optional) Stop date in fileman format; defaults to 365 days
N SDAY,SDAY1,SDBLKS,SDE,SDE1,SDJ,SDPAT,SDPAT1,SDSIM
S SDCL=$G(SDCL)
Q:SDCL=""
;S SDT=$G(SDT)
;Q:SDT'?1"T"1N
S SDLEN=$G(SDLEN)
I SDLEN="" S SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
S SDCLS=$G(SDCLS)
I SDCLS="" S SDCLS=$$GET1^DIQ(44,SDCL_",",1914) ;SDCLS=8
S SDSI=$G(SDSI)
I SDSI="" S SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I") ;SDDATA(44,SDCL_",",1917,"I")
S SDBEG=$G(SDBEG)
;S STDAT=$O(^SC(SDCL,"T",0)) S:STDAT<1 STDAT=DT
;S SDBEG=$S(SDBEG'?7N:STDAT,SDBEG<STDAT:STDAT,1:SDBEG)
;S SDAY1=$$FMADD^XLFDT(SDBEG,-1)
;S SDEND=$G(SDEND) I SDEND="" S SDEND=SDBEG_".2359"
;
;SDBEG - SDEND
;F S SDAY1=$$FMADD^XLFDT(SDAY1,1) Q:$P(SDAY1,".",1)>$P(SDEND,".",1) D TDAY1
D TDAY1
Q
TDAY1 ;
N D,SDA,SDTP,SS,ST,Y
S SDA=$S(SDSI=3:6,SDSI=6:12,1:8)
S SDTP=""
I '$D(^SC(SDCL,"ST",$P(SDBEG,".",1),1)) S ST='$$ST(SDCL,SDBEG) Q:ST
;Q:'$D(^SC(SDCL,"ST",$P(SDBEG,".",1),1))
I $D(^SC(SDCL,"ST",$P(SDBEG,".",1),9)) S SDTP=$G(^SC(SDCL,"OST",$P(SDBEG,".",1),1)) S SDTP=$E(SDTP,SDA,$L(SDTP))
E D
.S D=$$DOW^XLFDT($P(SDBEG,".",1),1)
.S Y=D#7
.S SS=$$FDT(SDCL,Y)
.Q:SS=""
.S SDTP=SS
Q:SDTP=""
K SDBLKS
D GETBLKS^SDECUTL1(.SDBLKS,SDTP,$P(SDBEG,".",1),SDCLS,SDLEN,SDSI,SDCL)
D RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,$P(SDBEG,".",1))
K SDBLKS
Q
;
S SDPAT1=$E($P($T(DAY),U,$E(SDT,2)+2),1,2)
S SDAY=$S(SDAY1'="":$$FMADD^XLFDT(SDAY1,-1),1:$P($$NOW^XLFDT,".",1)) ;$$FMADD^XLFDT(SDE,-1)
S SDE1=$$FMADD^XLFDT(SDAY,1) ;$S(SDEND'="":SDEND,1:$$FMADD^XLFDT(SDAY,365)) ;$S(SDAY1'="":SDAY1,1:$$FMADD^XLFDT(SDAY,365))
F S SDAY=$$FMADD^XLFDT($P($$SCH^XLFDT($E("UMTWRFS",$E(SDT,2)+1),SDAY),".",1),1) Q:SDAY'>0 Q:SDAY>SDE1 D ;alb/sat 665
.I $$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y",$D(^HOLIDAY("B",SDAY)) Q ;do not schedule on holidays
.Q:$D(^SC(SDCL,"T",SDAY,2,1)) ;if AVAILABILITY defined, this day is already built
.S SDSIM=$S(SDSI="":4,SDSI<3:4,SDSI:SDSI,1:4)
.S SDPAT=SDPAT1_" "_$E(SDAY,6,7)_$J("",SDSIM+SDSIM-6)_SDTP
.K SDBLKS
.D GETBLKS^SDECUTL1(.SDBLKS,SDPAT,SDAY,SDCLS,SDLEN,SDSI,SDCL)
.D RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,SDAY)
.K SDBLKS
Q
ST(SDCL,SDBEG) ;build ST
;RETURN - 0=not buildable or built as holiday ;1=buildable
N D,SC,SDDT,SS,Y
S SDDT=$P(SDBEG,".",1)
S SC=SDCL
S D=$$DOW^XLFDT(SDDT,1)
S Y=D#7
I $D(^HOLIDAY(SDDT))&($$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y") D H Q 0
S SS=$$FDT(SDCL,Y)
Q:+SS="" 0
S ^SC(+SDCL,"ST",SDDT,1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SDDT,6,7)_$S(SDSI=3:"",SDSI=6:" ",1:" ")_SS,^SC(+SDCL,"ST",SDDT,0)=SDDT
Q 1
FDT(SDCL,Y) ;find day template pattern
N SDE,SDTP
S SDTP=""
S SDE=$O(^SC(SDCL,"T"_Y,99999999),-1)
Q:'SDE ""
S SDTP=$G(^SC(SDCL,"T"_Y,SDE,1))
Q:SDTP="" ""
F S SDE=$O(^SC(SDCL,"T"_Y,SDE),-1) Q:SDE'>0 Q:$P(SDBEG,".",1)'<SDE S SDTP=$G(^SC(SDCL,"T"_Y,SDE,1)) ;alb/sat 665
Q SDTP
H ;update ST as holiday
S ^SC(+SC,"ST",X,1)=" "_$E(X,6,7)_" "_$P(^HOLIDAY(X,0),U,2),^SC(+SC,"ST",X,0)=X
Q
;
RESABDAY(SDAB,SDCL,SDAY,SDLEN,SDCLS,SDECRES) ;add/update access blocks for AVAILABILITY on a specific day
;INPUT:
; SDAB - (required) global name for access blocks - "^TMP("_$J_",""SDEC"",""BLKS"")"
; SDCL - (required) clinic ID
; SDAY - (required) date in fm format (no time)
; SDLEN - (optional) length of appointment
; SDCLS - (optional) hour schedule starts; default to 8
; SDECRES - (optional) pointer to SDEC RESOURCE file
N SDBLKS
S SDCL=$G(SDCL)
Q:SDCL=""
S SDECRES=$G(SDECRES)
S SDAY=$G(SDAY)
Q:SDAY'?7N
S SDLEN=$G(SDLEN)
I SDLEN="" S SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
S SDCLS=$G(SDCLS)
I SDCLS="" S SDCLS=$$GET1^DIQ(44,SDCL_",",1914) ;SDCLS=8
D SDAY(.SDBLKS,SDCL,SDAY,SDLEN,SDCLS)
I $D(SDBLKS) D RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,SDAY,SDECRES)
;D CA^SDEC12(SDCL,SDAY)
Q
;
SDAY(SDBLKS,SDCL,SDAY,SDLEN,SDCLS) ;build blocks for the day
;INPUT:
; SDCL - clinic pointer to HOSPITAL LOCATION file
; SDAY - date (no time) in FM format
; SDLEN - length of appointment in minutes
; SDCLS - hour clinic display begins default is 8am; whole number 0-16
N SDATAV,SDATUN,SDB1,SDBI,SDDH,SDEND,SDEND1,SDNOD2,SDSI,SDTIME
N SDAV,SDCLS4
N PSLOT,PTIME
S:$G(SDCLS)="" SDCLS=8
S SDCLS4=$S($L(SDCLS)=1:"0",1:"")_SDCLS_"00"
S SDATAV=$O(^SDEC(409.823,"B","AVAILABLE",0))
S SDATUN=$O(^SDEC(409.823,"B","UNAVAILABLE",0))
S SDDH=$$GET1^DIQ(44,SDCL_",",1917,"E") ;display increments per hour
S SDDH=$E(SDDH,1,2)
S SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I") ;display increments per hour (internal)
S (PTIME,PSLOT,SDB1)=""
S SDBI=0
K SDBLKS
S SDTIME=$O(^SC(SDCL,"T",SDAY,2,0))
Q:SDTIME=""
D SDAV(.SDAV,SDCL,SDAY,SDLEN,SDCLS,SDSI)
S SDNOD2=$G(SDAV(2,SDTIME,0)) I $$COMPARE(SDCLS4,$P(SDNOD2,U,1))=2 D
.S SDBI=SDBI+1 S SDBLKS(SDBI)=$$FM(SDAY_"."_SDCLS4)_U_$$FM(SDAY_"."_$P(SDNOD2,U,1))_U_U_SDATUN
S SDTIME=0 F S SDTIME=$O(SDAV(2,SDTIME)) Q:SDTIME'>0 D ;alb/sat 665
.S SDNOD2=$G(SDAV(2,SDTIME,0))
.S:SDB1="" SDB1=$P(SDNOD2,U,1)
.I PTIME'="" D
..I (PSLOT'=$P(SDNOD2,U,2))!(($$ADD(PTIME,SDLEN)'=$P(SDNOD2,U,1))) D ;new block
...S SDEND=$$ADD(PTIME,SDLEN) S SDEND=$S(SDEND<$P(SDNOD2,U,1):SDEND,1:$P(SDNOD2,U,1)) ;use the lesser of the 2
...S SDEND1=$S($E(SDEND,1,2)>23:"2359",1:SDEND)
...;S SDEND1=$S($E(SDEND,1,2)>23:"0000",1:SDEND)
...S SDBI=SDBI+1 S SDBLKS(SDBI)=$$FM(SDAY_"."_SDB1)_U_$$FM(SDAY_"."_SDEND1)_U_PSLOT_U_SDATAV
...I SDEND'=$P(SDNOD2,U,1) D
....S SDBI=SDBI+1 S SDBLKS(SDBI)=$$FM(SDAY_"."_SDEND)_U_$$FM(SDAY_"."_$P(SDNOD2,U,1))_U_0_U_SDATUN
...S SDB1=$P(SDNOD2,U,1)
.S PTIME=$P(SDNOD2,U,1)
.S PSLOT=$P(SDNOD2,U,2)
I SDB1'="" D ;setup last block
.S SDEND=$$ADD(PTIME,$S(SDLEN>SDDH:SDLEN,1:SDDH))
.S SDEND1=$S($E(SDEND,1,2)>23:"2359",1:SDEND)
.;S SDEND1=$S($E(SDEND,1,2)>23:"0000",1:SDEND)
.I $E(SDEND,1,2)>23 S SDEND="2359"
.;I $E(SDEND,1,2)>23 S SDEND="0000"
.S SDBI=SDBI+1 S SDBLKS(SDBI)=$$FM(SDAY_"."_SDB1)_U_$$FM(SDAY_"."_SDEND)_U_PSLOT_U_SDATAV
I PTIME<1800 D
.S SDBI=SDBI+1 S SDBLKS(SDBI)=$$FM(SDAY_"."_SDEND)_U_$$FM(SDAY_".1800")_U_0_U_SDATUN
K SDAV
Q
;
COMPARE(T1,T2) ;compare time
;RETURN:
; 0 = same
; 1 = T1 is greater than
; 2 = T1 is less than
N T1M,T2M
S T1M=+T1,T2M=+T2
Q:T1M=T2M 0
Q:T1M>T2M 1
Q:T1M<T2M 2
Q -1 ;sanity check should not happen
;
ADD(HM,M) ;add minutes M to HourMinute HM and return with 4 digit military time
N H1,M1
S H1=$E(HM,1,2)
S M1=$E(HM,3,4)
S M1=M1+M
AGAIN I M1>59 S M1=M1-60,H1=H1+1 G:M1>59 AGAIN
I $L(H1)=1 S H1="0"_H1
I $L(M1)=1 S M1="0"_M1
Q H1_M1
;
FM(SDDATE) ;use to strip zeros off of the end of the time
N %DT,X,Y
S %DT="DT",X=SDDATE D ^%DT
Q Y
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
SDB(SDEC) ;add/update access blocks after clinic modifications using SDBUILD in routine SDB
; SDEC = array of modified days or day templates
; SDEC(<clinic ID>,<day/template>)=""
; day = date in FM format
; template = T#
N %,SDCL,SDCLN,SDT
S SDCL="" F S SDCL=$O(SDEC(SDCL)) Q:SDCL="" D
.D SDRES(SDCL)
.S SDT="" F S SDT=$O(SDEC(SDCL,SDT)) Q:SDT="" D
..I $E(SDT,1)="T" D TDAY(SDCL,SDT)
..I SDT?7N D RESABDAY(SDCL,SDT)
K SDEC
Q
;
SDRES(SDCL) ;add clinic resource
N ABBR,SDDATA,SDDI,SDFDA,SDFOUND,SDI,SDNOD,SDRT
S SDFOUND=0
S SDI="" F S SDI=$O(^SDEC(409.831,"ALOC",SDCL,SDI)) Q:SDI="" D Q:SDFOUND=1
.S SDNOD=$G(^SDEC(409.831,SDI,0))
.S SDRT=$P(SDNOD,U,11)
.I $P(SDRT,";",2)="SC(",$P(SDRT,";",1)=SDCL S SDFOUND=1
S SDI=$S(SDFOUND=1:SDI,1:"+1")
S SDFIELDS=".01;1;1917" ;alb/sat 658 - add field 1
D GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA")
S SDFDA(409.831,SDI_",",.01)=SDDATA(44,SDCL_",",.01,"E")
S SDDI=SDDATA(44,SDCL_",",1917,"E") S SDFDA(409.831,SDI_",",.03)=$E(SDDI,1,2)
S ABBR=SDDATA(44,SDCL_",",1,"E") S:ABBR'="" SDFDA(409.831,SDI_",",.011)=ABBR ;alb/sat 658 - add abbreviation
S SDFDA(409.831,SDI_",",.04)=SDCL
S SDFDA(409.831,SDI_",",.012)=SDCL_";SC("
S SDFDA(409.831,SDI_",",.015)=$E($$NOW^XLFDT,1,12)
S SDFDA(409.831,SDI_",",.016)=DUZ
D UPDATE^DIE("","SDFDA")
Q
;
INACTIVE(SDCL,SDBEG,SDEND,IDATE,RDATE) ;
;INPUT:
; SDCL - clinic ID
; .SDBEG - begin date in FM format, no time
; .SDEND - end date in FM format, no time
; IDATE - clinic's inactivation date
; RDATE - clinic's reactivation date
;RETURN:
; 0=Clinic is active
; 1=Clinic is inactive
; active 0 0
I IDATE="" Q 0
; active but inactivated in future
I IDATE>SDBEG S SDEND=IDATE Q 0
; inactive 1 0
I IDATE'>SDBEG,RDATE="" Q 1 ;alb/sat 665
; inactive 1 1 inactive but reactivated
; inactive now reactive now
I IDATE'>SDBEG,RDATE'>SDBEG Q 0 ;alb/sat 665
; inactive now reactive future
I IDATE'>SDBEG,RDATE>IDATE S SDBEG=RDATE Q 0 ;alb/sat 665
Q 1
;
DEL ;
N H
S H=0 F S H=$O(^SDEC(409.821,H)) Q:H'>0 W !,H," ",$G(^SDEC(409.821,H,0)) S SDFDA(409.821,H_",",.01)="@" D UPDATE^DIE("","SDFDA")
K ^SDEC(409.821,"ARSCT")
Q
DEL1 ;
N H
S H=0 F S H=$O(^SDEC(409.821,H)) Q:H'>0 S SDFDA(409.821,H_",",.01)="@" D UPDATE^DIE("","SDFDA")
K ^SDEC(409.821,"ARSCT")
Q
;
ARRAY(DTARRAY,SDPAT,SDAY,SDLEN,SDCLS,SDSI,SDF) ;build date/time array from pattern
; .DTARRAY - Array of cancelled date/times
; CARRAY(FMDATE,TIME)=<slots>
; SDPAT - (required) pattern
; SDAY - (required) date in FM format (no time)
; SDLEN - (required) length of appointment
; SDCLS - (required) hour schedule starts; default to 8
; SDSI - (required) display increments per hour
N SDA,SDI,SDSIM
;SDSIM - calculated using DISPLAY INCREMENTS PER HOUR field from file 44
; $S(X="":4,X<3:4,X:X,1:4)
S SDF=$G(SDF,0) ;cancelled flag
S SDA=$S(SDSI=3:6,SDSI=6:12,1:8)
S SDSIM=$S(SDSI="":4,SDSI<3:4,SDSI:SDSI,1:4)
;S:$E(SDPAT)?1A SDPAT=$E(SDPAT,SDA,$L(SDPAT))
;1 2 3 4 OR 6
D @SDSI
Q
1 ;1 increments per hour (60 min)
N BSTART,CNT,HOUR,SDI
S BSTART=""
S SDI=0
S HOUR=SDCLS-1
F CNT=2:8 Q:CNT>$L(SDPAT) D
.I (CNT#8)=2 S HOUR=HOUR+1
.S BSTART=SDAY_"."_$S($L(HOUR)=1:"0"_HOUR,1:HOUR)
.S DTARRAY($P(BSTART,".",1),$P(BSTART,".",2))=$S(+SDF:"X",1:$E(SDPAT,CNT))
Q
2 ;2 increments per hour (30 min)
N BSTART,CNT,HOUR
S BSTART=""
S SDI=0
S HOUR=SDCLS-1
F CNT=2:4 Q:CNT>$L(SDPAT) D
.I (CNT#8)=2 S HOUR=HOUR+1
.S BSTART=SDAY_"."_$S($L(HOUR)=1:"0"_HOUR,1:HOUR)_$S((CNT#8)=6:30,1:"00")
.S DTARRAY($P(BSTART,".",1),$P(BSTART,".",2))=$S(+SDF:"X",1:$E(SDPAT,CNT))
Q
3 ;3 increments per hour (20 min)
N BSTART,CNT,HOUR
S BSTART=""
S SDI=0
S HOUR=SDCLS-1
F CNT=2:2 Q:CNT>$L(SDPAT) D
.I (CNT#6)=2 S HOUR=HOUR+1
.S BSTART=SDAY_"."_$S($L(HOUR)=1:"0"_HOUR,1:HOUR)_$S((CNT#6)=4:20,(CNT#6)=0:40,1:"00")
.S DTARRAY($P(BSTART,".",1),$P(BSTART,".",2))=$S(+SDF:"X",1:$E(SDPAT,CNT))
Q
4 ;4 increments per hour (15 min)
N BSTART,CNT,HOUR
S BSTART=""
S SDI=0
S HOUR=SDCLS-1
F CNT=2:2 Q:CNT>$L(SDPAT) D
.I (CNT#8)=2 S HOUR=HOUR+1
.S BSTART=SDAY_"."_$S($L(HOUR)=1:"0"_HOUR,1:HOUR)_$S((CNT#8)=4:15,(CNT#8)=6:30,(CNT#8)=0:45,1:"00")
.S DTARRAY($P(BSTART,".",1),$P(BSTART,".",2))=$S(+SDF:"X",1:$E(SDPAT,CNT))
Q
6 ;6 increments per hour (10 min)
N BSTART,CNT,HOUR
S BSTART=""
S SDI=0
S HOUR=SDCLS-1
F CNT=2:2 Q:CNT>$L(SDPAT) D
.I (CNT#12)=2 S HOUR=HOUR+1
.S BSTART=SDAY_"."_$S($L(HOUR)=1:"0"_HOUR,1:HOUR)_$S((CNT#12)=4:10,(CNT#12)=6:20,(CNT#12)=8:30,(CNT#12)=10:40,(CNT#12)=0:50,1:"00")
.S DTARRAY($P(BSTART,".",1),$P(BSTART,".",2))=$S(+SDF:"X",1:$E(SDPAT,CNT))
Q
SDAV(SDAV,SDCL,SDAY,SDLEN,SDCLS,SDSI) ;build modified availability array from AVAILABILITY in 44
N DTARRAY
N SDCAN,SDI,SDPAT,SDTIME
K SDAV
M SDAV=^SC(SDCL,"T",SDAY)
S SDPAT=$G(^SC(SDCL,"ST",SDAY,1)) ;get PATTERN from file 44
Q:SDPAT=""
D ARRAY(.DTARRAY,SDPAT,SDAY,SDLEN,SDCLS,SDSI) ;convert pattern to array
S SDTIME=0 F S SDTIME=$O(SDAV(2,SDTIME)) Q:SDTIME'>0 D
.S SDNOD2=$G(SDAV(2,SDTIME,0))
.I $G(DTARRAY(SDAY,$P(SDNOD2,U,1)))="X" D
..K SDAV(2,SDTIME,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECUTL2 14028 printed Apr 09, 2024@21:39:58 Page 2
SDECUTL2 ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
+1 ;;5.3;Scheduling;**627,642,658,665**;Aug 13, 1993;Build 14
+2 ;
+3 QUIT
+4 ;
RESAB(SDAB,SDCL,SDBEG,SDEND,SDECRES) ;build access blocks for 1 clinic
+1 ; SDECRES (optional) Resource pointer to SDEC RESOURCE file
+2 ; used to build access blocks from clinic availability
+3 ; for only this resource; all resources are build if null
+4 ; .01 name
+5 ; 2 type (clinic)
+6 ; 1912 length of app't
+7 ; 1914 hour clinic display begins default is 8am; whole number 0-16
+8 ; 1917 display increments per hour
+9 ; 2505 inactive date
+10 ; 2506 reactivate date
+11 NEW SDAY,SDCLS,SDDATA,SDFIELDS,SDIN,SDLEN,SDRA,SDSI,SDT
+12 IF $PIECE($GET(SDBEG),".",1)'?7N
SET SDBEG=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),-1)
+13 IF $PIECE($GET(SDEND),".",1)'?7N
SET SDEND=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),365)
+14 SET SDECRES=$GET(SDECRES)
IF SDECRES'=""
IF '$DATA(^SDEC(409.831,+SDECRES,0))
SET SDECRES=""
+15 SET SDFIELDS=".01;2;1912;1914;1917;2505;2506"
+16 DO GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA","SDMSG")
+17 ;only clinic
if SDDATA(44,SDCL_",",2,"I")'="C"
QUIT
+18 ;only active
IF $$INACTIVE(SDCL,.SDBEG,.SDEND,SDDATA(44,SDCL_",",2505,"I"),SDDATA(44,SDCL_",",2506,"I"))
QUIT
+19 ;length of app't is required in file 44
SET SDLEN=SDDATA(44,SDCL_",",1912,"I")
+20 ;hour clinic display begins
SET SDCLS=SDDATA(44,SDCL_",",1914,"I")
+21 if SDCLS=""
SET SDCLS=8
+22 SET SDSI=SDDATA(44,SDCL_",",1917,"I")
+23 ;add to SDEC ACCESS BLOCK from AVAILABILITY in file 44
+24 IF 0
SET SDAY=$$FMADD^XLFDT(SDBEG,-1)
FOR
SET SDAY=$ORDER(^SC(SDCL,"T",SDAY))
if SDAY'>0
QUIT
if SDAY>SDEND
QUIT
Begin DoDot:1
+25 DO RESABDAY(SDAB,SDCL,SDAY,SDLEN,SDCLS,+SDECRES)
End DoDot:1
+26 ;add to SDEC ACCESS BLOCK from day templates in file 44
+27 ;F SDT="T0","T1","T2","T3","T4","T5","T6" D
+28 DO TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND)
+29 QUIT
+30 ;
TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND) ;add/update access blocks for day template SDT
+1 ;SDBEG = (optional) Start date in fileman format; defaults to 'today'
+2 ;SDEND = (optional) Stop date in fileman format; defaults to 365 days
+3 NEW SDAY,SDAY1,SDBLKS,SDE,SDE1,SDJ,SDPAT,SDPAT1,SDSIM
+4 SET SDCL=$GET(SDCL)
+5 if SDCL=""
QUIT
+6 ;S SDT=$G(SDT)
+7 ;Q:SDT'?1"T"1N
+8 SET SDLEN=$GET(SDLEN)
+9 IF SDLEN=""
SET SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
+10 SET SDCLS=$GET(SDCLS)
+11 ;SDCLS=8
IF SDCLS=""
SET SDCLS=$$GET1^DIQ(44,SDCL_",",1914)
+12 SET SDSI=$GET(SDSI)
+13 ;SDDATA(44,SDCL_",",1917,"I")
IF SDSI=""
SET SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I")
+14 SET SDBEG=$GET(SDBEG)
+15 ;S STDAT=$O(^SC(SDCL,"T",0)) S:STDAT<1 STDAT=DT
+16 ;S SDBEG=$S(SDBEG'?7N:STDAT,SDBEG<STDAT:STDAT,1:SDBEG)
+17 ;S SDAY1=$$FMADD^XLFDT(SDBEG,-1)
+18 ;S SDEND=$G(SDEND) I SDEND="" S SDEND=SDBEG_".2359"
+19 ;
+20 ;SDBEG - SDEND
+21 ;F S SDAY1=$$FMADD^XLFDT(SDAY1,1) Q:$P(SDAY1,".",1)>$P(SDEND,".",1) D TDAY1
+22 DO TDAY1
+23 QUIT
TDAY1 ;
+1 NEW D,SDA,SDTP,SS,ST,Y
+2 SET SDA=$SELECT(SDSI=3:6,SDSI=6:12,1:8)
+3 SET SDTP=""
+4 IF '$DATA(^SC(SDCL,"ST",$PIECE(SDBEG,".",1),1))
SET ST='$$ST(SDCL,SDBEG)
if ST
QUIT
+5 ;Q:'$D(^SC(SDCL,"ST",$P(SDBEG,".",1),1))
+6 IF $DATA(^SC(SDCL,"ST",$PIECE(SDBEG,".",1),9))
SET SDTP=$GET(^SC(SDCL,"OST",$PIECE(SDBEG,".",1),1))
SET SDTP=$EXTRACT(SDTP,SDA,$LENGTH(SDTP))
+7 IF '$TEST
Begin DoDot:1
+8 SET D=$$DOW^XLFDT($PIECE(SDBEG,".",1),1)
+9 SET Y=D#7
+10 SET SS=$$FDT(SDCL,Y)
+11 if SS=""
QUIT
+12 SET SDTP=SS
End DoDot:1
+13 if SDTP=""
QUIT
+14 KILL SDBLKS
+15 DO GETBLKS^SDECUTL1(.SDBLKS,SDTP,$PIECE(SDBEG,".",1),SDCLS,SDLEN,SDSI,SDCL)
+16 DO RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,$PIECE(SDBEG,".",1))
+17 KILL SDBLKS
+18 QUIT
+19 ;
+20 SET SDPAT1=$EXTRACT($PIECE($TEXT(DAY),U,$EXTRACT(SDT,2)+2),1,2)
+21 ;$$FMADD^XLFDT(SDE,-1)
SET SDAY=$SELECT(SDAY1'="":$$FMADD^XLFDT(SDAY1,-1),1:$PIECE($$NOW^XLFDT,".",1))
+22 ;$S(SDEND'="":SDEND,1:$$FMADD^XLFDT(SDAY,365)) ;$S(SDAY1'="":SDAY1,1:$$FMADD^XLFDT(SDAY,365))
SET SDE1=$$FMADD^XLFDT(SDAY,1)
+23 ;alb/sat 665
FOR
SET SDAY=$$FMADD^XLFDT($PIECE($$SCH^XLFDT($EXTRACT("UMTWRFS",$EXTRACT(SDT,2)+1),SDAY),".",1),1)
if SDAY'>0
QUIT
if SDAY>SDE1
QUIT
Begin DoDot:1
+24 ;do not schedule on holidays
IF $$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y"
IF $DATA(^HOLIDAY("B",SDAY))
QUIT
+25 ;if AVAILABILITY defined, this day is already built
if $DATA(^SC(SDCL,"T",SDAY,2,1))
QUIT
+26 SET SDSIM=$SELECT(SDSI="":4,SDSI<3:4,SDSI:SDSI,1:4)
+27 SET SDPAT=SDPAT1_" "_$EXTRACT(SDAY,6,7)_$JUSTIFY("",SDSIM+SDSIM-6)_SDTP
+28 KILL SDBLKS
+29 DO GETBLKS^SDECUTL1(.SDBLKS,SDPAT,SDAY,SDCLS,SDLEN,SDSI,SDCL)
+30 DO RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,SDAY)
+31 KILL SDBLKS
End DoDot:1
+32 QUIT
ST(SDCL,SDBEG) ;build ST
+1 ;RETURN - 0=not buildable or built as holiday ;1=buildable
+2 NEW D,SC,SDDT,SS,Y
+3 SET SDDT=$PIECE(SDBEG,".",1)
+4 SET SC=SDCL
+5 SET D=$$DOW^XLFDT(SDDT,1)
+6 SET Y=D#7
+7 IF $DATA(^HOLIDAY(SDDT))&($$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y")
DO H
QUIT 0
+8 SET SS=$$FDT(SDCL,Y)
+9 if +SS=""
QUIT 0
+10 SET ^SC(+SDCL,"ST",SDDT,1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(SDDT,6,7)_$SELECT(SDSI=3:"",SDSI=6:" ",1:" ")_SS
SET ^SC(+SDCL,"ST",SDDT,0)=SDDT
+11 QUIT 1
FDT(SDCL,Y) ;find day template pattern
+1 NEW SDE,SDTP
+2 SET SDTP=""
+3 SET SDE=$ORDER(^SC(SDCL,"T"_Y,99999999),-1)
+4 if 'SDE
QUIT ""
+5 SET SDTP=$GET(^SC(SDCL,"T"_Y,SDE,1))
+6 if SDTP=""
QUIT ""
+7 ;alb/sat 665
FOR
SET SDE=$ORDER(^SC(SDCL,"T"_Y,SDE),-1)
if SDE'>0
QUIT
if $PIECE(SDBEG,".",1)'<SDE
QUIT
SET SDTP=$GET(^SC(SDCL,"T"_Y,SDE,1))
+8 QUIT SDTP
H ;update ST as holiday
+1 SET ^SC(+SC,"ST",X,1)=" "_$EXTRACT(X,6,7)_" "_$PIECE(^HOLIDAY(X,0),U,2)
SET ^SC(+SC,"ST",X,0)=X
+2 QUIT
+3 ;
RESABDAY(SDAB,SDCL,SDAY,SDLEN,SDCLS,SDECRES) ;add/update access blocks for AVAILABILITY on a specific day
+1 ;INPUT:
+2 ; SDAB - (required) global name for access blocks - "^TMP("_$J_",""SDEC"",""BLKS"")"
+3 ; SDCL - (required) clinic ID
+4 ; SDAY - (required) date in fm format (no time)
+5 ; SDLEN - (optional) length of appointment
+6 ; SDCLS - (optional) hour schedule starts; default to 8
+7 ; SDECRES - (optional) pointer to SDEC RESOURCE file
+8 NEW SDBLKS
+9 SET SDCL=$GET(SDCL)
+10 if SDCL=""
QUIT
+11 SET SDECRES=$GET(SDECRES)
+12 SET SDAY=$GET(SDAY)
+13 if SDAY'?7N
QUIT
+14 SET SDLEN=$GET(SDLEN)
+15 IF SDLEN=""
SET SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
+16 SET SDCLS=$GET(SDCLS)
+17 ;SDCLS=8
IF SDCLS=""
SET SDCLS=$$GET1^DIQ(44,SDCL_",",1914)
+18 DO SDAY(.SDBLKS,SDCL,SDAY,SDLEN,SDCLS)
+19 IF $DATA(SDBLKS)
DO RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,SDAY,SDECRES)
+20 ;D CA^SDEC12(SDCL,SDAY)
+21 QUIT
+22 ;
SDAY(SDBLKS,SDCL,SDAY,SDLEN,SDCLS) ;build blocks for the day
+1 ;INPUT:
+2 ; SDCL - clinic pointer to HOSPITAL LOCATION file
+3 ; SDAY - date (no time) in FM format
+4 ; SDLEN - length of appointment in minutes
+5 ; SDCLS - hour clinic display begins default is 8am; whole number 0-16
+6 NEW SDATAV,SDATUN,SDB1,SDBI,SDDH,SDEND,SDEND1,SDNOD2,SDSI,SDTIME
+7 NEW SDAV,SDCLS4
+8 NEW PSLOT,PTIME
+9 if $GET(SDCLS)=""
SET SDCLS=8
+10 SET SDCLS4=$SELECT($LENGTH(SDCLS)=1:"0",1:"")_SDCLS_"00"
+11 SET SDATAV=$ORDER(^SDEC(409.823,"B","AVAILABLE",0))
+12 SET SDATUN=$ORDER(^SDEC(409.823,"B","UNAVAILABLE",0))
+13 ;display increments per hour
SET SDDH=$$GET1^DIQ(44,SDCL_",",1917,"E")
+14 SET SDDH=$EXTRACT(SDDH,1,2)
+15 ;display increments per hour (internal)
SET SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I")
+16 SET (PTIME,PSLOT,SDB1)=""
+17 SET SDBI=0
+18 KILL SDBLKS
+19 SET SDTIME=$ORDER(^SC(SDCL,"T",SDAY,2,0))
+20 if SDTIME=""
QUIT
+21 DO SDAV(.SDAV,SDCL,SDAY,SDLEN,SDCLS,SDSI)
+22 SET SDNOD2=$GET(SDAV(2,SDTIME,0))
IF $$COMPARE(SDCLS4,$PIECE(SDNOD2,U,1))=2
Begin DoDot:1
+23 SET SDBI=SDBI+1
SET SDBLKS(SDBI)=$$FM(SDAY_"."_SDCLS4)_U_$$FM(SDAY_"."_$PIECE(SDNOD2,U,1))_U_U_SDATUN
End DoDot:1
+24 ;alb/sat 665
SET SDTIME=0
FOR
SET SDTIME=$ORDER(SDAV(2,SDTIME))
if SDTIME'>0
QUIT
Begin DoDot:1
+25 SET SDNOD2=$GET(SDAV(2,SDTIME,0))
+26 if SDB1=""
SET SDB1=$PIECE(SDNOD2,U,1)
+27 IF PTIME'=""
Begin DoDot:2
+28 ;new block
IF (PSLOT'=$PIECE(SDNOD2,U,2))!(($$ADD(PTIME,SDLEN)'=$PIECE(SDNOD2,U,1)))
Begin DoDot:3
+29 ;use the lesser of the 2
SET SDEND=$$ADD(PTIME,SDLEN)
SET SDEND=$SELECT(SDEND<$PIECE(SDNOD2,U,1):SDEND,1:$PIECE(SDNOD2,U,1))
+30 SET SDEND1=$SELECT($EXTRACT(SDEND,1,2)>23:"2359",1:SDEND)
+31 ;S SDEND1=$S($E(SDEND,1,2)>23:"0000",1:SDEND)
+32 SET SDBI=SDBI+1
SET SDBLKS(SDBI)=$$FM(SDAY_"."_SDB1)_U_$$FM(SDAY_"."_SDEND1)_U_PSLOT_U_SDATAV
+33 IF SDEND'=$PIECE(SDNOD2,U,1)
Begin DoDot:4
+34 SET SDBI=SDBI+1
SET SDBLKS(SDBI)=$$FM(SDAY_"."_SDEND)_U_$$FM(SDAY_"."_$PIECE(SDNOD2,U,1))_U_0_U_SDATUN
End DoDot:4
+35 SET SDB1=$PIECE(SDNOD2,U,1)
End DoDot:3
End DoDot:2
+36 SET PTIME=$PIECE(SDNOD2,U,1)
+37 SET PSLOT=$PIECE(SDNOD2,U,2)
End DoDot:1
+38 ;setup last block
IF SDB1'=""
Begin DoDot:1
+39 SET SDEND=$$ADD(PTIME,$SELECT(SDLEN>SDDH:SDLEN,1:SDDH))
+40 SET SDEND1=$SELECT($EXTRACT(SDEND,1,2)>23:"2359",1:SDEND)
+41 ;S SDEND1=$S($E(SDEND,1,2)>23:"0000",1:SDEND)
+42 IF $EXTRACT(SDEND,1,2)>23
SET SDEND="2359"
+43 ;I $E(SDEND,1,2)>23 S SDEND="0000"
+44 SET SDBI=SDBI+1
SET SDBLKS(SDBI)=$$FM(SDAY_"."_SDB1)_U_$$FM(SDAY_"."_SDEND)_U_PSLOT_U_SDATAV
End DoDot:1
+45 IF PTIME<1800
Begin DoDot:1
+46 SET SDBI=SDBI+1
SET SDBLKS(SDBI)=$$FM(SDAY_"."_SDEND)_U_$$FM(SDAY_".1800")_U_0_U_SDATUN
End DoDot:1
+47 KILL SDAV
+48 QUIT
+49 ;
COMPARE(T1,T2) ;compare time
+1 ;RETURN:
+2 ; 0 = same
+3 ; 1 = T1 is greater than
+4 ; 2 = T1 is less than
+5 NEW T1M,T2M
+6 SET T1M=+T1
SET T2M=+T2
+7 if T1M=T2M
QUIT 0
+8 if T1M>T2M
QUIT 1
+9 if T1M<T2M
QUIT 2
+10 ;sanity check should not happen
QUIT -1
+11 ;
ADD(HM,M) ;add minutes M to HourMinute HM and return with 4 digit military time
+1 NEW H1,M1
+2 SET H1=$EXTRACT(HM,1,2)
+3 SET M1=$EXTRACT(HM,3,4)
+4 SET M1=M1+M
AGAIN IF M1>59
SET M1=M1-60
SET H1=H1+1
if M1>59
GOTO AGAIN
+1 IF $LENGTH(H1)=1
SET H1="0"_H1
+2 IF $LENGTH(M1)=1
SET M1="0"_M1
+3 QUIT H1_M1
+4 ;
FM(SDDATE) ;use to strip zeros off of the end of the time
+1 NEW %DT,X,Y
+2 SET %DT="DT"
SET X=SDDATE
DO ^%DT
+3 QUIT Y
+4 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
SDB(SDEC) ;add/update access blocks after clinic modifications using SDBUILD in routine SDB
+1 ; SDEC = array of modified days or day templates
+2 ; SDEC(<clinic ID>,<day/template>)=""
+3 ; day = date in FM format
+4 ; template = T#
+5 NEW %,SDCL,SDCLN,SDT
+6 SET SDCL=""
FOR
SET SDCL=$ORDER(SDEC(SDCL))
if SDCL=""
QUIT
Begin DoDot:1
+7 DO SDRES(SDCL)
+8 SET SDT=""
FOR
SET SDT=$ORDER(SDEC(SDCL,SDT))
if SDT=""
QUIT
Begin DoDot:2
+9 IF $EXTRACT(SDT,1)="T"
DO TDAY(SDCL,SDT)
+10 IF SDT?7N
DO RESABDAY(SDCL,SDT)
End DoDot:2
End DoDot:1
+11 KILL SDEC
+12 QUIT
+13 ;
SDRES(SDCL) ;add clinic resource
+1 NEW ABBR,SDDATA,SDDI,SDFDA,SDFOUND,SDI,SDNOD,SDRT
+2 SET SDFOUND=0
+3 SET SDI=""
FOR
SET SDI=$ORDER(^SDEC(409.831,"ALOC",SDCL,SDI))
if SDI=""
QUIT
Begin DoDot:1
+4 SET SDNOD=$GET(^SDEC(409.831,SDI,0))
+5 SET SDRT=$PIECE(SDNOD,U,11)
+6 IF $PIECE(SDRT,";",2)="SC("
IF $PIECE(SDRT,";",1)=SDCL
SET SDFOUND=1
End DoDot:1
if SDFOUND=1
QUIT
+7 SET SDI=$SELECT(SDFOUND=1:SDI,1:"+1")
+8 ;alb/sat 658 - add field 1
SET SDFIELDS=".01;1;1917"
+9 DO GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA")
+10 SET SDFDA(409.831,SDI_",",.01)=SDDATA(44,SDCL_",",.01,"E")
+11 SET SDDI=SDDATA(44,SDCL_",",1917,"E")
SET SDFDA(409.831,SDI_",",.03)=$EXTRACT(SDDI,1,2)
+12 ;alb/sat 658 - add abbreviation
SET ABBR=SDDATA(44,SDCL_",",1,"E")
if ABBR'=""
SET SDFDA(409.831,SDI_",",.011)=ABBR
+13 SET SDFDA(409.831,SDI_",",.04)=SDCL
+14 SET SDFDA(409.831,SDI_",",.012)=SDCL_";SC("
+15 SET SDFDA(409.831,SDI_",",.015)=$EXTRACT($$NOW^XLFDT,1,12)
+16 SET SDFDA(409.831,SDI_",",.016)=DUZ
+17 DO UPDATE^DIE("","SDFDA")
+18 QUIT
+19 ;
INACTIVE(SDCL,SDBEG,SDEND,IDATE,RDATE) ;
+1 ;INPUT:
+2 ; SDCL - clinic ID
+3 ; .SDBEG - begin date in FM format, no time
+4 ; .SDEND - end date in FM format, no time
+5 ; IDATE - clinic's inactivation date
+6 ; RDATE - clinic's reactivation date
+7 ;RETURN:
+8 ; 0=Clinic is active
+9 ; 1=Clinic is inactive
+10 ; active 0 0
+11 IF IDATE=""
QUIT 0
+12 ; active but inactivated in future
+13 IF IDATE>SDBEG
SET SDEND=IDATE
QUIT 0
+14 ; inactive 1 0
+15 ;alb/sat 665
IF IDATE'>SDBEG
IF RDATE=""
QUIT 1
+16 ; inactive 1 1 inactive but reactivated
+17 ; inactive now reactive now
+18 ;alb/sat 665
IF IDATE'>SDBEG
IF RDATE'>SDBEG
QUIT 0
+19 ; inactive now reactive future
+20 ;alb/sat 665
IF IDATE'>SDBEG
IF RDATE>IDATE
SET SDBEG=RDATE
QUIT 0
+21 QUIT 1
+22 ;
DEL ;
+1 NEW H
+2 SET H=0
FOR
SET H=$ORDER(^SDEC(409.821,H))
if H'>0
QUIT
WRITE !,H," ",$GET(^SDEC(409.821,H,0))
SET SDFDA(409.821,H_",",.01)="@"
DO UPDATE^DIE("","SDFDA")
+3 KILL ^SDEC(409.821,"ARSCT")
+4 QUIT
DEL1 ;
+1 NEW H
+2 SET H=0
FOR
SET H=$ORDER(^SDEC(409.821,H))
if H'>0
QUIT
SET SDFDA(409.821,H_",",.01)="@"
DO UPDATE^DIE("","SDFDA")
+3 KILL ^SDEC(409.821,"ARSCT")
+4 QUIT
+5 ;
ARRAY(DTARRAY,SDPAT,SDAY,SDLEN,SDCLS,SDSI,SDF) ;build date/time array from pattern
+1 ; .DTARRAY - Array of cancelled date/times
+2 ; CARRAY(FMDATE,TIME)=<slots>
+3 ; SDPAT - (required) pattern
+4 ; SDAY - (required) date in FM format (no time)
+5 ; SDLEN - (required) length of appointment
+6 ; SDCLS - (required) hour schedule starts; default to 8
+7 ; SDSI - (required) display increments per hour
+8 NEW SDA,SDI,SDSIM
+9 ;SDSIM - calculated using DISPLAY INCREMENTS PER HOUR field from file 44
+10 ; $S(X="":4,X<3:4,X:X,1:4)
+11 ;cancelled flag
SET SDF=$GET(SDF,0)
+12 SET SDA=$SELECT(SDSI=3:6,SDSI=6:12,1:8)
+13 SET SDSIM=$SELECT(SDSI="":4,SDSI<3:4,SDSI:SDSI,1:4)
+14 ;S:$E(SDPAT)?1A SDPAT=$E(SDPAT,SDA,$L(SDPAT))
+15 ;1 2 3 4 OR 6
+16 DO @SDSI
+17 QUIT
1 ;1 increments per hour (60 min)
+1 NEW BSTART,CNT,HOUR,SDI
+2 SET BSTART=""
+3 SET SDI=0
+4 SET HOUR=SDCLS-1
+5 FOR CNT=2:8
if CNT>$LENGTH(SDPAT)
QUIT
Begin DoDot:1
+6 IF (CNT#8)=2
SET HOUR=HOUR+1
+7 SET BSTART=SDAY_"."_$SELECT($LENGTH(HOUR)=1:"0"_HOUR,1:HOUR)
+8 SET DTARRAY($PIECE(BSTART,".",1),$PIECE(BSTART,".",2))=$SELECT(+SDF:"X",1:$EXTRACT(SDPAT,CNT))
End DoDot:1
+9 QUIT
2 ;2 increments per hour (30 min)
+1 NEW BSTART,CNT,HOUR
+2 SET BSTART=""
+3 SET SDI=0
+4 SET HOUR=SDCLS-1
+5 FOR CNT=2:4
if CNT>$LENGTH(SDPAT)
QUIT
Begin DoDot:1
+6 IF (CNT#8)=2
SET HOUR=HOUR+1
+7 SET BSTART=SDAY_"."_$SELECT($LENGTH(HOUR)=1:"0"_HOUR,1:HOUR)_$SELECT((CNT#8)=6:30,1:"00")
+8 SET DTARRAY($PIECE(BSTART,".",1),$PIECE(BSTART,".",2))=$SELECT(+SDF:"X",1:$EXTRACT(SDPAT,CNT))
End DoDot:1
+9 QUIT
3 ;3 increments per hour (20 min)
+1 NEW BSTART,CNT,HOUR
+2 SET BSTART=""
+3 SET SDI=0
+4 SET HOUR=SDCLS-1
+5 FOR CNT=2:2
if CNT>$LENGTH(SDPAT)
QUIT
Begin DoDot:1
+6 IF (CNT#6)=2
SET HOUR=HOUR+1
+7 SET BSTART=SDAY_"."_$SELECT($LENGTH(HOUR)=1:"0"_HOUR,1:HOUR)_$SELECT((CNT#6)=4:20,(CNT#6)=0:40,1:"00")
+8 SET DTARRAY($PIECE(BSTART,".",1),$PIECE(BSTART,".",2))=$SELECT(+SDF:"X",1:$EXTRACT(SDPAT,CNT))
End DoDot:1
+9 QUIT
4 ;4 increments per hour (15 min)
+1 NEW BSTART,CNT,HOUR
+2 SET BSTART=""
+3 SET SDI=0
+4 SET HOUR=SDCLS-1
+5 FOR CNT=2:2
if CNT>$LENGTH(SDPAT)
QUIT
Begin DoDot:1
+6 IF (CNT#8)=2
SET HOUR=HOUR+1
+7 SET BSTART=SDAY_"."_$SELECT($LENGTH(HOUR)=1:"0"_HOUR,1:HOUR)_$SELECT((CNT#8)=4:15,(CNT#8)=6:30,(CNT#8)=0:45,1:"00")
+8 SET DTARRAY($PIECE(BSTART,".",1),$PIECE(BSTART,".",2))=$SELECT(+SDF:"X",1:$EXTRACT(SDPAT,CNT))
End DoDot:1
+9 QUIT
6 ;6 increments per hour (10 min)
+1 NEW BSTART,CNT,HOUR
+2 SET BSTART=""
+3 SET SDI=0
+4 SET HOUR=SDCLS-1
+5 FOR CNT=2:2
if CNT>$LENGTH(SDPAT)
QUIT
Begin DoDot:1
+6 IF (CNT#12)=2
SET HOUR=HOUR+1
+7 SET BSTART=SDAY_"."_$SELECT($LENGTH(HOUR)=1:"0"_HOUR,1:HOUR)_$SELECT((CNT#12)=4:10,(CNT#12)=6:20,(CNT#12)=8:30,(CNT#12)=10:40,(CNT#12)=0:50,1:"00")
+8 SET DTARRAY($PIECE(BSTART,".",1),$PIECE(BSTART,".",2))=$SELECT(+SDF:"X",1:$EXTRACT(SDPAT,CNT))
End DoDot:1
+9 QUIT
SDAV(SDAV,SDCL,SDAY,SDLEN,SDCLS,SDSI) ;build modified availability array from AVAILABILITY in 44
+1 NEW DTARRAY
+2 NEW SDCAN,SDI,SDPAT,SDTIME
+3 KILL SDAV
+4 MERGE SDAV=^SC(SDCL,"T",SDAY)
+5 ;get PATTERN from file 44
SET SDPAT=$GET(^SC(SDCL,"ST",SDAY,1))
+6 if SDPAT=""
QUIT
+7 ;convert pattern to array
DO ARRAY(.DTARRAY,SDPAT,SDAY,SDLEN,SDCLS,SDSI)
+8 SET SDTIME=0
FOR
SET SDTIME=$ORDER(SDAV(2,SDTIME))
if SDTIME'>0
QUIT
Begin DoDot:1
+9 SET SDNOD2=$GET(SDAV(2,SDTIME,0))
+10 IF $GET(DTARRAY(SDAY,$PIECE(SDNOD2,U,1)))="X"
Begin DoDot:2
+11 KILL SDAV(2,SDTIME,0)
End DoDot:2
End DoDot:1
+12 QUIT
