SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB,BLB - SDES2 UTILITIES Continued ;FEB 08, 2024
;;5.3;Scheduling;**870,861,873,890**;Aug 13, 1993;Build 5
;;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
;
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,INDEFINITEUNTIL,DATES,TIMES,SDDISPPERHR,SDRETURN,ERRORS) ;
;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,SDRETURN
N POP,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,SDSOH,RETURN
S POP=0
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
K DATES,TIMES
Q
;
G3 ;
;
;
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
;
K Y
I SI+SI+$L(X)>80 K ^SC(DA,"T",D0) S CNT=0,LT=$G(STIME),SDEL=0 S POP=1 D ERRLOG^SDES2JSON(.ERRORS,596) 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
;
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 ;
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 ;
Q
APPERR ;
N %
Q
DELERR ;
S Y=D
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 ;
N JSONERR
S JSONERR=""
D ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2UTIL1 10036 printed Sep 23, 2025@20:31:28 Page 2
SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB,BLB - SDES2 UTILITIES Continued ;FEB 08, 2024
+1 ;;5.3;Scheduling;**870,861,873,890**;Aug 13, 1993;Build 5
+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 ;
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,INDEFINITEUNTIL,DATES,TIMES,SDDISPPERHR,SDRETURN,ERRORS) ;
+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,SDRETURN
+4 NEW POP,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,SDSOH,RETURN
+5 SET POP=0
+6 SET STARTTIME=STARTDAY*100
+7 SET (HSI,SI)=$GET(SDDISPPERHR,4)
+8 if SI=1
SET SI=4
SET HSI=1
+9 if SI=2
SET SI=4
SET HSI=2
+10 ;
+11 ;S DIC(0)="MAQEZL",(DIC,DIE)="^SC("_DA_",""T"",",DIC("W")=$P($T(DOW),";",3)
+12 if '$DATA(^SC(DA,"T",0))
SET ^SC(DA,"T",0)="^44.002D"
+13 ;
+14 SET D0=""
+15 FOR
SET (SD,D0)=$ORDER(DATES(D0))
if D0=""
QUIT
Begin DoDot:1
+16 if D0?7"9"
QUIT
+17 SET (CNT,INDEFINITELY)=0
+18 IF $ORDER(DATES(D0))?7"9"
SET INDEFINITELY=1
+19 SET STARTTIME=""
+20 FOR
SET STARTTIME=$ORDER(TIMES(STARTTIME))
if STARTTIME=""
QUIT
Begin DoDot:2
+21 SET X=TIMES(STARTTIME)
+22 SET T2=$PIECE($PIECE(X,"^",1),"-",2)
+23 SET NSL=$PIECE(X,"^",2)
+24 SET T1=STARTTIME
+25 ;Set up time slots in the T node
DO G3
End DoDot:2
if POP
QUIT
+26 ;
+27 ;Set up pattern for the date
if 'POP
DO G5
End DoDot:1
if POP
QUIT
+28 KILL DATES,TIMES
+29 QUIT
+30 ;
G3 ;
+1 ;
+2 ;
+3 ;????
SET SDTOP=1
+4 SET SDZQ=1
+5 ;
+6 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)
+7 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 ;
+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
SET POP=1
DO ERRLOG^SDES2JSON(.ERRORS,596)
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 ;
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 ;
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 ;
+1 QUIT
APPERR ;
+1 NEW %
+2 QUIT
DELERR ;
+1 SET Y=D
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 ;
+1 NEW JSONERR
+2 SET JSONERR=""
+3 DO ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
+4 QUIT
+5 ;
