SDEC57 ;ALB/SAT/JSM,WTC/BLB - VISTA SCHEDULING RPCS ;Apr 14, 2023@15:22
;;5.3;Scheduling;**627,642,658,665,701,686,694,837,842**;Aug 13, 1993;Build 17
;
Q
;APPSLOTS - return appt slots and availability
;SDECY=Return global array
; FM DATE ^ SLOT START TIME ^ SLOT STOP TIME ^ AVAILABILITY CODE
; Availability codes 0-9,j-z for 0 to 26 available appts, A-W for overbooks 1-23
;SDECRES=Resource name
;SDECSTRT=Start date/time
;SDECEND=End date/time
APPSLOTS(SDECY,SDECRES,SDECSTART,SDECEND) ;GET Create Assigned Slot Schedule
N CNT
N SDECAD,SDECALO,SDECBS,SDECDEP,SDECERR,SDECI,SDECIEN,SDECK,SDECL,SDECNEND,SDECNOD
N SDECNOT,SDECNSTART,SDECPEND,SDECQ,SDECRESD,SDECRESN,SDECS,SDECSUBCD,SDECTMP
N SDAB,SDECTYPE,SDECTYPED,SDECZ
N %DT,X,Y
S SDECERR=""
S SDECY="^TMP(""SDEC57"","_$J_",""APPSLOTS"")"
K @SDECY
S SDECALO=0,SDECI=0
S @SDECY@(SDECI)="T00030DATE^T00030START_TIME^T00030END_TIME^I00010AVAILABILITY"_$C(30)
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
;S SDECSTART=Y
S SDECSTART=$$NETTOFM^SDECDATE($P(SDECSTART,"@",1),"N") ;
;
; Return error if date is invalid. wtc 6/18/18
;
I SDECSTART=-1 S @SDECY@(1)="-1^Invalid start date"_$C(30)_$C(31) Q ;
;
;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
;S SDECEND=Y
S SDECEND=$$NETTOFM^SDECDATE($P(SDECEND,"@",1),"N") ;
;
; Return error if date is invalid. wtc 6/18/18
;
I SDECEND=-1 S @SDECY@(1)="-1^Invalid end date"_$C(30)_$C(31) Q ;
;
;validate SDECRES
S SDECRES=$G(SDECRES)
I SDECRES']"" S @SDECY@(1)="-1^Resource ID is required"_$C(30)_$C(31) Q
I +SDECRES,'$D(^SDEC(409.831,+SDECRES,0)) S @SDECY@(1)="-1^Resource ID is required"_$C(30)_$C(31) Q
I '+SDECRES S SDECRES=$O(^SDEC(409.831,"B",SDECRES,0)) I '+SDECRES S @SDECY@(1)="-1^Invalid Resource ID"_$C(30)_$C(31) Q
S SDAB="^TMP("_$J_",""SDEC57"",""BLKS"")"
K @SDAB
D GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND)
;Get Access Type IDs
N SD1,SD2,SD3,SD4,SDI,SDNOD,SDENDDT
N SDSTRTDT,SDSLOTS,SDSTOPTM,SDSTRTTM
S SDI=0 F S SDI=$O(@SDAB@(SDI)) Q:SDI'>0 D
.S SDNOD=@SDAB@(SDI)
.S SD1=$P(SDNOD,U,2) ;start DT
.S SD2=$P(SDNOD,U,3) ;end DT
.S SD3=+$P(SDNOD,U,4) ;slots
.S SD4=$P(SDNOD,U,5) ;access type(1=avail,2=not avail,3=canc)
.S SDSTRTDT=$P(SD1,".")
.S SDENDDT=$P(SD2,".")
.S SDSTRTTM=$E($P(SD1_"0000",".",2),1,4)
.S SDSTOPTM=$E($P(SD2_"0000",".",2),1,4)
.S SDSLOTS=$P(SDNOD,U,4)
.S SDSLOTS=$S(SDSLOTS=" ":"",1:SDSLOTS)
.S SDSLOTS=$S(SD4=2:"",SD4=3:"X",1:SDSLOTS)
.S SDECI=SDECI+1,@SDECY@(SDECI)=SDSTRTDT_U_SDSTRTTM_U_SDSTOPTM_U_SDSLOTS_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
K @SDAB
Q
;
GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND) ;load SDEC ACCESS BLOCKS from file 44
N SDCL,SDI,SDJ
S SDECRES=$G(SDECRES) Q:SDECRES=""
I +SDECRES,'$D(^SDEC(409.831,+SDECRES,0)) Q
I '+SDECRES S SDECRES=$O(^SDEC(409.831,"B",SDECRES,0))
Q:'SDECRES
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
;Q:Y=-1
;S SDECSTART=Y
S SDECSTART=$$NETTOFM^SDECDATE($P(SDECSTART,"@",1),"N") Q:SDECSTART=-1 ;
;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
;Q:Y=-1
;S SDECEND=Y
S SDECEND=$$NETTOFM^SDECDATE($P(SDECEND,"@",1),"N") Q:SDECEND=-1 ;
S SDCL=$$GET1^DIQ(409.831,SDECRES_",",.04,"I")
Q:SDCL=""
S SDI=$$FMADD^XLFDT(SDECSTART,-1)
;
; Handle where SDI is initially -1 because of bad future dates. wtc 6/18/18 SD*5.3*701
;
I SDI<0 S @SDECY@(1)="-1^Bad future appointment date"_$C(30)_$C(31) Q ;
N BADATE S BADATE=0 ;
F S SDI=$$FMADD^XLFDT(SDI,1) Q:SDI>$P(SDECEND,".",1)!(BADATE>0) D ;
. I SDI<0 S BADATE=1,SDECI=SDECI+1,@SDECY@(SDECI)="-1^Bad future appointment date"_$C(30)_$C(31) Q ;
.I ($O(^SC(SDCL,"T",0))="")!($O(^SC(SDCL,"T",0))>SDI) Q
.I $$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y",$D(^HOLIDAY("B",SDI)) Q ;do not schedule on holidays
.;Q:$G(^SC(SDCL,"ST",SDI,1))["**CANCELLED**"
.Q:$$INACTIVE^SDEC32(SDCL,$P(SDI,".",1)) ;don't get availability if clinic inactive on day SDI
.D RESAB(SDAB,SDCL,SDI,SDI_"."_2359,SDECRES)
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 ;apply default start time of 0800
;SDSI=DISPLAY INCREMENTS PER HOUR (1-60min,2-30min,3-20min,4-15min,6-10min)
S SDSI=SDDATA(44,SDCL_",",1917,"I")
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 SDLEN=$G(SDLEN)
;LENGTH OF APP'T
I SDLEN="" S SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
S SDCLS=$G(SDCLS)
;HOUR CLINIC DISPLAY BEGINS
I SDCLS="" S SDCLS=$$GET1^DIQ(44,SDCL_",",1914) ;SDCLS=8
S SDSI=$G(SDSI)
;DISPLAY INCREMENTS PER HOUR
I SDSI="" S SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I") ;SDDATA(44,SDCL_",",1917,"I")
S SDBEG=$G(SDBEG)
D TDAY1
Q
TDAY1 ;
N D,SDA,SDTP,SS,ST,Y,SUB,DAY
;SDA=begin position of pattern on template
S SDA=$S(SDSI=3:6,SDSI=6:12,1:8)
S SDTP=""
;if no CURRENT AVAILABILITY pattern, try to build it
;
S DAY=$$DOW^XLFDT(SDBEG,1)
S SUB="T"_DAY
I '$D(^SC(SDCL,"ST",$P(SDBEG,".",1),1)),$L($G(^SC(SDCL,SUB,9999999,1))) S ST='$$ST(SDCL,SDBEG) Q:ST
S SDTP=$G(^SC(SDCL,"ST",$P(SDBEG,".",1),1)) S SDTP=$E(SDTP,SDA,$L(SDTP))
Q:SDTP=""
K SDBLKS
D GETBLKS^SDEC57A(.SDBLKS,SDTP,$P(SDBEG,".",1),SDCLS,SDLEN,SDSI,SDCL)
D RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,$P(SDBEG,".",1))
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(SDDT) 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))
Q SDTP
H(X) ;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
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
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
;
OBM(RET,SDCL,SDT,MRTC,USR,SDW) ;GET overbook status and message
N %DT,OBM,SDTMP,X,Y
S RET=$NA(^TMP("SDEC57",$J,"OBM"))
K @RET
S @RET@(0)="T00030CONTINUE^T00200MESSAGE^T00200PROMPT^T00030DEFAULT"_$C(30)
;validate SDCL
S SDCL=$G(SDCL)
I SDCL="" S @RET@(1)="-1^Clinic ID is required."_$C(30,31) Q
I '$D(^SC(SDCL,0)) S @RET@(1)="-1^Invalid Clinic ID."_$C(30,31) Q
;validate SDT
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
S SDT=$G(SDT)
;S %DT="T",X=SDT D ^%DT I Y=-1 S @RET@(1)="-1^Invalid appointment date/time."_$C(30,31) Q
;S SDT=Y
S SDT=$$NETTOFM^SDECDATE(SDT,$S(SDT["@":"Y",1:"N")) I SDT=-1 S @RET@(1)="-1^Invalid appointment date/time."_$C(30,31) Q ;
;validate MRTC
S MRTC=$G(MRTC)
I MRTC'="","01"'[MRTC S @RET@(1)="-1^Invalid MRTC flag."_$C(30,31) Q
;validate USR
S USR=$G(USR)
I USR="" S USR=DUZ
I '$D(^VA(200,USR,0)) S @RET@(1)="-1^Invalid user ID."_$C(30,31) Q
;validate SDW
S SDW=$G(SDW)
S OBM=$$OBM1(SDCL,SDT,MRTC,USR,SDW)
I OBM="" S @RET@(1)=1
E D
.S SDTMP=""
.F I=1:1:$L(OBM,"|") S $P(SDTMP,U,I)=$P(OBM,"|",I)
.S @RET@(1)=SDTMP
S @RET@(1)=@RET@(1)_$C(30,31)
Q
OBM1(SDCL,SDT,MRTC,USR,SDW) ;return message and possible prompt for overbook ;alb/sat 658
; RETURN - <continue> | <message> | <prompt> | <default>
; <continue> - 0=do not continue
; 1=continue
; 2=continue based on prompt response
N %,CAN,D,DATE,HSI,I,OBM,MOB,MOBR,S,SB,SI,SL,SM,SM7,SDA,SDDIF,ST,STARTDAY,STR,X
;
S OBM=""
S (CAN,SM,SM7)=0
;validate SDCL
S SDCL=$G(SDCL)
Q:SDCL="" ""
Q:'$D(^SC(SDCL,0)) ""
;validate MRTC
S MRTC=$G(MRTC)
;validate USR
S USR=$G(USR)
I USR="" S USR=DUZ
Q:'$D(^VA(200,USR,0)) ""
;validate SDT
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
S SDT=$G(SDT)
;S %DT="T",X=SDT D ^%DT I Y=-1 Q ""
;S SDT=Y
;
; Convert date unless already in FileMan format.
;
I SDT'?7N,SDT'?7N1".".N S SDT=$$NETTOFM^SDECDATE(SDT,$S(SDT["@":"Y",1:"N")) I SDT=-1 Q "" ;
;
; If time is midnight, change to beginning of next day. wtc 6/7/18 694
;
I $P(SDT,".",2)=24 S SDT=$$FMADD^XLFDT($P(SDT,".",1),1) ;
;
S DATE=$$FMTE^XLFDT($P(SDT,".",1))
;validate SDW walk-in flag
S SDW=$G(SDW)
;
;SM=6=OVERBOOK SM=7=NOT IN SCHEDULE PERIOD
S SL=$G(^SC(+SDCL,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4)
S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2)
S S=$G(^SC(SDCL,"ST",$P(SDT,".",1),1))
S I=SDT#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
;check if not during schedule period (SM=7)
S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
;check if OB (SM=6)
S SDA=$S($P(SL,U,6)=3:6,$P(SL,U,6)=6:12,1:8)
F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$E(STR,$F(STR,ST)-2),SM7=$S(I<SDA:1,Y="*":1,1:SM7) S CAN=$$CAN(S,ST,SDCL,SDT) Q:CAN Q:Y="" S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) D S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
.Q:ST'=""
.Q:+SL'>+^SC(SDCL,"SL")
.S ST=" "
.Q
I CAN S OBM="0|CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!" G OBX
I +SDW,+SM7 S OBM="1" G OBX
S (MOBR,MOB)=$P($G(^SC(SDCL,"SL")),U,7) ;MOB=MAX OB ALLOWED MOBR=MAX OB REMAINING
; alb/jsm 658 updated to used the $P(SDT,".",1)-.01
I MOBR F D=$P(SDT,".",1)-.01:0 S D=$O(^SC(SDCL,"S",D)) Q:$P(D,".",1)-$P(SDT,".",1) F %=0:0 S %=$O(^SC(SDCL,"S",D,1,%)) Q:'% I $P(^(%,0),"^",9)'["C",$D(^("OB")) S MOBR=MOBR-1
;*zeb 686 12/13/18 removed assumption that MRTCs are overbooks
; MAX OB DEFINED
I MOB'="",SM#9'=0,MOBR<1,'$D(^XUSEC("SDMOB",DUZ)) S OBM="0|ONLY "_MOB_" OVERBOOK"_$E("S",MOB>1)_" ALLOWED PER DAY!!" G OBX
I MOB'="",SM#9'=0,MOBR<1,$D(^XUSEC("SDMOB",DUZ)) S OBM="2||WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS, OK?|YES" G OBX
I MOB'="",SM#9'=0,MOBR>0,'$D(^XUSEC("SDOB",DUZ)) S OBM="0|NO OPEN SLOTS THEN" G OBX
I MOB'="",SM=7,$D(^XUSEC("SDOB",DUZ)) S OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO" G OBX
I MOB'="",SM=6,$D(^XUSEC("SDOB",DUZ)) S OBM="2||OVERBOOK!...OK?|NO" G OBX
; MAX OB NOT DEFINED
I MOB="",SM#9'=0,'$D(^XUSEC("SDOB",DUZ)) S OBM="0|NO OPEN SLOTS THEN" G OBX
I MOB="",SM=7,$D(^XUSEC("SDOB",DUZ)) S OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO" G OBX
I MOB="",SM=6,$D(^XUSEC("SDOB",DUZ)) S OBM="2||OVERBOOK!...OK?|NO" G OBX
OBX Q OBM
CAN(S,ST,SDCL,SDT) ;
Q S["CAN"!(ST="X"&($D(^SC(+SDCL,"ST",$P(SDT,"."),"CAN"))))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC57 13136 printed Oct 16, 2024@18:51:30 Page 2
SDEC57 ;ALB/SAT/JSM,WTC/BLB - VISTA SCHEDULING RPCS ;Apr 14, 2023@15:22
+1 ;;5.3;Scheduling;**627,642,658,665,701,686,694,837,842**;Aug 13, 1993;Build 17
+2 ;
+3 QUIT
+4 ;APPSLOTS - return appt slots and availability
+5 ;SDECY=Return global array
+6 ; FM DATE ^ SLOT START TIME ^ SLOT STOP TIME ^ AVAILABILITY CODE
+7 ; Availability codes 0-9,j-z for 0 to 26 available appts, A-W for overbooks 1-23
+8 ;SDECRES=Resource name
+9 ;SDECSTRT=Start date/time
+10 ;SDECEND=End date/time
APPSLOTS(SDECY,SDECRES,SDECSTART,SDECEND) ;GET Create Assigned Slot Schedule
+1 NEW CNT
+2 NEW SDECAD,SDECALO,SDECBS,SDECDEP,SDECERR,SDECI,SDECIEN,SDECK,SDECL,SDECNEND,SDECNOD
+3 NEW SDECNOT,SDECNSTART,SDECPEND,SDECQ,SDECRESD,SDECRESN,SDECS,SDECSUBCD,SDECTMP
+4 NEW SDAB,SDECTYPE,SDECTYPED,SDECZ
+5 NEW %DT,X,Y
+6 SET SDECERR=""
+7 SET SDECY="^TMP(""SDEC57"","_$JOB_",""APPSLOTS"")"
+8 KILL @SDECY
+9 SET SDECALO=0
SET SDECI=0
+10 SET @SDECY@(SDECI)="T00030DATE^T00030START_TIME^T00030END_TIME^I00010AVAILABILITY"_$CHAR(30)
+11 ;
+12 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+13 ;
+14 ;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
+15 ;S SDECSTART=Y
+16 ;
SET SDECSTART=$$NETTOFM^SDECDATE($PIECE(SDECSTART,"@",1),"N")
+17 ;
+18 ; Return error if date is invalid. wtc 6/18/18
+19 ;
+20 ;
IF SDECSTART=-1
SET @SDECY@(1)="-1^Invalid start date"_$CHAR(30)_$CHAR(31)
QUIT
+21 ;
+22 ;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
+23 ;S SDECEND=Y
+24 ;
SET SDECEND=$$NETTOFM^SDECDATE($PIECE(SDECEND,"@",1),"N")
+25 ;
+26 ; Return error if date is invalid. wtc 6/18/18
+27 ;
+28 ;
IF SDECEND=-1
SET @SDECY@(1)="-1^Invalid end date"_$CHAR(30)_$CHAR(31)
QUIT
+29 ;
+30 ;validate SDECRES
+31 SET SDECRES=$GET(SDECRES)
+32 IF SDECRES']""
SET @SDECY@(1)="-1^Resource ID is required"_$CHAR(30)_$CHAR(31)
QUIT
+33 IF +SDECRES
IF '$DATA(^SDEC(409.831,+SDECRES,0))
SET @SDECY@(1)="-1^Resource ID is required"_$CHAR(30)_$CHAR(31)
QUIT
+34 IF '+SDECRES
SET SDECRES=$ORDER(^SDEC(409.831,"B",SDECRES,0))
IF '+SDECRES
SET @SDECY@(1)="-1^Invalid Resource ID"_$CHAR(30)_$CHAR(31)
QUIT
+35 SET SDAB="^TMP("_$JOB_",""SDEC57"",""BLKS"")"
+36 KILL @SDAB
+37 DO GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND)
+38 ;Get Access Type IDs
+39 NEW SD1,SD2,SD3,SD4,SDI,SDNOD,SDENDDT
+40 NEW SDSTRTDT,SDSLOTS,SDSTOPTM,SDSTRTTM
+41 SET SDI=0
FOR
SET SDI=$ORDER(@SDAB@(SDI))
if SDI'>0
QUIT
Begin DoDot:1
+42 SET SDNOD=@SDAB@(SDI)
+43 ;start DT
SET SD1=$PIECE(SDNOD,U,2)
+44 ;end DT
SET SD2=$PIECE(SDNOD,U,3)
+45 ;slots
SET SD3=+$PIECE(SDNOD,U,4)
+46 ;access type(1=avail,2=not avail,3=canc)
SET SD4=$PIECE(SDNOD,U,5)
+47 SET SDSTRTDT=$PIECE(SD1,".")
+48 SET SDENDDT=$PIECE(SD2,".")
+49 SET SDSTRTTM=$EXTRACT($PIECE(SD1_"0000",".",2),1,4)
+50 SET SDSTOPTM=$EXTRACT($PIECE(SD2_"0000",".",2),1,4)
+51 SET SDSLOTS=$PIECE(SDNOD,U,4)
+52 SET SDSLOTS=$SELECT(SDSLOTS=" ":"",1:SDSLOTS)
+53 SET SDSLOTS=$SELECT(SD4=2:"",SD4=3:"X",1:SDSLOTS)
+54 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDSTRTDT_U_SDSTRTTM_U_SDSTOPTM_U_SDSLOTS_$CHAR(30)
End DoDot:1
+55 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+56 KILL @SDAB
+57 QUIT
+58 ;
GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND) ;load SDEC ACCESS BLOCKS from file 44
+1 NEW SDCL,SDI,SDJ
+2 SET SDECRES=$GET(SDECRES)
if SDECRES=""
QUIT
+3 IF +SDECRES
IF '$DATA(^SDEC(409.831,+SDECRES,0))
QUIT
+4 IF '+SDECRES
SET SDECRES=$ORDER(^SDEC(409.831,"B",SDECRES,0))
+5 if 'SDECRES
QUIT
+6 ;
+7 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+8 ;
+9 ;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
+10 ;Q:Y=-1
+11 ;S SDECSTART=Y
+12 ;
SET SDECSTART=$$NETTOFM^SDECDATE($PIECE(SDECSTART,"@",1),"N")
if SDECSTART=-1
QUIT
+13 ;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
+14 ;Q:Y=-1
+15 ;S SDECEND=Y
+16 ;
SET SDECEND=$$NETTOFM^SDECDATE($PIECE(SDECEND,"@",1),"N")
if SDECEND=-1
QUIT
+17 SET SDCL=$$GET1^DIQ(409.831,SDECRES_",",.04,"I")
+18 if SDCL=""
QUIT
+19 SET SDI=$$FMADD^XLFDT(SDECSTART,-1)
+20 ;
+21 ; Handle where SDI is initially -1 because of bad future dates. wtc 6/18/18 SD*5.3*701
+22 ;
+23 ;
IF SDI<0
SET @SDECY@(1)="-1^Bad future appointment date"_$CHAR(30)_$CHAR(31)
QUIT
+24 ;
NEW BADATE
SET BADATE=0
+25 ;
FOR
SET SDI=$$FMADD^XLFDT(SDI,1)
if SDI>$PIECE(SDECEND,".",1)!(BADATE>0)
QUIT
Begin DoDot:1
+26 ;
IF SDI<0
SET BADATE=1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)="-1^Bad future appointment date"_$CHAR(30)_$CHAR(31)
QUIT
+27 IF ($ORDER(^SC(SDCL,"T",0))="")!($ORDER(^SC(SDCL,"T",0))>SDI)
QUIT
+28 ;do not schedule on holidays
IF $$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y"
IF $DATA(^HOLIDAY("B",SDI))
QUIT
+29 ;Q:$G(^SC(SDCL,"ST",SDI,1))["**CANCELLED**"
+30 ;don't get availability if clinic inactive on day SDI
if $$INACTIVE^SDEC32(SDCL,$PIECE(SDI,".",1))
QUIT
+31 DO RESAB(SDAB,SDCL,SDI,SDI_"."_2359,SDECRES)
End DoDot:1
+32 QUIT
+33 ;
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 ;apply default start time of 0800
if SDCLS=""
SET SDCLS=8
+22 ;SDSI=DISPLAY INCREMENTS PER HOUR (1-60min,2-30min,3-20min,4-15min,6-10min)
+23 SET SDSI=SDDATA(44,SDCL_",",1917,"I")
+24 DO TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND)
+25 QUIT
+26 ;
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 SET SDLEN=$GET(SDLEN)
+7 ;LENGTH OF APP'T
+8 IF SDLEN=""
SET SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
+9 SET SDCLS=$GET(SDCLS)
+10 ;HOUR CLINIC DISPLAY BEGINS
+11 ;SDCLS=8
IF SDCLS=""
SET SDCLS=$$GET1^DIQ(44,SDCL_",",1914)
+12 SET SDSI=$GET(SDSI)
+13 ;DISPLAY INCREMENTS PER HOUR
+14 ;SDDATA(44,SDCL_",",1917,"I")
IF SDSI=""
SET SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I")
+15 SET SDBEG=$GET(SDBEG)
+16 DO TDAY1
+17 QUIT
TDAY1 ;
+1 NEW D,SDA,SDTP,SS,ST,Y,SUB,DAY
+2 ;SDA=begin position of pattern on template
+3 SET SDA=$SELECT(SDSI=3:6,SDSI=6:12,1:8)
+4 SET SDTP=""
+5 ;if no CURRENT AVAILABILITY pattern, try to build it
+6 ;
+7 SET DAY=$$DOW^XLFDT(SDBEG,1)
+8 SET SUB="T"_DAY
+9 IF '$DATA(^SC(SDCL,"ST",$PIECE(SDBEG,".",1),1))
IF $LENGTH($GET(^SC(SDCL,SUB,9999999,1)))
SET ST='$$ST(SDCL,SDBEG)
if ST
QUIT
+10 SET SDTP=$GET(^SC(SDCL,"ST",$PIECE(SDBEG,".",1),1))
SET SDTP=$EXTRACT(SDTP,SDA,$LENGTH(SDTP))
+11 if SDTP=""
QUIT
+12 KILL SDBLKS
+13 DO GETBLKS^SDEC57A(.SDBLKS,SDTP,$PIECE(SDBEG,".",1),SDCLS,SDLEN,SDSI,SDCL)
+14 DO RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,$PIECE(SDBEG,".",1))
+15 KILL SDBLKS
+16 QUIT
+17 ;
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(SDDT)
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 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(X) ;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 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
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 ;
OBM(RET,SDCL,SDT,MRTC,USR,SDW) ;GET overbook status and message
+1 NEW %DT,OBM,SDTMP,X,Y
+2 SET RET=$NAME(^TMP("SDEC57",$JOB,"OBM"))
+3 KILL @RET
+4 SET @RET@(0)="T00030CONTINUE^T00200MESSAGE^T00200PROMPT^T00030DEFAULT"_$CHAR(30)
+5 ;validate SDCL
+6 SET SDCL=$GET(SDCL)
+7 IF SDCL=""
SET @RET@(1)="-1^Clinic ID is required."_$CHAR(30,31)
QUIT
+8 IF '$DATA(^SC(SDCL,0))
SET @RET@(1)="-1^Invalid Clinic ID."_$CHAR(30,31)
QUIT
+9 ;validate SDT
+10 ;
+11 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+12 ;
+13 SET SDT=$GET(SDT)
+14 ;S %DT="T",X=SDT D ^%DT I Y=-1 S @RET@(1)="-1^Invalid appointment date/time."_$C(30,31) Q
+15 ;S SDT=Y
+16 ;
SET SDT=$$NETTOFM^SDECDATE(SDT,$SELECT(SDT["@":"Y",1:"N"))
IF SDT=-1
SET @RET@(1)="-1^Invalid appointment date/time."_$CHAR(30,31)
QUIT
+17 ;validate MRTC
+18 SET MRTC=$GET(MRTC)
+19 IF MRTC'=""
IF "01"'[MRTC
SET @RET@(1)="-1^Invalid MRTC flag."_$CHAR(30,31)
QUIT
+20 ;validate USR
+21 SET USR=$GET(USR)
+22 IF USR=""
SET USR=DUZ
+23 IF '$DATA(^VA(200,USR,0))
SET @RET@(1)="-1^Invalid user ID."_$CHAR(30,31)
QUIT
+24 ;validate SDW
+25 SET SDW=$GET(SDW)
+26 SET OBM=$$OBM1(SDCL,SDT,MRTC,USR,SDW)
+27 IF OBM=""
SET @RET@(1)=1
+28 IF '$TEST
Begin DoDot:1
+29 SET SDTMP=""
+30 FOR I=1:1:$LENGTH(OBM,"|")
SET $PIECE(SDTMP,U,I)=$PIECE(OBM,"|",I)
+31 SET @RET@(1)=SDTMP
End DoDot:1
+32 SET @RET@(1)=@RET@(1)_$CHAR(30,31)
+33 QUIT
OBM1(SDCL,SDT,MRTC,USR,SDW) ;return message and possible prompt for overbook ;alb/sat 658
+1 ; RETURN - <continue> | <message> | <prompt> | <default>
+2 ; <continue> - 0=do not continue
+3 ; 1=continue
+4 ; 2=continue based on prompt response
+5 NEW %,CAN,D,DATE,HSI,I,OBM,MOB,MOBR,S,SB,SI,SL,SM,SM7,SDA,SDDIF,ST,STARTDAY,STR,X
+6 ;
+7 SET OBM=""
+8 SET (CAN,SM,SM7)=0
+9 ;validate SDCL
+10 SET SDCL=$GET(SDCL)
+11 if SDCL=""
QUIT ""
+12 if '$DATA(^SC(SDCL,0))
QUIT ""
+13 ;validate MRTC
+14 SET MRTC=$GET(MRTC)
+15 ;validate USR
+16 SET USR=$GET(USR)
+17 IF USR=""
SET USR=DUZ
+18 if '$DATA(^VA(200,USR,0))
QUIT ""
+19 ;validate SDT
+20 ;
+21 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+22 ;
+23 SET SDT=$GET(SDT)
+24 ;S %DT="T",X=SDT D ^%DT I Y=-1 Q ""
+25 ;S SDT=Y
+26 ;
+27 ; Convert date unless already in FileMan format.
+28 ;
+29 ;
IF SDT'?7N
IF SDT'?7N1".".N
SET SDT=$$NETTOFM^SDECDATE(SDT,$SELECT(SDT["@":"Y",1:"N"))
IF SDT=-1
QUIT ""
+30 ;
+31 ; If time is midnight, change to beginning of next day. wtc 6/7/18 694
+32 ;
+33 ;
IF $PIECE(SDT,".",2)=24
SET SDT=$$FMADD^XLFDT($PIECE(SDT,".",1),1)
+34 ;
+35 SET DATE=$$FMTE^XLFDT($PIECE(SDT,".",1))
+36 ;validate SDW walk-in flag
+37 SET SDW=$GET(SDW)
+38 ;
+39 ;SM=6=OVERBOOK SM=7=NOT IN SCHEDULE PERIOD
+40 SET SL=$GET(^SC(+SDCL,"SL"))
SET X=$PIECE(SL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
+41 SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
+42 SET S=$GET(^SC(SDCL,"ST",$PIECE(SDT,".",1),1))
+43 SET I=SDT#1-SB*100
SET ST=I#1*SI\.6+($PIECE(I,".")*SI)
SET SS=SL*HSI/60*SDDIF+ST+ST
+44 ;check if not during schedule period (SM=7)
+45 SET %=$FIND(S,"[",SS-1)
if '%!($PIECE(SL,"^",6)<3)
SET %=999
IF $FIND(S,"]",SS)'<%!(SDDIF=2&$EXTRACT(S,ST+ST+1,SS-1)["[")
SET SM=7
+46 ;check if OB (SM=6)
+47 SET SDA=$SELECT($PIECE(SL,U,6)=3:6,$PIECE(SL,U,6)=6:12,1:8)
+48 FOR I=ST+ST:SDDIF:SS-SDDIF
SET ST=$EXTRACT(S,I+1)
if ST=""
SET ST=" "
SET Y=$EXTRACT(STR,$FIND(STR,ST)-2)
SET SM7=$SELECT(I<SDA:1,Y="*":1,1:SM7)
SET CAN=$$CAN(S,ST,SDCL,SDT)
if CAN
QUIT
if Y=""
QUIT
if Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
Begin DoDot:1
+49 if ST'=""
QUIT
+50 if +SL'>+^SC(SDCL,"SL")
QUIT
+51 SET ST=" "
+52 QUIT
End DoDot:1
if ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
+53 IF CAN
SET OBM="0|CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!"
GOTO OBX
+54 IF +SDW
IF +SM7
SET OBM="1"
GOTO OBX
+55 ;MOB=MAX OB ALLOWED MOBR=MAX OB REMAINING
SET (MOBR,MOB)=$PIECE($GET(^SC(SDCL,"SL")),U,7)
+56 ; alb/jsm 658 updated to used the $P(SDT,".",1)-.01
+57 IF MOBR
FOR D=$PIECE(SDT,".",1)-.01:0
SET D=$ORDER(^SC(SDCL,"S",D))
if $PIECE(D,".",1)-$PIECE(SDT,".",1)
QUIT
FOR %=0:0
SET %=$ORDER(^SC(SDCL,"S",D,1,%))
if '%
QUIT
IF $PIECE(^(%,0),"^",9)'["C"
IF $DATA(^("OB"))
SET MOBR=MOBR-1
+58 ;*zeb 686 12/13/18 removed assumption that MRTCs are overbooks
+59 ; MAX OB DEFINED
+60 IF MOB'=""
IF SM#9'=0
IF MOBR<1
IF '$DATA(^XUSEC("SDMOB",DUZ))
SET OBM="0|ONLY "_MOB_" OVERBOOK"_$EXTRACT("S",MOB>1)_" ALLOWED PER DAY!!"
GOTO OBX
+61 IF MOB'=""
IF SM#9'=0
IF MOBR<1
IF $DATA(^XUSEC("SDMOB",DUZ))
SET OBM="2||WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS, OK?|YES"
GOTO OBX
+62 IF MOB'=""
IF SM#9'=0
IF MOBR>0
IF '$DATA(^XUSEC("SDOB",DUZ))
SET OBM="0|NO OPEN SLOTS THEN"
GOTO OBX
+63 IF MOB'=""
IF SM=7
IF $DATA(^XUSEC("SDOB",DUZ))
SET OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO"
GOTO OBX
+64 IF MOB'=""
IF SM=6
IF $DATA(^XUSEC("SDOB",DUZ))
SET OBM="2||OVERBOOK!...OK?|NO"
GOTO OBX
+65 ; MAX OB NOT DEFINED
+66 IF MOB=""
IF SM#9'=0
IF '$DATA(^XUSEC("SDOB",DUZ))
SET OBM="0|NO OPEN SLOTS THEN"
GOTO OBX
+67 IF MOB=""
IF SM=7
IF $DATA(^XUSEC("SDOB",DUZ))
SET OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO"
GOTO OBX
+68 IF MOB=""
IF SM=6
IF $DATA(^XUSEC("SDOB",DUZ))
SET OBM="2||OVERBOOK!...OK?|NO"
GOTO OBX
OBX QUIT OBM
CAN(S,ST,SDCL,SDT) ;
+1 QUIT S["CAN"!(ST="X"&($DATA(^SC(+SDCL,"ST",$PIECE(SDT,"."),"CAN"))))
