- 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 Jan 18, 2025@03:52:04 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"))))