Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC57

SDEC57.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;APPSLOTS - return appt slots and availability
  1. ;SDECY=Return global array
  1. ; FM DATE ^ SLOT START TIME ^ SLOT STOP TIME ^ AVAILABILITY CODE
  1. ; Availability codes 0-9,j-z for 0 to 26 available appts, A-W for overbooks 1-23
  1. ;SDECRES=Resource name
  1. ;SDECSTRT=Start date/time
  1. ;SDECEND=End date/time
  1. APPSLOTS(SDECY,SDECRES,SDECSTART,SDECEND) ;GET Create Assigned Slot Schedule
  1. N CNT
  1. N SDECAD,SDECALO,SDECBS,SDECDEP,SDECERR,SDECI,SDECIEN,SDECK,SDECL,SDECNEND,SDECNOD
  1. N SDECNOT,SDECNSTART,SDECPEND,SDECQ,SDECRESD,SDECRESN,SDECS,SDECSUBCD,SDECTMP
  1. N SDAB,SDECTYPE,SDECTYPED,SDECZ
  1. N %DT,X,Y
  1. S SDECERR=""
  1. S SDECY="^TMP(""SDEC57"","_$J_",""APPSLOTS"")"
  1. K @SDECY
  1. S SDECALO=0,SDECI=0
  1. S @SDECY@(SDECI)="T00030DATE^T00030START_TIME^T00030END_TIME^I00010AVAILABILITY"_$C(30)
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
  1. ;
  1. ;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
  1. ;S SDECSTART=Y
  1. S SDECSTART=$$NETTOFM^SDECDATE($P(SDECSTART,"@",1),"N") ;
  1. ;
  1. ; Return error if date is invalid. wtc 6/18/18
  1. ;
  1. I SDECSTART=-1 S @SDECY@(1)="-1^Invalid start date"_$C(30)_$C(31) Q ;
  1. ;
  1. ;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
  1. ;S SDECEND=Y
  1. S SDECEND=$$NETTOFM^SDECDATE($P(SDECEND,"@",1),"N") ;
  1. ;
  1. ; Return error if date is invalid. wtc 6/18/18
  1. ;
  1. I SDECEND=-1 S @SDECY@(1)="-1^Invalid end date"_$C(30)_$C(31) Q ;
  1. ;
  1. ;validate SDECRES
  1. S SDECRES=$G(SDECRES)
  1. I SDECRES']"" S @SDECY@(1)="-1^Resource ID is required"_$C(30)_$C(31) Q
  1. I +SDECRES,'$D(^SDEC(409.831,+SDECRES,0)) S @SDECY@(1)="-1^Resource ID is required"_$C(30)_$C(31) Q
  1. 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
  1. S SDAB="^TMP("_$J_",""SDEC57"",""BLKS"")"
  1. K @SDAB
  1. D GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND)
  1. ;Get Access Type IDs
  1. N SD1,SD2,SD3,SD4,SDI,SDNOD,SDENDDT
  1. N SDSTRTDT,SDSLOTS,SDSTOPTM,SDSTRTTM
  1. S SDI=0 F S SDI=$O(@SDAB@(SDI)) Q:SDI'>0 D
  1. .S SDNOD=@SDAB@(SDI)
  1. .S SD1=$P(SDNOD,U,2) ;start DT
  1. .S SD2=$P(SDNOD,U,3) ;end DT
  1. .S SD3=+$P(SDNOD,U,4) ;slots
  1. .S SD4=$P(SDNOD,U,5) ;access type(1=avail,2=not avail,3=canc)
  1. .S SDSTRTDT=$P(SD1,".")
  1. .S SDENDDT=$P(SD2,".")
  1. .S SDSTRTTM=$E($P(SD1_"0000",".",2),1,4)
  1. .S SDSTOPTM=$E($P(SD2_"0000",".",2),1,4)
  1. .S SDSLOTS=$P(SDNOD,U,4)
  1. .S SDSLOTS=$S(SDSLOTS=" ":"",1:SDSLOTS)
  1. .S SDSLOTS=$S(SD4=2:"",SD4=3:"X",1:SDSLOTS)
  1. .S SDECI=SDECI+1,@SDECY@(SDECI)=SDSTRTDT_U_SDSTRTTM_U_SDSTOPTM_U_SDSLOTS_$C(30)
  1. S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1. K @SDAB
  1. Q
  1. ;
  1. GETSLOTS(SDAB,SDECRES,SDECSTART,SDECEND) ;load SDEC ACCESS BLOCKS from file 44
  1. N SDCL,SDI,SDJ
  1. S SDECRES=$G(SDECRES) Q:SDECRES=""
  1. I +SDECRES,'$D(^SDEC(409.831,+SDECRES,0)) Q
  1. I '+SDECRES S SDECRES=$O(^SDEC(409.831,"B",SDECRES,0))
  1. Q:'SDECRES
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
  1. ;
  1. ;S %DT="T",X=$P($P(SDECSTART,"@",1),".",1) D ^%DT
  1. ;Q:Y=-1
  1. ;S SDECSTART=Y
  1. S SDECSTART=$$NETTOFM^SDECDATE($P(SDECSTART,"@",1),"N") Q:SDECSTART=-1 ;
  1. ;S %DT="T",X=$P($P(SDECEND,"@",1),".",1) D ^%DT
  1. ;Q:Y=-1
  1. ;S SDECEND=Y
  1. S SDECEND=$$NETTOFM^SDECDATE($P(SDECEND,"@",1),"N") Q:SDECEND=-1 ;
  1. S SDCL=$$GET1^DIQ(409.831,SDECRES_",",.04,"I")
  1. Q:SDCL=""
  1. S SDI=$$FMADD^XLFDT(SDECSTART,-1)
  1. ;
  1. ; Handle where SDI is initially -1 because of bad future dates. wtc 6/18/18 SD*5.3*701
  1. ;
  1. I SDI<0 S @SDECY@(1)="-1^Bad future appointment date"_$C(30)_$C(31) Q ;
  1. N BADATE S BADATE=0 ;
  1. F S SDI=$$FMADD^XLFDT(SDI,1) Q:SDI>$P(SDECEND,".",1)!(BADATE>0) D ;
  1. . I SDI<0 S BADATE=1,SDECI=SDECI+1,@SDECY@(SDECI)="-1^Bad future appointment date"_$C(30)_$C(31) Q ;
  1. .I ($O(^SC(SDCL,"T",0))="")!($O(^SC(SDCL,"T",0))>SDI) Q
  1. .I $$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y",$D(^HOLIDAY("B",SDI)) Q ;do not schedule on holidays
  1. .;Q:$G(^SC(SDCL,"ST",SDI,1))["**CANCELLED**"
  1. .Q:$$INACTIVE^SDEC32(SDCL,$P(SDI,".",1)) ;don't get availability if clinic inactive on day SDI
  1. .D RESAB(SDAB,SDCL,SDI,SDI_"."_2359,SDECRES)
  1. Q
  1. ;
  1. RESAB(SDAB,SDCL,SDBEG,SDEND,SDECRES) ;build access blocks for 1 clinic
  1. ; SDECRES (optional) Resource pointer to SDEC RESOURCE file
  1. ; used to build access blocks from clinic availability
  1. ; for only this resource; all resources are build if null
  1. ; .01 name
  1. ; 2 type (clinic)
  1. ; 1912 length of app't
  1. ; 1914 hour clinic display begins default is 8am; whole number 0-16
  1. ; 1917 display increments per hour
  1. ; 2505 inactive date
  1. ; 2506 reactivate date
  1. N SDAY,SDCLS,SDDATA,SDFIELDS,SDIN,SDLEN,SDRA,SDSI,SDT
  1. I $P($G(SDBEG),".",1)'?7N S SDBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1)
  1. I $P($G(SDEND),".",1)'?7N S SDEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),365)
  1. S SDECRES=$G(SDECRES) I SDECRES'="",'$D(^SDEC(409.831,+SDECRES,0)) S SDECRES=""
  1. S SDFIELDS=".01;2;1912;1914;1917;2505;2506"
  1. D GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA","SDMSG")
  1. Q:SDDATA(44,SDCL_",",2,"I")'="C" ;only clinic
  1. I $$INACTIVE(SDCL,.SDBEG,.SDEND,SDDATA(44,SDCL_",",2505,"I"),SDDATA(44,SDCL_",",2506,"I")) Q ;only active
  1. S SDLEN=SDDATA(44,SDCL_",",1912,"I") ;length of app't is required in file 44
  1. S SDCLS=SDDATA(44,SDCL_",",1914,"I") ;hour clinic display begins
  1. S:SDCLS="" SDCLS=8 ;apply default start time of 0800
  1. ;SDSI=DISPLAY INCREMENTS PER HOUR (1-60min,2-30min,3-20min,4-15min,6-10min)
  1. S SDSI=SDDATA(44,SDCL_",",1917,"I")
  1. D TDAY(SDAB,SDCL,SDCLS,SDLEN,SDSI,SDBEG,SDEND)
  1. Q
  1. ;
  1. 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'
  1. ;SDEND = (optional) Stop date in fileman format; defaults to 365 days
  1. N SDAY,SDAY1,SDBLKS,SDE,SDE1,SDJ,SDPAT,SDPAT1,SDSIM
  1. S SDCL=$G(SDCL)
  1. Q:SDCL=""
  1. S SDLEN=$G(SDLEN)
  1. ;LENGTH OF APP'T
  1. I SDLEN="" S SDLEN=$$GET1^DIQ(44,SDCL_",",1912)
  1. S SDCLS=$G(SDCLS)
  1. ;HOUR CLINIC DISPLAY BEGINS
  1. I SDCLS="" S SDCLS=$$GET1^DIQ(44,SDCL_",",1914) ;SDCLS=8
  1. S SDSI=$G(SDSI)
  1. ;DISPLAY INCREMENTS PER HOUR
  1. I SDSI="" S SDSI=$$GET1^DIQ(44,SDCL_",",1917,"I") ;SDDATA(44,SDCL_",",1917,"I")
  1. S SDBEG=$G(SDBEG)
  1. D TDAY1
  1. Q
  1. TDAY1 ;
  1. N D,SDA,SDTP,SS,ST,Y,SUB,DAY
  1. ;SDA=begin position of pattern on template
  1. S SDA=$S(SDSI=3:6,SDSI=6:12,1:8)
  1. S SDTP=""
  1. ;if no CURRENT AVAILABILITY pattern, try to build it
  1. ;
  1. S DAY=$$DOW^XLFDT(SDBEG,1)
  1. S SUB="T"_DAY
  1. I '$D(^SC(SDCL,"ST",$P(SDBEG,".",1),1)),$L($G(^SC(SDCL,SUB,9999999,1))) S ST='$$ST(SDCL,SDBEG) Q:ST
  1. S SDTP=$G(^SC(SDCL,"ST",$P(SDBEG,".",1),1)) S SDTP=$E(SDTP,SDA,$L(SDTP))
  1. Q:SDTP=""
  1. K SDBLKS
  1. D GETBLKS^SDEC57A(.SDBLKS,SDTP,$P(SDBEG,".",1),SDCLS,SDLEN,SDSI,SDCL)
  1. D RESNB^SDECUTL1(SDAB,.SDBLKS,SDCL,$P(SDBEG,".",1))
  1. K SDBLKS
  1. Q
  1. ;
  1. ST(SDCL,SDBEG) ;build ST
  1. ;RETURN - 0=not buildable or built as holiday ;1=buildable
  1. N D,SC,SDDT,SS,Y
  1. S SDDT=$P(SDBEG,".",1)
  1. S SC=SDCL
  1. S D=$$DOW^XLFDT(SDDT,1)
  1. S Y=D#7
  1. I $D(^HOLIDAY(SDDT))&($$GET1^DIQ(44,SDCL_",",1918.5,"I")'="Y") D H(SDDT) Q 0
  1. S SS=$$FDT(SDCL,Y)
  1. Q:+SS="" 0
  1. 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
  1. Q 1
  1. FDT(SDCL,Y) ;find day template pattern
  1. N SDE,SDTP
  1. S SDTP=""
  1. S SDE=$O(^SC(SDCL,"T"_Y,99999999),-1)
  1. Q:'SDE ""
  1. S SDTP=$G(^SC(SDCL,"T"_Y,SDE,1))
  1. Q:SDTP="" ""
  1. 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))
  1. Q SDTP
  1. H(X) ;update ST as holiday
  1. S ^SC(+SC,"ST",X,1)=" "_$E(X,6,7)_" "_$P(^HOLIDAY(X,0),U,2),^SC(+SC,"ST",X,0)=X
  1. Q
  1. ;
  1. DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
  1. ;
  1. INACTIVE(SDCL,SDBEG,SDEND,IDATE,RDATE) ;
  1. ;INPUT:
  1. ; SDCL - clinic ID
  1. ; .SDBEG - begin date in FM format, no time
  1. ; .SDEND - end date in FM format, no time
  1. ; IDATE - clinic's inactivation date
  1. ; RDATE - clinic's reactivation date
  1. ;RETURN:
  1. ; 0=Clinic is active
  1. ; 1=Clinic is inactive
  1. ; active 0 0
  1. I IDATE="" Q 0
  1. ; active but inactivated in future
  1. I IDATE>SDBEG S SDEND=IDATE Q 0
  1. ; inactive 1 0
  1. I IDATE'>SDBEG,RDATE="" Q 1 ;alb/sat 665
  1. ; inactive 1 1 inactive but reactivated
  1. ; inactive now reactive now
  1. I IDATE'>SDBEG,RDATE'>SDBEG Q 0 ;alb/sat 665
  1. ; inactive now reactive future
  1. I IDATE'>SDBEG,RDATE>IDATE S SDBEG=RDATE Q 0 ;alb/sat 665
  1. Q 1
  1. ;
  1. OBM(RET,SDCL,SDT,MRTC,USR,SDW) ;GET overbook status and message
  1. N %DT,OBM,SDTMP,X,Y
  1. S RET=$NA(^TMP("SDEC57",$J,"OBM"))
  1. K @RET
  1. S @RET@(0)="T00030CONTINUE^T00200MESSAGE^T00200PROMPT^T00030DEFAULT"_$C(30)
  1. ;validate SDCL
  1. S SDCL=$G(SDCL)
  1. I SDCL="" S @RET@(1)="-1^Clinic ID is required."_$C(30,31) Q
  1. I '$D(^SC(SDCL,0)) S @RET@(1)="-1^Invalid Clinic ID."_$C(30,31) Q
  1. ;validate SDT
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
  1. ;
  1. S SDT=$G(SDT)
  1. ;S %DT="T",X=SDT D ^%DT I Y=-1 S @RET@(1)="-1^Invalid appointment date/time."_$C(30,31) Q
  1. ;S SDT=Y
  1. 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 ;
  1. ;validate MRTC
  1. S MRTC=$G(MRTC)
  1. I MRTC'="","01"'[MRTC S @RET@(1)="-1^Invalid MRTC flag."_$C(30,31) Q
  1. ;validate USR
  1. S USR=$G(USR)
  1. I USR="" S USR=DUZ
  1. I '$D(^VA(200,USR,0)) S @RET@(1)="-1^Invalid user ID."_$C(30,31) Q
  1. ;validate SDW
  1. S SDW=$G(SDW)
  1. S OBM=$$OBM1(SDCL,SDT,MRTC,USR,SDW)
  1. I OBM="" S @RET@(1)=1
  1. E D
  1. .S SDTMP=""
  1. .F I=1:1:$L(OBM,"|") S $P(SDTMP,U,I)=$P(OBM,"|",I)
  1. .S @RET@(1)=SDTMP
  1. S @RET@(1)=@RET@(1)_$C(30,31)
  1. Q
  1. OBM1(SDCL,SDT,MRTC,USR,SDW) ;return message and possible prompt for overbook ;alb/sat 658
  1. ; RETURN - <continue> | <message> | <prompt> | <default>
  1. ; <continue> - 0=do not continue
  1. ; 1=continue
  1. ; 2=continue based on prompt response
  1. N %,CAN,D,DATE,HSI,I,OBM,MOB,MOBR,S,SB,SI,SL,SM,SM7,SDA,SDDIF,ST,STARTDAY,STR,X
  1. ;
  1. S OBM=""
  1. S (CAN,SM,SM7)=0
  1. ;validate SDCL
  1. S SDCL=$G(SDCL)
  1. Q:SDCL="" ""
  1. Q:'$D(^SC(SDCL,0)) ""
  1. ;validate MRTC
  1. S MRTC=$G(MRTC)
  1. ;validate USR
  1. S USR=$G(USR)
  1. I USR="" S USR=DUZ
  1. Q:'$D(^VA(200,USR,0)) ""
  1. ;validate SDT
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
  1. ;
  1. S SDT=$G(SDT)
  1. ;S %DT="T",X=SDT D ^%DT I Y=-1 Q ""
  1. ;S SDT=Y
  1. ;
  1. ; Convert date unless already in FileMan format.
  1. ;
  1. I SDT'?7N,SDT'?7N1".".N S SDT=$$NETTOFM^SDECDATE(SDT,$S(SDT["@":"Y",1:"N")) I SDT=-1 Q "" ;
  1. ;
  1. ; If time is midnight, change to beginning of next day. wtc 6/7/18 694
  1. ;
  1. I $P(SDT,".",2)=24 S SDT=$$FMADD^XLFDT($P(SDT,".",1),1) ;
  1. ;
  1. S DATE=$$FMTE^XLFDT($P(SDT,".",1))
  1. ;validate SDW walk-in flag
  1. S SDW=$G(SDW)
  1. ;
  1. ;SM=6=OVERBOOK SM=7=NOT IN SCHEDULE PERIOD
  1. 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)
  1. S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2)
  1. S S=$G(^SC(SDCL,"ST",$P(SDT,".",1),1))
  1. S I=SDT#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
  1. ;check if not during schedule period (SM=7)
  1. 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
  1. ;check if OB (SM=6)
  1. S SDA=$S($P(SL,U,6)=3:6,$P(SL,U,6)=6:12,1:8)
  1. 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
  1. .Q:ST'=""
  1. .Q:+SL'>+^SC(SDCL,"SL")
  1. .S ST=" "
  1. .Q
  1. I CAN S OBM="0|CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!" G OBX
  1. I +SDW,+SM7 S OBM="1" G OBX
  1. S (MOBR,MOB)=$P($G(^SC(SDCL,"SL")),U,7) ;MOB=MAX OB ALLOWED MOBR=MAX OB REMAINING
  1. ; alb/jsm 658 updated to used the $P(SDT,".",1)-.01
  1. 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
  1. ;*zeb 686 12/13/18 removed assumption that MRTCs are overbooks
  1. ; MAX OB DEFINED
  1. 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
  1. I MOB'="",SM#9'=0,MOBR<1,$D(^XUSEC("SDMOB",DUZ)) S OBM="2||WILL EXCEED MAXIMUM ALLOWABLE OVERBOOKS, OK?|YES" G OBX
  1. I MOB'="",SM#9'=0,MOBR>0,'$D(^XUSEC("SDOB",DUZ)) S OBM="0|NO OPEN SLOTS THEN" G OBX
  1. I MOB'="",SM=7,$D(^XUSEC("SDOB",DUZ)) S OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO" G OBX
  1. I MOB'="",SM=6,$D(^XUSEC("SDOB",DUZ)) S OBM="2||OVERBOOK!...OK?|NO" G OBX
  1. ; MAX OB NOT DEFINED
  1. I MOB="",SM#9'=0,'$D(^XUSEC("SDOB",DUZ)) S OBM="0|NO OPEN SLOTS THEN" G OBX
  1. I MOB="",SM=7,$D(^XUSEC("SDOB",DUZ)) S OBM="2||THAT TIME IS NOT WITHIN SCHEDULED PERIOD!...OK?|NO" G OBX
  1. I MOB="",SM=6,$D(^XUSEC("SDOB",DUZ)) S OBM="2||OVERBOOK!...OK?|NO" G OBX
  1. OBX Q OBM
  1. CAN(S,ST,SDCL,SDT) ;
  1. Q S["CAN"!(ST="X"&($D(^SC(+SDCL,"ST",$P(SDT,"."),"CAN"))))