SDESCLNSETAVAIL ;ALB/TAW,KML,MGD,LAB,BLB,TJB - SET CLINIC AVAILABILITY ;JUN 03, 2024
;;5.3;Scheduling;**800,803,805,809,818,820,833,842,843,868,880**;Aug 13, 1993;Build 5
;;Per VHA Directive 6402, this routine should not be modified
;
SETCLINAVAIL(RETURN,SDCLINIC,DATES,TIMES,SLOTS,SDEAS) ;INICSET2(.POP,SDIEN,.FDA,.SDCLINIC,.PROVIDER,.DIAGNOSIS,.SPECIALINSTRUCT,.PRIVLIAGEDUSER)
; Input:
; SDCLIN - [REQ] Name or IEN from file 44
; DATES - [opt] String of dates in ISO8601 or FM format separated by a ;
; TIMES - [opt] String of time frames in military format separated by a ;
; ex: 0700-1030;1030-1400
; SLOTS - [REQ] String of integers separated by a ;
; The number of TIMES and SLOTS must match
; SDEAS - [Optional] - Enterprise Appointment Scheduling (EAS) Tracking Number
;
;if times and slots are empty, logic will remove availability
;
N POP,SDAVAIL,I,SDDOWNUM,DOWNUM,EOF,SDTOTALSLOTS,SDDISPPERHR,SDCLINSTARTHR,SDSOH,SLT,IEN,SDCLINDATA,SDSLOTS,SDTIME,SDDATE,TMPINDX
N SDRETURN,APPTCNT,ERRARRAY
S (POP,SDTOTALSLOTS,APPTCNT)=0
D VALIDATE
I 'POP D CREATE(SDCLINIC,SDCLINSTARTHR,SLT,SDDOWNUM)
I 'POP S SDRETURN("ClinicAvailability","Create")="Pattern Filed"
D BUILDER
K ERRARRAY
Q
;
VALIDATE ;
S SDCLINIC=$G(SDCLINIC)
I SDCLINIC'="",'$D(^SC(SDCLINIC,0)) D ERRLOG(19) Q
I SDCLINIC="" D ERRLOG(18) Q
;
S IEN=SDCLINIC_","
D GETS^DIQ(44,IEN,"1912;1914;1917;1918.5","IE","SDCLINDATA","SDMSG")
S SLT=$G(SDCLINDATA(44,IEN,1912,"I"))
I SLT="" D ERRLOG(115)
I (SLT<10)!(SLT>240)!(SLT?.E1"."1N.N)!($S('(SLT#10):0,'(SLT#15):0,1:1)) D ERRLOG(116)
S SDDISPPERHR=$G(SDCLINDATA(44,IEN,1917,"I"))
S SDCLINSTARTHR=$G(SDCLINDATA(44,IEN,1914,"I"),"")
I SDCLINSTARTHR="" S SDCLINSTARTHR=8
;
N STARTTIME,ENDTIME,TMPTIMES
S TIMES=$G(TIMES)
S SLOTS=$G(SLOTS)
I ((TIMES="")&(SLOTS'=""))!((TIMES'="")&(SLOTS="")) D ERRLOG(52,"Times and slots mismatch")
I 'POP,$L(TIMES,";")'=$L(SLOTS,";") D ERRLOG(52,"Times and slots mismatch")
;
I $P(DATES,"9999999",1)="" D ERRLOG(52,"Date Missing. Must have a date indicated.") Q
I $P(DATES,"9999999",2)'="" D ERRLOG(52,"Indefinite date indicator must be last") Q
;
I TIMES'="" D
.F I=1:1:$L(TIMES,";") Q:POP D
..S SDTIME=$P(TIMES,";",I)
..I SDTIME'?4N1"-"4N D ERRLOG(52,"Invalid time format") Q
..I $P(SDTIME,"-",2)>2400 D ERRLOG(52,"Invalid time format") Q
..S STARTTIME=$P(SDTIME,"-",1)
..S ENDTIME=$P(SDTIME,"-",2)
..I +STARTTIME'<+ENDTIME D ERRLOG(52,"Invalid time format") Q
..;Do not allow overlapping time frames
..I $D(TIMES(STARTTIME)) D ERRLOG(52,"Existing entry with same start time") Q
..; STARTTIME can not fall within the previous segment
..S TMPINDX=$O(TIMES(STARTTIME),-1)
..I TMPINDX D Q:POP
...S TMPTIMES=TIMES(TMPINDX)
...I +$P(TMPTIMES,"-",2)>+STARTTIME D ERRLOG(52,"Start time overlaps existing segment") Q
..; ENDTIME can not fall within a prior segment
..S TMPINDX=$O(TIMES(ENDTIME),-1)
..I TMPINDX D
...S TMPTIMES=TIMES(TMPINDX)
...;Current start time is = or > than previous end time
...I STARTTIME'<+$P(TMPTIMES,"-",2) Q
...; ENDTIME falls within and existing segment
...I +$P(TMPTIMES,"-",1)<+ENDTIME D ERRLOG(52,"End time overlaps existing segment") Q
...; An existing segment falls within STARTTIME and ENDTIME
...I +$P(TMPTIMES,"-",2)<+ENDTIME D ERRLOG(52,"End time overlaps existing segment") Q
..; Is this time segment consistent with slot duration
..I '$$CHECKDURATION(STARTTIME,ENDTIME,SLT) D ERRLOG(52,"Time span not consistent with appointment length")
..;
..S SDSLOTS=+$P(SLOTS,";",I)
..I SDSLOTS<1!(SDSLOTS>26) D ERRLOG(125) Q
..S TIMES(STARTTIME)=SDTIME_"^"_SDSLOTS
..S SDTOTALSLOTS=SDTOTALSLOTS+SDSLOTS
.I 'POP,$D(TIMES)'>1 D ERRLOG(52,"No valid time segments passed in")
.;Can't start prior to clinic opening
.I 'POP,+$O(TIMES(""))<(SDCLINSTARTHR*100) D ERRLOG(52,"Appointments can not start prior to clinic opening")
;
S DATES=$G(DATES)
S SDDATE=$P(DATES,";",1)
I SDDATE="" D ERRLOG(45)
I SDDATE'="" D
.I SDDATE'?7N S SDDATE=$$ISOTFM^SDAMUTDT(SDDATE) ;vse-2396
.I SDDATE'?7N D ERRLOG(46) Q
.I SDDATE<DT D ERRLOG(71) Q
.S SDDOWNUM=$$DOW^XLFDT(SDDATE,1),DATES(SDDATE)=""
.;D GETAPPT
.;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
;
Q:POP
I 'POP,$D(DATES)'>1 D ERRLOG(52,"No valid dates passed in") Q
;
S EOF=0
F I=2:1:$L(DATES,";") D Q:EOF
.S SDDATE=$P(DATES,";",I)
.Q:'SDDATE
.I SDDATE=9999999 S DATES(SDDATE)="",EOF=1 Q ;Indefinitely
.I SDDATE'?7N S SDDATE=$$ISOTFM^SDAMUTDT(SDDATE) ;vse-2396
.I SDDATE'?7N D ERRLOG(46) Q
.I SDDATE<DT D ERRLOG(71)
.I $G(SDDOWNUM)'=$$DOW^XLFDT(SDDATE,1) D ERRLOG(52,"Schedule days do not match") S EOF=1
.S DATES(SDDATE)=""
.;D GETAPPT
.;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
.;I $D(SDRETURN("ClinicAvailability","Appt")) D ERRLOG(52,"Pending appointments must be cancelled")
;
S SDEAS=$G(SDEAS,"")
I $L(SDEAS) S SDEAS=$$EASVALIDATE^SDESUTIL(SDEAS)
I SDEAS=-1 D ERRLOG(142)
Q
GETAPPT ;Check if there are any open appts for this date
N JSON,SDESERR,A,X
S X=""
D APPTBYCLINIC^SDESAPPT(.JSON,SDCLINIC,SDDATE_"@0001",SDDATE_"@2359")
;D DECODE^XLFJSON("JSON","A","SDESERR") ;removed the decode
;Remove any canceled appt
F S X=$O(JSON("Appt",X)) Q:'X D
.I $P(JSON("Appt",X,"Status"),"CANCELLED",2)'="" Q
.S APPTCNT=APPTCNT+1
.M SDRETURN("ClinicAvailability","Appt",APPTCNT)=JSON("Appt",X)
.S ERRARRAY(SDDATE)=1
Q
CHECKDURATION(T1,T2,SLT) ;Ensure the appointment lengths align with the time segment
N H1,H2,M1,M2,SDL,SD1
S H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
S:M1=0 M1=60,H1=H1-1
S:M2=0 M2=60,H2=H2-1
S SD1=M2-M1+((H2-H1)*60),SDL=SD1\SLT
I SDL*SLT'=+SD1 Q 0
Q 1
;
CREATE(DA,STARTDAY,SLT,DOW) ;
;DA = Clinic IEN (SDCLINIC)
;SLT - Appointment length
N D0,X,CNT,STARTTIME,T1,T2,NSL,CTR,DR,HY,MAX,SC,SD,SDREB,SDSTRTDT,SDZQ,ST,STR,Y1,INDEFINITELY,STIME
N LT,H1,H2,M1,M2,SDTOP,SDREACT,X,SI,ZDX,DH,DO,D,Y,SDEL,HSI,SDJJ,HHY,SDIN,SDRE,SDRE1,I,OK,X1,X2,A,SDA1
S STARTTIME=STARTDAY*100
S (HSI,SI)=$G(SDDISPPERHR,4)
S:SI=1 SI=4,HSI=1
S:SI=2 SI=4,HSI=2
;
;S DIC(0)="MAQEZL",(DIC,DIE)="^SC("_DA_",""T"",",DIC("W")=$P($T(DOW),";",3)
S:'$D(^SC(DA,"T",0)) ^SC(DA,"T",0)="^44.002D"
;
S D0=""
F S (SD,D0)=$O(DATES(D0)) Q:D0="" D Q:POP
.Q:D0?7"9"
.S (CNT,INDEFINITELY)=0
.I $O(DATES(D0))?7"9" S INDEFINITELY=1
.S STARTTIME=""
.F S STARTTIME=$O(TIMES(STARTTIME)) Q:STARTTIME="" D Q:POP
..S X=TIMES(STARTTIME)
..S T2=$P($P(X,"^",1),"-",2)
..S NSL=$P(X,"^",2)
..S T1=STARTTIME
..D G3 ;Set up time slots in the T node
.;
.D:'POP G5 ;Set up pattern for the date
Q
;
G3 ;
;
;SDTOP ??
;SDREACT ??
;SDSOH - Schedule on holidays
;SDIN - Inactivation date
;SDRE - Reactivation date
;
S SDTOP=1 ;????
S SDZQ=1
;
S LT=T2,H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
S M2=M2-SLT
G3A I M2<0 S M2=M2+60,H2=H2-1 G G3A
S:M2?1N M2="0"_M2 S:H2?1N H2="0"_H2
G4 S CNT=CNT+1,^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_NSL
S M1=M1+SLT
G4A I M1>59 S M1=M1-60,H1=H1+1 G G4A
S:M1?1N M1="0"_M1 S:H1?1N H1="0"_H1
I (H1_M1)>(H2_M2) Q
G G4
Q
;
G5 ;
S SDEL=0
G:'CNT DEL1:'$D(SDREACT),DEL1:'$D(SDTOP)&$D(SDREACT)&'CNT,C^SDB
S ^SC(DA,"T",D0,0)=D0,^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
S X=^SC(DA,"T",0),^SC(DA,"T",0)="^44.002D^"_D0_"^"_($P(X,"^",4)+1)
S DH=SLT*SI\60
F ZDX=CNT:0 S ZDX=$O(^SC(DA,"T",D0,2,ZDX)) Q:ZDX="" K ^SC(DA,"T",D0,2,ZDX)
F X=0:0 S X=$O(^SC(DA,"T",D0,2,X)) Q:X="" D
.S Y=^SC(DA,"T",D0,2,X,0)
.F D=1:1:DH S Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$S($P(Y,U,2):$E("123456789jklmnopqrstuvwxyz",$P(Y,U,2)),1:0)
S (DH,DO,X)=""
I $D(Y)=1 S SDEL=1 G D
I $D(HSI) I HSI=1!(HSI=2) D CKSI1
F Y=1:1 S DH=$D(Y(Y)),X=X_$S('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$S(DH:Y(Y),1:" "),DO=DH I 'DH,$O(Y(Y))="" Q
; CHECK WITH DARRYL & ANGELA RELATED TO NEXT LINE
K Y
I SI+SI+$L(X)>80 K ^SC(DA,"T",D0) S CNT=0,LT=$G(STIME),SDEL=0 D ERRLOG(52,"Availability string exceeds 80 characters") Q
G D
CKSI1 F SDJJ=$O(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$O(Y(SDJJ))="" S SDJJ=$O(Y(SDJJ-1))-$S(HSI=1:4,1:2)
F HHY=0:0 S HHY=$O(Y(HHY)) Q:HHY="" I '$D(HY(HHY)) K Y(HHY)
Q
;
DEL1 S (DH,DO,X)="",SDEL=1
D I $D(SDIN),SDIN>D0 S SDRE1=$S(SDRE:SDRE,1:9999999)
S DH=X,OK=0,CTR=0
S SDSOH=$S('$D(^SC(DA,"SL")):0,$P(^SC(DA,"SL"),"^",8)']"":0,1:1)
F X=D0:0 S X=+$O(^SC(DA,"T",X)) Q:X'>0 D DOW^SDM0 I Y=DOW S Y=X,DO=Y G R
I X'>0,$D(SDIN),SDIN>D0 D
.S SDRE1=$S(SDRE=0:9999999,1:SDRE)
.S X=SDIN
.F I=0:1:6 D DOW^SDM0 S:Y=DOW OK=1 Q:OK S X1=X,X2=1 D C^%DTC Q:X>SDRE1
I OK S Y=X,DO=D0 G R
S DO=9999999
R K OK
; CHECK ON AVAILABILITY DATE W D&A THEN REVIEW G1^SDB
EN1 ;
S D=D0
I 'INDEFINITELY G 1
S Y=""
I '$D(^SC(DA,"T"_DOW,D0,1)) D
.S Y=+$O(^SC(DA,"T"_DOW,D0))
.I Y>D0 S X=^SC(DA,"T"_DOW,Y,1),POP=0 D CHK1 K:'POP ^SC(DA,"T"_DOW,Y) S ^SC(DA,"T"_DOW,D0,1)=X,^SC(DA,"T"_DOW,D0,0)=D0 D TX
I Y<0,'$D(^SC(DA,"T"_DOW,D0)) S ^SC(DA,"T"_DOW,D0,1)="",^SC(DA,"T"_DOW,D0,0)=D0 D TX
S ^SC(DA,"T"_DOW,DO,1)=DH,^SC(DA,"T"_DOW,DO,0)=DO D TX
S X=D0 D B1^SDB1 S MAX=$$DAYSINFUTURE(DA,SD),SC=DA,SDSTRTDT=SD
Q:'CNT
D OVR^SDAUT1 I $G(DO)'=9999999 S SDRETURN("ClinicAvailability","DateIndefiniteScheduleEnds")=$$FMTISO^SDAMUTDT($G(DO)) Q:'SDZQ
Q
;
DAYSINFUTURE(CLINICIEN,STARTDATE) ;
N FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
;
S FUTUREBOOKINGNUM=$S($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
S FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
S HOLIDAYFILEDATE="",HOLIDAYFILEDATE=$O(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
;
I FUTUREBOOKDATE<HOLIDAYFILEDATE Q FUTUREBOOKINGNUM
Q $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
;
1 I SDEL S POP=0 D APPCK I POP D DELERR G OVR
11 G:$D(^HOLIDAY(D,0))&('SDSOH) OVR
S POP=0
D:$D(SDIN) CHK2
G:POP OVR
S (POP,SDREB)=0
S %=1
D APPCK
I POP D APPERR G:(%-1) OVR S SDREB=1
S X=D,DO=X+1,^SC(DA,"ST",X,9)=D,SDREACT=1
S:'$D(^SC(DA,"ST",0)) ^SC(DA,"ST",0)="^44.005DA^^" D B1^SDB1 ;SD*567 change set of 9 node to selected date
OVR ;
I D#100<22 S D=D+7 S POP=0 D:$D(SDIN) CHK2 Q
S X1=D,X2=7 D C^%DTC S D=X S POP=0 D:$D(SDIN) CHK2 Q
;
APPCK ;Are there appointments for this time?
Q
;Temporary change appointment has already been checked above, quick fix, logic to be removed during rewrite
;F A=D:0 S A=+$O(^SC(DA,"S",A)) Q:A'>0!(A\1-D) F SDA1=0:0 S SDA1=+$O(^SC(DA,"S",A,1,SDA1)) Q:SDA1'>0 I $P(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C" S POP=1 Q
;Q
APPERR ;
N %
W *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY" S %=2 D YN^DICN
I '% W !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO" G APPERR
Q
DELERR ;
S Y=D
W !,"... " D DT^DIQ W " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED" Q
CHK1 Q:'$D(SDIN)
I Y=SDIN S POP=1
Q
;
CHK2 ;
I SDIN<D,SDRE,SDRE'>D K SDIN Q
I SDIN<D,SDRE=0 S POP=1 Q
I SDIN<D,SDRE>D S POP=2,D=SDRE,X=D F I=0:1:6 D DOW^SDM0 Q:Y=DOW S X1=D,X2=1 D C^%DTC S D=X
S Y=SDIN D DTS^SDUTL S Y1=Y,Y=SDRE1 D DTS^SDUTL W:POP=2&('CTR) !!," Clinic is inactive from ",Y1," to ",Y,! S:POP=2 CTR=1
Q
OB ;
S SDSLOT=$E(STR,$F(STR,ST)-2)
I SDSLOT?1P,SDSLOT'?1" " S ^SC(DA,"S",DR,1,Y,"OB")="O" K SDSLOT Q
K ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
Q
TX ;
S:'$D(^SC(DA,"T"_DOW,0)) ^SC(DA,"T"_DOW,0)="^44.0"_$S(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^" Q
;
ERRLOG(ERNUM,OPTIONALTXT) ;
S POP=1
D ERRLOG^SDESJSON(.SDRETURN,$G(ERNUM),$G(OPTIONALTXT))
Q
BUILDER ;Convert data to JSON
N JSONERR
S JSONERR=""
D ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESCLNSETAVAIL 11897 printed Nov 22, 2024@18:06:10 Page 2
SDESCLNSETAVAIL ;ALB/TAW,KML,MGD,LAB,BLB,TJB - SET CLINIC AVAILABILITY ;JUN 03, 2024
+1 ;;5.3;Scheduling;**800,803,805,809,818,820,833,842,843,868,880**;Aug 13, 1993;Build 5
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
SETCLINAVAIL(RETURN,SDCLINIC,DATES,TIMES,SLOTS,SDEAS) ;INICSET2(.POP,SDIEN,.FDA,.SDCLINIC,.PROVIDER,.DIAGNOSIS,.SPECIALINSTRUCT,.PRIVLIAGEDUSER)
+1 ; Input:
+2 ; SDCLIN - [REQ] Name or IEN from file 44
+3 ; DATES - [opt] String of dates in ISO8601 or FM format separated by a ;
+4 ; TIMES - [opt] String of time frames in military format separated by a ;
+5 ; ex: 0700-1030;1030-1400
+6 ; SLOTS - [REQ] String of integers separated by a ;
+7 ; The number of TIMES and SLOTS must match
+8 ; SDEAS - [Optional] - Enterprise Appointment Scheduling (EAS) Tracking Number
+9 ;
+10 ;if times and slots are empty, logic will remove availability
+11 ;
+12 NEW POP,SDAVAIL,I,SDDOWNUM,DOWNUM,EOF,SDTOTALSLOTS,SDDISPPERHR,SDCLINSTARTHR,SDSOH,SLT,IEN,SDCLINDATA,SDSLOTS,SDTIME,SDDATE,TMPINDX
+13 NEW SDRETURN,APPTCNT,ERRARRAY
+14 SET (POP,SDTOTALSLOTS,APPTCNT)=0
+15 DO VALIDATE
+16 IF 'POP
DO CREATE(SDCLINIC,SDCLINSTARTHR,SLT,SDDOWNUM)
+17 IF 'POP
SET SDRETURN("ClinicAvailability","Create")="Pattern Filed"
+18 DO BUILDER
+19 KILL ERRARRAY
+20 QUIT
+21 ;
VALIDATE ;
+1 SET SDCLINIC=$GET(SDCLINIC)
+2 IF SDCLINIC'=""
IF '$DATA(^SC(SDCLINIC,0))
DO ERRLOG(19)
QUIT
+3 IF SDCLINIC=""
DO ERRLOG(18)
QUIT
+4 ;
+5 SET IEN=SDCLINIC_","
+6 DO GETS^DIQ(44,IEN,"1912;1914;1917;1918.5","IE","SDCLINDATA","SDMSG")
+7 SET SLT=$GET(SDCLINDATA(44,IEN,1912,"I"))
+8 IF SLT=""
DO ERRLOG(115)
+9 IF (SLT<10)!(SLT>240)!(SLT?.E1"."1N.N)!($SELECT('(SLT#10):0,'(SLT#15):0,1:1))
DO ERRLOG(116)
+10 SET SDDISPPERHR=$GET(SDCLINDATA(44,IEN,1917,"I"))
+11 SET SDCLINSTARTHR=$GET(SDCLINDATA(44,IEN,1914,"I"),"")
+12 IF SDCLINSTARTHR=""
SET SDCLINSTARTHR=8
+13 ;
+14 NEW STARTTIME,ENDTIME,TMPTIMES
+15 SET TIMES=$GET(TIMES)
+16 SET SLOTS=$GET(SLOTS)
+17 IF ((TIMES="")&(SLOTS'=""))!((TIMES'="")&(SLOTS=""))
DO ERRLOG(52,"Times and slots mismatch")
+18 IF 'POP
IF $LENGTH(TIMES,";")'=$LENGTH(SLOTS,";")
DO ERRLOG(52,"Times and slots mismatch")
+19 ;
+20 IF $PIECE(DATES,"9999999",1)=""
DO ERRLOG(52,"Date Missing. Must have a date indicated.")
QUIT
+21 IF $PIECE(DATES,"9999999",2)'=""
DO ERRLOG(52,"Indefinite date indicator must be last")
QUIT
+22 ;
+23 IF TIMES'=""
Begin DoDot:1
+24 FOR I=1:1:$LENGTH(TIMES,";")
if POP
QUIT
Begin DoDot:2
+25 SET SDTIME=$PIECE(TIMES,";",I)
+26 IF SDTIME'?4N1"-"4N
DO ERRLOG(52,"Invalid time format")
QUIT
+27 IF $PIECE(SDTIME,"-",2)>2400
DO ERRLOG(52,"Invalid time format")
QUIT
+28 SET STARTTIME=$PIECE(SDTIME,"-",1)
+29 SET ENDTIME=$PIECE(SDTIME,"-",2)
+30 IF +STARTTIME'<+ENDTIME
DO ERRLOG(52,"Invalid time format")
QUIT
+31 ;Do not allow overlapping time frames
+32 IF $DATA(TIMES(STARTTIME))
DO ERRLOG(52,"Existing entry with same start time")
QUIT
+33 ; STARTTIME can not fall within the previous segment
+34 SET TMPINDX=$ORDER(TIMES(STARTTIME),-1)
+35 IF TMPINDX
Begin DoDot:3
+36 SET TMPTIMES=TIMES(TMPINDX)
+37 IF +$PIECE(TMPTIMES,"-",2)>+STARTTIME
DO ERRLOG(52,"Start time overlaps existing segment")
QUIT
End DoDot:3
if POP
QUIT
+38 ; ENDTIME can not fall within a prior segment
+39 SET TMPINDX=$ORDER(TIMES(ENDTIME),-1)
+40 IF TMPINDX
Begin DoDot:3
+41 SET TMPTIMES=TIMES(TMPINDX)
+42 ;Current start time is = or > than previous end time
+43 IF STARTTIME'<+$PIECE(TMPTIMES,"-",2)
QUIT
+44 ; ENDTIME falls within and existing segment
+45 IF +$PIECE(TMPTIMES,"-",1)<+ENDTIME
DO ERRLOG(52,"End time overlaps existing segment")
QUIT
+46 ; An existing segment falls within STARTTIME and ENDTIME
+47 IF +$PIECE(TMPTIMES,"-",2)<+ENDTIME
DO ERRLOG(52,"End time overlaps existing segment")
QUIT
End DoDot:3
+48 ; Is this time segment consistent with slot duration
+49 IF '$$CHECKDURATION(STARTTIME,ENDTIME,SLT)
DO ERRLOG(52,"Time span not consistent with appointment length")
+50 ;
+51 SET SDSLOTS=+$PIECE(SLOTS,";",I)
+52 IF SDSLOTS<1!(SDSLOTS>26)
DO ERRLOG(125)
QUIT
+53 SET TIMES(STARTTIME)=SDTIME_"^"_SDSLOTS
+54 SET SDTOTALSLOTS=SDTOTALSLOTS+SDSLOTS
End DoDot:2
+55 IF 'POP
IF $DATA(TIMES)'>1
DO ERRLOG(52,"No valid time segments passed in")
+56 ;Can't start prior to clinic opening
+57 IF 'POP
IF +$ORDER(TIMES(""))<(SDCLINSTARTHR*100)
DO ERRLOG(52,"Appointments can not start prior to clinic opening")
End DoDot:1
+58 ;
+59 SET DATES=$GET(DATES)
+60 SET SDDATE=$PIECE(DATES,";",1)
+61 IF SDDATE=""
DO ERRLOG(45)
+62 IF SDDATE'=""
Begin DoDot:1
+63 ;vse-2396
IF SDDATE'?7N
SET SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)
+64 IF SDDATE'?7N
DO ERRLOG(46)
QUIT
+65 IF SDDATE<DT
DO ERRLOG(71)
QUIT
+66 SET SDDOWNUM=$$DOW^XLFDT(SDDATE,1)
SET DATES(SDDATE)=""
+67 ;D GETAPPT
+68 ;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
End DoDot:1
+69 ;
+70 if POP
QUIT
+71 IF 'POP
IF $DATA(DATES)'>1
DO ERRLOG(52,"No valid dates passed in")
QUIT
+72 ;
+73 SET EOF=0
+74 FOR I=2:1:$LENGTH(DATES,";")
Begin DoDot:1
+75 SET SDDATE=$PIECE(DATES,";",I)
+76 if 'SDDATE
QUIT
+77 ;Indefinitely
IF SDDATE=9999999
SET DATES(SDDATE)=""
SET EOF=1
QUIT
+78 ;vse-2396
IF SDDATE'?7N
SET SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)
+79 IF SDDATE'?7N
DO ERRLOG(46)
QUIT
+80 IF SDDATE<DT
DO ERRLOG(71)
+81 IF $GET(SDDOWNUM)'=$$DOW^XLFDT(SDDATE,1)
DO ERRLOG(52,"Schedule days do not match")
SET EOF=1
+82 SET DATES(SDDATE)=""
+83 ;D GETAPPT
+84 ;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
+85 ;I $D(SDRETURN("ClinicAvailability","Appt")) D ERRLOG(52,"Pending appointments must be cancelled")
End DoDot:1
if EOF
QUIT
+86 ;
+87 SET SDEAS=$GET(SDEAS,"")
+88 IF $LENGTH(SDEAS)
SET SDEAS=$$EASVALIDATE^SDESUTIL(SDEAS)
+89 IF SDEAS=-1
DO ERRLOG(142)
+90 QUIT
GETAPPT ;Check if there are any open appts for this date
+1 NEW JSON,SDESERR,A,X
+2 SET X=""
+3 DO APPTBYCLINIC^SDESAPPT(.JSON,SDCLINIC,SDDATE_"@0001",SDDATE_"@2359")
+4 ;D DECODE^XLFJSON("JSON","A","SDESERR") ;removed the decode
+5 ;Remove any canceled appt
+6 FOR
SET X=$ORDER(JSON("Appt",X))
if 'X
QUIT
Begin DoDot:1
+7 IF $PIECE(JSON("Appt",X,"Status"),"CANCELLED",2)'=""
QUIT
+8 SET APPTCNT=APPTCNT+1
+9 MERGE SDRETURN("ClinicAvailability","Appt",APPTCNT)=JSON("Appt",X)
+10 SET ERRARRAY(SDDATE)=1
End DoDot:1
+11 QUIT
CHECKDURATION(T1,T2,SLT) ;Ensure the appointment lengths align with the time segment
+1 NEW H1,H2,M1,M2,SDL,SD1
+2 SET H1=$EXTRACT(T1,1,2)
SET H2=$EXTRACT(T2,1,2)
SET M1=$EXTRACT(T1,3,4)
SET M2=$EXTRACT(T2,3,4)
+3 if M1=0
SET M1=60
SET H1=H1-1
+4 if M2=0
SET M2=60
SET H2=H2-1
+5 SET SD1=M2-M1+((H2-H1)*60)
SET SDL=SD1\SLT
+6 IF SDL*SLT'=+SD1
QUIT 0
+7 QUIT 1
+8 ;
CREATE(DA,STARTDAY,SLT,DOW) ;
+1 ;DA = Clinic IEN (SDCLINIC)
+2 ;SLT - Appointment length
+3 NEW D0,X,CNT,STARTTIME,T1,T2,NSL,CTR,DR,HY,MAX,SC,SD,SDREB,SDSTRTDT,SDZQ,ST,STR,Y1,INDEFINITELY,STIME
+4 NEW LT,H1,H2,M1,M2,SDTOP,SDREACT,X,SI,ZDX,DH,DO,D,Y,SDEL,HSI,SDJJ,HHY,SDIN,SDRE,SDRE1,I,OK,X1,X2,A,SDA1
+5 SET STARTTIME=STARTDAY*100
+6 SET (HSI,SI)=$GET(SDDISPPERHR,4)
+7 if SI=1
SET SI=4
SET HSI=1
+8 if SI=2
SET SI=4
SET HSI=2
+9 ;
+10 ;S DIC(0)="MAQEZL",(DIC,DIE)="^SC("_DA_",""T"",",DIC("W")=$P($T(DOW),";",3)
+11 if '$DATA(^SC(DA,"T",0))
SET ^SC(DA,"T",0)="^44.002D"
+12 ;
+13 SET D0=""
+14 FOR
SET (SD,D0)=$ORDER(DATES(D0))
if D0=""
QUIT
Begin DoDot:1
+15 if D0?7"9"
QUIT
+16 SET (CNT,INDEFINITELY)=0
+17 IF $ORDER(DATES(D0))?7"9"
SET INDEFINITELY=1
+18 SET STARTTIME=""
+19 FOR
SET STARTTIME=$ORDER(TIMES(STARTTIME))
if STARTTIME=""
QUIT
Begin DoDot:2
+20 SET X=TIMES(STARTTIME)
+21 SET T2=$PIECE($PIECE(X,"^",1),"-",2)
+22 SET NSL=$PIECE(X,"^",2)
+23 SET T1=STARTTIME
+24 ;Set up time slots in the T node
DO G3
End DoDot:2
if POP
QUIT
+25 ;
+26 ;Set up pattern for the date
if 'POP
DO G5
End DoDot:1
if POP
QUIT
+27 QUIT
+28 ;
G3 ;
+1 ;
+2 ;SDTOP ??
+3 ;SDREACT ??
+4 ;SDSOH - Schedule on holidays
+5 ;SDIN - Inactivation date
+6 ;SDRE - Reactivation date
+7 ;
+8 ;????
SET SDTOP=1
+9 SET SDZQ=1
+10 ;
+11 SET LT=T2
SET H1=$EXTRACT(T1,1,2)
SET H2=$EXTRACT(T2,1,2)
SET M1=$EXTRACT(T1,3,4)
SET M2=$EXTRACT(T2,3,4)
+12 SET M2=M2-SLT
G3A IF M2<0
SET M2=M2+60
SET H2=H2-1
GOTO G3A
+1 if M2?1N
SET M2="0"_M2
if H2?1N
SET H2="0"_H2
G4 SET CNT=CNT+1
SET ^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_NSL
+1 SET M1=M1+SLT
G4A IF M1>59
SET M1=M1-60
SET H1=H1+1
GOTO G4A
+1 if M1?1N
SET M1="0"_M1
if H1?1N
SET H1="0"_H1
+2 IF (H1_M1)>(H2_M2)
QUIT
+3 GOTO G4
+4 QUIT
+5 ;
G5 ;
+1 SET SDEL=0
+2 if 'CNT
if '$DATA(SDREACT)
GOTO DEL1
if '$DATA(SDTOP)&$DATA(SDREACT)&'CNT
GOTO DEL1
GOTO C^SDB
+3 SET ^SC(DA,"T",D0,0)=D0
SET ^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
+4 SET X=^SC(DA,"T",0)
SET ^SC(DA,"T",0)="^44.002D^"_D0_"^"_($PIECE(X,"^",4)+1)
+5 SET DH=SLT*SI\60
+6 FOR ZDX=CNT:0
SET ZDX=$ORDER(^SC(DA,"T",D0,2,ZDX))
if ZDX=""
QUIT
KILL ^SC(DA,"T",D0,2,ZDX)
+7 FOR X=0:0
SET X=$ORDER(^SC(DA,"T",D0,2,X))
if X=""
QUIT
Begin DoDot:1
+8 SET Y=^SC(DA,"T",D0,2,X,0)
+9 FOR D=1:1:DH
SET Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$SELECT($PIECE(Y,U,2):$EXTRACT("123456789jklmnopqrstuvwxyz",$PIECE(Y,U,2)),1:0)
End DoDot:1
+10 SET (DH,DO,X)=""
+11 IF $DATA(Y)=1
SET SDEL=1
GOTO D
+12 IF $DATA(HSI)
IF HSI=1!(HSI=2)
DO CKSI1
+13 FOR Y=1:1
SET DH=$DATA(Y(Y))
SET X=X_$SELECT('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$SELECT(DH:Y(Y),1:" ")
SET DO=DH
IF 'DH
IF $ORDER(Y(Y))=""
QUIT
+14 ; CHECK WITH DARRYL & ANGELA RELATED TO NEXT LINE
+15 KILL Y
+16 IF SI+SI+$LENGTH(X)>80
KILL ^SC(DA,"T",D0)
SET CNT=0
SET LT=$GET(STIME)
SET SDEL=0
DO ERRLOG(52,"Availability string exceeds 80 characters")
QUIT
+17 GOTO D
CKSI1 FOR SDJJ=$ORDER(Y(-1)):$SELECT(HSI=1:4,1:2)
if SDJJ>41
QUIT
if $DATA(Y(SDJJ))
SET HY(SDJJ)=""
IF '$DATA(Y(SDJJ))
if $ORDER(Y(SDJJ))=""
QUIT
SET SDJJ=$ORDER(Y(SDJJ-1))-$SELECT(HSI=1:4,1:2)
+1 FOR HHY=0:0
SET HHY=$ORDER(Y(HHY))
if HHY=""
QUIT
IF '$DATA(HY(HHY))
KILL Y(HHY)
+2 QUIT
+3 ;
DEL1 SET (DH,DO,X)=""
SET SDEL=1
D IF $DATA(SDIN)
IF SDIN>D0
SET SDRE1=$SELECT(SDRE:SDRE,1:9999999)
+1 SET DH=X
SET OK=0
SET CTR=0
+2 SET SDSOH=$SELECT('$DATA(^SC(DA,"SL")):0,$PIECE(^SC(DA,"SL"),"^",8)']"":0,1:1)
+3 FOR X=D0:0
SET X=+$ORDER(^SC(DA,"T",X))
if X'>0
QUIT
DO DOW^SDM0
IF Y=DOW
SET Y=X
SET DO=Y
GOTO R
+4 IF X'>0
IF $DATA(SDIN)
IF SDIN>D0
Begin DoDot:1
+5 SET SDRE1=$SELECT(SDRE=0:9999999,1:SDRE)
+6 SET X=SDIN
+7 FOR I=0:1:6
DO DOW^SDM0
if Y=DOW
SET OK=1
if OK
QUIT
SET X1=X
SET X2=1
DO C^%DTC
if X>SDRE1
QUIT
End DoDot:1
+8 IF OK
SET Y=X
SET DO=D0
GOTO R
+9 SET DO=9999999
R KILL OK
+1 ; CHECK ON AVAILABILITY DATE W D&A THEN REVIEW G1^SDB
EN1 ;
+1 SET D=D0
+2 IF 'INDEFINITELY
GOTO 1
+3 SET Y=""
+4 IF '$DATA(^SC(DA,"T"_DOW,D0,1))
Begin DoDot:1
+5 SET Y=+$ORDER(^SC(DA,"T"_DOW,D0))
+6 IF Y>D0
SET X=^SC(DA,"T"_DOW,Y,1)
SET POP=0
DO CHK1
if 'POP
KILL ^SC(DA,"T"_DOW,Y)
SET ^SC(DA,"T"_DOW,D0,1)=X
SET ^SC(DA,"T"_DOW,D0,0)=D0
DO TX
End DoDot:1
+7 IF Y<0
IF '$DATA(^SC(DA,"T"_DOW,D0))
SET ^SC(DA,"T"_DOW,D0,1)=""
SET ^SC(DA,"T"_DOW,D0,0)=D0
DO TX
+8 SET ^SC(DA,"T"_DOW,DO,1)=DH
SET ^SC(DA,"T"_DOW,DO,0)=DO
DO TX
+9 SET X=D0
DO B1^SDB1
SET MAX=$$DAYSINFUTURE(DA,SD)
SET SC=DA
SET SDSTRTDT=SD
+10 if 'CNT
QUIT
+11 DO OVR^SDAUT1
IF $GET(DO)'=9999999
SET SDRETURN("ClinicAvailability","DateIndefiniteScheduleEnds")=$$FMTISO^SDAMUTDT($GET(DO))
if 'SDZQ
QUIT
+12 QUIT
+13 ;
DAYSINFUTURE(CLINICIEN,STARTDATE) ;
+1 NEW FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
+2 ;
+3 SET FUTUREBOOKINGNUM=$SELECT($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
+4 SET FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
+5 SET HOLIDAYFILEDATE=""
SET HOLIDAYFILEDATE=$ORDER(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
+6 ;
+7 IF FUTUREBOOKDATE<HOLIDAYFILEDATE
QUIT FUTUREBOOKINGNUM
+8 QUIT $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
+9 ;
1 IF SDEL
SET POP=0
DO APPCK
IF POP
DO DELERR
GOTO OVR
11 if $DATA(^HOLIDAY(D,0))&('SDSOH)
GOTO OVR
+1 SET POP=0
+2 if $DATA(SDIN)
DO CHK2
+3 if POP
GOTO OVR
+4 SET (POP,SDREB)=0
+5 SET %=1
+6 DO APPCK
+7 IF POP
DO APPERR
if (%-1)
GOTO OVR
SET SDREB=1
+8 SET X=D
SET DO=X+1
SET ^SC(DA,"ST",X,9)=D
SET SDREACT=1
+9 ;SD*567 change set of 9 node to selected date
if '$DATA(^SC(DA,"ST",0))
SET ^SC(DA,"ST",0)="^44.005DA^^"
DO B1^SDB1
OVR ;
+1 IF D#100<22
SET D=D+7
SET POP=0
if $DATA(SDIN)
DO CHK2
QUIT
+2 SET X1=D
SET X2=7
DO C^%DTC
SET D=X
SET POP=0
if $DATA(SDIN)
DO CHK2
QUIT
+3 ;
APPCK ;Are there appointments for this time?
+1 QUIT
+2 ;Temporary change appointment has already been checked above, quick fix, logic to be removed during rewrite
+3 ;F A=D:0 S A=+$O(^SC(DA,"S",A)) Q:A'>0!(A\1-D) F SDA1=0:0 S SDA1=+$O(^SC(DA,"S",A,1,SDA1)) Q:SDA1'>0 I $P(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C" S POP=1 Q
+4 ;Q
APPERR ;
+1 NEW %
+2 WRITE *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY"
SET %=2
DO YN^DICN
+3 IF '%
WRITE !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO"
GOTO APPERR
+4 QUIT
DELERR ;
+1 SET Y=D
+2 WRITE !,"... "
DO DT^DIQ
WRITE " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED"
QUIT
CHK1 if '$DATA(SDIN)
QUIT
+1 IF Y=SDIN
SET POP=1
+2 QUIT
+3 ;
CHK2 ;
+1 IF SDIN<D
IF SDRE
IF SDRE'>D
KILL SDIN
QUIT
+2 IF SDIN<D
IF SDRE=0
SET POP=1
QUIT
+3 IF SDIN<D
IF SDRE>D
SET POP=2
SET D=SDRE
SET X=D
FOR I=0:1:6
DO DOW^SDM0
if Y=DOW
QUIT
SET X1=D
SET X2=1
DO C^%DTC
SET D=X
+4 SET Y=SDIN
DO DTS^SDUTL
SET Y1=Y
SET Y=SDRE1
DO DTS^SDUTL
if POP=2&('CTR)
WRITE !!," Clinic is inactive from ",Y1," to ",Y,!
if POP=2
SET CTR=1
+5 QUIT
OB ;
+1 SET SDSLOT=$EXTRACT(STR,$FIND(STR,ST)-2)
+2 IF SDSLOT?1P
IF SDSLOT'?1" "
SET ^SC(DA,"S",DR,1,Y,"OB")="O"
KILL SDSLOT
QUIT
+3 KILL ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
+4 QUIT
TX ;
+1 if '$DATA(^SC(DA,"T"_DOW,0))
SET ^SC(DA,"T"_DOW,0)="^44.0"_$SELECT(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^"
QUIT
+2 ;
ERRLOG(ERNUM,OPTIONALTXT) ;
+1 SET POP=1
+2 DO ERRLOG^SDESJSON(.SDRETURN,$GET(ERNUM),$GET(OPTIONALTXT))
+3 QUIT
BUILDER ;Convert data to JSON
+1 NEW JSONERR
+2 SET JSONERR=""
+3 DO ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
+4 QUIT
+5 ;
