- 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 Jan 18, 2025@03:55:56 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 ;