SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB,BLB,JDJ - SDES2 UTILITIES Continued ;OCT 23, 2025
;;5.3;Scheduling;**870,861,873,890,919,922**;Aug 13, 1993;Build 7
;;Per VHA Directive 6402, this routine should not be modified
;
Q
VALBOOLEAN(SDERRORS,SDBOOLEAN,SDREQUIRED,SDERRORTEXT) ;
; SDERRORS = Array to hold any logged errors
; SDBOOLEAN = Boolean input array element to validate
; SDREQUIRED = 1:Required, 0:Optional, Defaults to 0
; SDERRORTEXT = Additional text to append to error message. This is normally the name of the input parameter element.
;
I SDREQUIRED=0,SDBOOLEAN="" Q
S SDREQUIRED=$S($G(SDREQUIRED)="":0,1:$G(SDREQUIRED))
I SDREQUIRED=1,SDBOOLEAN="" D ERRLOG^SDESJSON(.SDERRORS,519,SDERRORTEXT)
I SDBOOLEAN'="1",SDBOOLEAN'="0" D ERRLOG^SDESJSON(.SDERRORS,518,SDERRORTEXT)
Q
;
GETRES(SDCL,INACT) ; Extrinsic function to return resource for clinic - SDEC RESOURCE (409.831)
; SDCL = Clinic IEN from File 44
; INACT = If not null, skip check to see if resource is inactive
; Return value is the associated resource or the empty string
;
; SDHLN - Name of the Clinic from File 44
; SDI - Resource IEN from file 409.831
; SDRESTYP - RESOURCE TYPE, Field .012 from File 409.831
N SDHLN,SDI,SDRESTYP,SDRES,SDRES1
S (SDRES,SDRES1)=""
S SDHLN=$$GET1^DIQ(44,SDCL_",",.01,"E")
Q:SDHLN="" ""
S SDI="" F S SDI=$O(^SDEC(409.831,"ALOC",SDCL,SDI)) Q:SDI="" D Q:SDRES'=""
.S SDRESTYP=$$GET1^DIQ(409.831,SDI_",",.012,"I")
.I '$G(INACT) Q:$$GET1^DIQ(409.831,SDI_",",.02)="YES"
.S:SDRES1="" SDRES1=SDI
.Q:$P(SDRESTYP,";",2)'="SC("
.S SDRES=SDI
I SDRES="",SDRES1'="" S SDRES=SDRES1
Q SDRES
;
GETGAF(DFN) ;
N GAF,GAFR
S GAF=$$NEWGAF^SDUTL2(DFN)
S GAFR=""
S:GAF="" GAF=-1
S $P(GAFR,"|",1)=$S(+GAF:"New GAF Required",1:"No new GAF required")
Q GAFR
;
ETHNLIST(ETHNICITY,DFN) ;get ethnicity list
;INPUT:
; DFN = Patient ID pointer to PATIENT file
;RETURN:
; PETH - Patient Ethnicity list separated by pipe |
; Pointer to ETHNICITY file 10.2
; PETHN - Patient Ethnicity names separated by pipe |
N SDI,SDID,PETH,PETHN
S (PETH,PETHN)=""
S SDI=0 F S SDI=$O(^DPT(DFN,.06,SDI)) Q:SDI'>0 D
.S SDID=$P($G(^DPT(DFN,.06,SDI,0)),U,1)
.S PETH=$S(PETH'="":PETH_"|",1:"")_SDID
.S PETHN=$S(PETHN'="":PETHN_"|",1:"")_$P($G(^DIC(10.2,SDID,0)),U,1)
S ETHNICITY("NAMES")=PETHN
S ETHNICITY("IENS")=PETH
Q
RACELIST(RACELST,DFN) ;get list of race information for given patient
;INPUT:
; DFN = Patient ID pointer to PATIENT file
;RETURN:
; RACEIEN - Patient race list separated by pipe |
; Pointer to RACE file 10
; RACENAM - Patient race names separated by pipe |
N SDI,SDID,RACEIEN,RACENAM
S (RACEIEN,RACENAM)=""
S SDI=0 F S SDI=$O(^DPT(DFN,.02,SDI)) Q:SDI'>0 D
.S SDID=$P($G(^DPT(DFN,.02,SDI,0)),U,1)
.S RACEIEN=$S(RACEIEN'="":RACEIEN_"|",1:"")_SDID
.S RACENAM=$S(RACENAM'="":RACENAM_"|",1:"")_$P($G(^DIC(10,SDID,0)),U,1)
S RACELST("NAMES")=RACENAM
S RACELST("IENS")=RACEIEN
Q
;
HRN(DFN) ;Health Record Number
N X
S X=$G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0))
Q $S($P(X,U,3):"",1:$P(X,U,2))
;
FLAGS(DFN,FNUM) ;get PRF flags
;INPUT:
; DFN - Patient ID
; FNUM - PRF Flag file ID 26.15=PRF NATIONAL FLAG 26.11=PRF LOCAL FLAG
;RETURN:
; Each | piece contains the following ;; pieces:
; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
; 4. PRFLNAME - PRF Local Flag name
; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
;
N PRFAID,PRFID,PRFLST,RET,STAT
S RET=""
S DFN=$G(DFN)
Q:DFN="" ""
Q:'$D(^DPT(DFN,0)) ""
S FNUM=$G(FNUM)
Q:(FNUM'=26.15)&(FNUM'=26.11) ""
D FLST(.PRFLIST,FNUM)
S PRFID="" F S PRFID=$O(PRFLIST(PRFID)) Q:PRFID="" D
.S PRFAID="" F S PRFAID=$O(^DGPF(26.13,"AFLAG",PRFID,DFN,PRFAID)) Q:PRFAID="" D
..S STAT="" S STAT=$$GET1^DIQ(26.13,PRFAID_",",.03,"I") Q:STAT'=1
..S RET=RET_$S(RET'="":"|",1:"")_PRFAID_";;"_STAT_";;"_+PRFID_";;"_$P(PRFLIST(PRFID),U,1)_";;"_$P(PRFLIST(PRFID),U,2)
Q RET
FLST(PRFLIST,FNUM) ;build flag list
N PRFID,PRFN
K PRFLIST
S PRFN="" F S PRFN=$O(^DGPF(FNUM,"B",PRFN)) Q:PRFN="" D
.S PRFID="" F S PRFID=$O(^DGPF(FNUM,"B",PRFN,PRFID)) Q:PRFID="" D
..S PRFLIST(PRFID_";DGPF("_FNUM_",")=$$GET1^DIQ(FNUM,PRFID_",",.01)_U_$$GET1^DIQ(FNUM,PRFID_",",.02,"I")
Q
;
CREATEAVAIL(RETURN,SDCLINIC,DATES,TIMES,SLOTS,INDEFINITEUNTIL,SDEAS) ;INICSET2(.POP,SDIEN,.FDA,.SDCLINIC,.PROVIDER,.DIAGNOSIS,.SPECIALINSTRUCT,.PRIVLIAGEDUSER)
;
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=0,$$GET1^DIQ(40.7,$$GET1^DIQ(44,SDCLINIC,8,"I"),1,"I")'="130" D ;EMERGENCY DEPT EXCEPTION
...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)) S INDEFINITEUNTIL=$$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[HSDES2UTIL1 15844 printed Jan 29, 2026@15:54:03 Page 2
SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB,BLB,JDJ - SDES2 UTILITIES Continued ;OCT 23, 2025
+1 ;;5.3;Scheduling;**870,861,873,890,919,922**;Aug 13, 1993;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
VALBOOLEAN(SDERRORS,SDBOOLEAN,SDREQUIRED,SDERRORTEXT) ;
+1 ; SDERRORS = Array to hold any logged errors
+2 ; SDBOOLEAN = Boolean input array element to validate
+3 ; SDREQUIRED = 1:Required, 0:Optional, Defaults to 0
+4 ; SDERRORTEXT = Additional text to append to error message. This is normally the name of the input parameter element.
+5 ;
+6 IF SDREQUIRED=0
IF SDBOOLEAN=""
QUIT
+7 SET SDREQUIRED=$SELECT($GET(SDREQUIRED)="":0,1:$GET(SDREQUIRED))
+8 IF SDREQUIRED=1
IF SDBOOLEAN=""
DO ERRLOG^SDESJSON(.SDERRORS,519,SDERRORTEXT)
+9 IF SDBOOLEAN'="1"
IF SDBOOLEAN'="0"
DO ERRLOG^SDESJSON(.SDERRORS,518,SDERRORTEXT)
+10 QUIT
+11 ;
GETRES(SDCL,INACT) ; Extrinsic function to return resource for clinic - SDEC RESOURCE (409.831)
+1 ; SDCL = Clinic IEN from File 44
+2 ; INACT = If not null, skip check to see if resource is inactive
+3 ; Return value is the associated resource or the empty string
+4 ;
+5 ; SDHLN - Name of the Clinic from File 44
+6 ; SDI - Resource IEN from file 409.831
+7 ; SDRESTYP - RESOURCE TYPE, Field .012 from File 409.831
+8 NEW SDHLN,SDI,SDRESTYP,SDRES,SDRES1
+9 SET (SDRES,SDRES1)=""
+10 SET SDHLN=$$GET1^DIQ(44,SDCL_",",.01,"E")
+11 if SDHLN=""
QUIT ""
+12 SET SDI=""
FOR
SET SDI=$ORDER(^SDEC(409.831,"ALOC",SDCL,SDI))
if SDI=""
QUIT
Begin DoDot:1
+13 SET SDRESTYP=$$GET1^DIQ(409.831,SDI_",",.012,"I")
+14 IF '$GET(INACT)
if $$GET1^DIQ(409.831,SDI_",",.02)="YES"
QUIT
+15 if SDRES1=""
SET SDRES1=SDI
+16 if $PIECE(SDRESTYP,";",2)'="SC("
QUIT
+17 SET SDRES=SDI
End DoDot:1
if SDRES'=""
QUIT
+18 IF SDRES=""
IF SDRES1'=""
SET SDRES=SDRES1
+19 QUIT SDRES
+20 ;
GETGAF(DFN) ;
+1 NEW GAF,GAFR
+2 SET GAF=$$NEWGAF^SDUTL2(DFN)
+3 SET GAFR=""
+4 if GAF=""
SET GAF=-1
+5 SET $PIECE(GAFR,"|",1)=$SELECT(+GAF:"New GAF Required",1:"No new GAF required")
+6 QUIT GAFR
+7 ;
ETHNLIST(ETHNICITY,DFN) ;get ethnicity list
+1 ;INPUT:
+2 ; DFN = Patient ID pointer to PATIENT file
+3 ;RETURN:
+4 ; PETH - Patient Ethnicity list separated by pipe |
+5 ; Pointer to ETHNICITY file 10.2
+6 ; PETHN - Patient Ethnicity names separated by pipe |
+7 NEW SDI,SDID,PETH,PETHN
+8 SET (PETH,PETHN)=""
+9 SET SDI=0
FOR
SET SDI=$ORDER(^DPT(DFN,.06,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+10 SET SDID=$PIECE($GET(^DPT(DFN,.06,SDI,0)),U,1)
+11 SET PETH=$SELECT(PETH'="":PETH_"|",1:"")_SDID
+12 SET PETHN=$SELECT(PETHN'="":PETHN_"|",1:"")_$PIECE($GET(^DIC(10.2,SDID,0)),U,1)
End DoDot:1
+13 SET ETHNICITY("NAMES")=PETHN
+14 SET ETHNICITY("IENS")=PETH
+15 QUIT
RACELIST(RACELST,DFN) ;get list of race information for given patient
+1 ;INPUT:
+2 ; DFN = Patient ID pointer to PATIENT file
+3 ;RETURN:
+4 ; RACEIEN - Patient race list separated by pipe |
+5 ; Pointer to RACE file 10
+6 ; RACENAM - Patient race names separated by pipe |
+7 NEW SDI,SDID,RACEIEN,RACENAM
+8 SET (RACEIEN,RACENAM)=""
+9 SET SDI=0
FOR
SET SDI=$ORDER(^DPT(DFN,.02,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+10 SET SDID=$PIECE($GET(^DPT(DFN,.02,SDI,0)),U,1)
+11 SET RACEIEN=$SELECT(RACEIEN'="":RACEIEN_"|",1:"")_SDID
+12 SET RACENAM=$SELECT(RACENAM'="":RACENAM_"|",1:"")_$PIECE($GET(^DIC(10,SDID,0)),U,1)
End DoDot:1
+13 SET RACELST("NAMES")=RACENAM
+14 SET RACELST("IENS")=RACEIEN
+15 QUIT
+16 ;
HRN(DFN) ;Health Record Number
+1 NEW X
+2 SET X=$GET(^AUPNPAT(DFN,41,+$GET(DUZ(2)),0))
+3 QUIT $SELECT($PIECE(X,U,3):"",1:$PIECE(X,U,2))
+4 ;
FLAGS(DFN,FNUM) ;get PRF flags
+1 ;INPUT:
+2 ; DFN - Patient ID
+3 ; FNUM - PRF Flag file ID 26.15=PRF NATIONAL FLAG 26.11=PRF LOCAL FLAG
+4 ;RETURN:
+5 ; Each | piece contains the following ;; pieces:
+6 ; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
+7 ; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
+8 ; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
+9 ; 4. PRFLNAME - PRF Local Flag name
+10 ; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
+11 ;
+12 NEW PRFAID,PRFID,PRFLST,RET,STAT
+13 SET RET=""
+14 SET DFN=$GET(DFN)
+15 if DFN=""
QUIT ""
+16 if '$DATA(^DPT(DFN,0))
QUIT ""
+17 SET FNUM=$GET(FNUM)
+18 if (FNUM'=26.15)&(FNUM'=26.11)
QUIT ""
+19 DO FLST(.PRFLIST,FNUM)
+20 SET PRFID=""
FOR
SET PRFID=$ORDER(PRFLIST(PRFID))
if PRFID=""
QUIT
Begin DoDot:1
+21 SET PRFAID=""
FOR
SET PRFAID=$ORDER(^DGPF(26.13,"AFLAG",PRFID,DFN,PRFAID))
if PRFAID=""
QUIT
Begin DoDot:2
+22 SET STAT=""
SET STAT=$$GET1^DIQ(26.13,PRFAID_",",.03,"I")
if STAT'=1
QUIT
+23 SET RET=RET_$SELECT(RET'="":"|",1:"")_PRFAID_";;"_STAT_";;"_+PRFID_";;"_$PIECE(PRFLIST(PRFID),U,1)_";;"_$PIECE(PRFLIST(PRFID),U,2)
End DoDot:2
End DoDot:1
+24 QUIT RET
FLST(PRFLIST,FNUM) ;build flag list
+1 NEW PRFID,PRFN
+2 KILL PRFLIST
+3 SET PRFN=""
FOR
SET PRFN=$ORDER(^DGPF(FNUM,"B",PRFN))
if PRFN=""
QUIT
Begin DoDot:1
+4 SET PRFID=""
FOR
SET PRFID=$ORDER(^DGPF(FNUM,"B",PRFN,PRFID))
if PRFID=""
QUIT
Begin DoDot:2
+5 SET PRFLIST(PRFID_";DGPF("_FNUM_",")=$$GET1^DIQ(FNUM,PRFID_",",.01)_U_$$GET1^DIQ(FNUM,PRFID_",",.02,"I")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
CREATEAVAIL(RETURN,SDCLINIC,DATES,TIMES,SLOTS,INDEFINITEUNTIL,SDEAS) ;INICSET2(.POP,SDIEN,.FDA,.SDCLINIC,.PROVIDER,.DIAGNOSIS,.SPECIALINSTRUCT,.PRIVLIAGEDUSER)
+1 ;
+2 NEW POP,SDAVAIL,I,SDDOWNUM,DOWNUM,EOF,SDTOTALSLOTS,SDDISPPERHR,SDCLINSTARTHR,SDSOH,SLT,IEN,SDCLINDATA,SDSLOTS,SDTIME,SDDATE,TMPINDX
+3 NEW SDRETURN,APPTCNT,ERRARRAY
+4 SET (POP,SDTOTALSLOTS,APPTCNT)=0
+5 DO VALIDATE
+6 IF 'POP
DO CREATE(SDCLINIC,SDCLINSTARTHR,SLT,SDDOWNUM)
+7 IF 'POP
SET SDRETURN("ClinicAvailability","Create")="Pattern Filed"
+8 DO BUILDER
+9 KILL ERRARRAY
+10 QUIT
+11 ;
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 ;EMERGENCY DEPT EXCEPTION
IF SDSLOTS=0
IF $$GET1^DIQ(40.7,$$GET1^DIQ(44,SDCLINIC,8,"I"),1,"I")'="130"
Begin DoDot:3
+53 IF SDSLOTS<1!(SDSLOTS>26)
DO ERRLOG(125)
QUIT
End DoDot:3
+54 SET TIMES(STARTTIME)=SDTIME_"^"_SDSLOTS
+55 SET SDTOTALSLOTS=SDTOTALSLOTS+SDSLOTS
End DoDot:2
+56 IF 'POP
IF $DATA(TIMES)'>1
DO ERRLOG(52,"No valid time segments passed in")
+57 ;Can't start prior to clinic opening
+58 IF 'POP
IF +$ORDER(TIMES(""))<(SDCLINSTARTHR*100)
DO ERRLOG(52,"Appointments can not start prior to clinic opening")
End DoDot:1
+59 ;
+60 SET DATES=$GET(DATES)
+61 SET SDDATE=$PIECE(DATES,";",1)
+62 IF SDDATE=""
DO ERRLOG(45)
+63 IF SDDATE'=""
Begin DoDot:1
+64 ;vse-2396
IF SDDATE'?7N
SET SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)
+65 IF SDDATE'?7N
DO ERRLOG(46)
QUIT
+66 ;I SDDATE<DT D ERRLOG(71) Q
+67 SET SDDOWNUM=$$DOW^XLFDT(SDDATE,1)
SET DATES(SDDATE)=""
+68 ;D GETAPPT
+69 ;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
End DoDot:1
+70 ;
+71 if POP
QUIT
+72 IF 'POP
IF $DATA(DATES)'>1
DO ERRLOG(52,"No valid dates passed in")
QUIT
+73 ;
+74 SET EOF=0
+75 FOR I=2:1:$LENGTH(DATES,";")
Begin DoDot:1
+76 SET SDDATE=$PIECE(DATES,";",I)
+77 if 'SDDATE
QUIT
+78 ;Indefinitely
IF SDDATE=9999999
SET DATES(SDDATE)=""
SET EOF=1
QUIT
+79 ;vse-2396
IF SDDATE'?7N
SET SDDATE=$$ISOTFM^SDAMUTDT(SDDATE)
+80 IF SDDATE'?7N
DO ERRLOG(46)
QUIT
+81 ;I SDDATE<DT D ERRLOG(71)
+82 IF $GET(SDDOWNUM)'=$$DOW^XLFDT(SDDATE,1)
DO ERRLOG(52,"Schedule days do not match")
SET EOF=1
+83 SET DATES(SDDATE)=""
+84 ;D GETAPPT
+85 ;I $G(ERRARRAY(SDDATE))=1 D ERRLOG(52,"Pending appointments must be cancelled")
+86 ;I $D(SDRETURN("ClinicAvailability","Appt")) D ERRLOG(52,"Pending appointments must be cancelled")
End DoDot:1
if EOF
QUIT
+87 ;
+88 SET SDEAS=$GET(SDEAS,"")
+89 IF $LENGTH(SDEAS)
SET SDEAS=$$EASVALIDATE^SDESUTIL(SDEAS)
+90 IF SDEAS=-1
DO ERRLOG(142)
+91 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))
SET INDEFINITEUNTIL=$$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 ;
