Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDES2UTIL1

SDES2UTIL1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. Q
  1. VALBOOLEAN(SDERRORS,SDBOOLEAN,SDREQUIRED,SDERRORTEXT) ;
  1. ; SDERRORS = Array to hold any logged errors
  1. ; SDBOOLEAN = Boolean input array element to validate
  1. ; SDREQUIRED = 1:Required, 0:Optional, Defaults to 0
  1. ; SDERRORTEXT = Additional text to append to error message. This is normally the name of the input parameter element.
  1. ;
  1. I SDREQUIRED=0,SDBOOLEAN="" Q
  1. S SDREQUIRED=$S($G(SDREQUIRED)="":0,1:$G(SDREQUIRED))
  1. I SDREQUIRED=1,SDBOOLEAN="" D ERRLOG^SDESJSON(.SDERRORS,519,SDERRORTEXT)
  1. I SDBOOLEAN'="1",SDBOOLEAN'="0" D ERRLOG^SDESJSON(.SDERRORS,518,SDERRORTEXT)
  1. Q
  1. ;
  1. GETRES(SDCL,INACT) ; Extrinsic function to return resource for clinic - SDEC RESOURCE (409.831)
  1. ; SDCL = Clinic IEN from File 44
  1. ; INACT = If not null, skip check to see if resource is inactive
  1. ; Return value is the associated resource or the empty string
  1. ;
  1. ; SDHLN - Name of the Clinic from File 44
  1. ; SDI - Resource IEN from file 409.831
  1. ; SDRESTYP - RESOURCE TYPE, Field .012 from File 409.831
  1. N SDHLN,SDI,SDRESTYP,SDRES,SDRES1
  1. S (SDRES,SDRES1)=""
  1. S SDHLN=$$GET1^DIQ(44,SDCL_",",.01,"E")
  1. Q:SDHLN="" ""
  1. S SDI="" F S SDI=$O(^SDEC(409.831,"ALOC",SDCL,SDI)) Q:SDI="" D Q:SDRES'=""
  1. .S SDRESTYP=$$GET1^DIQ(409.831,SDI_",",.012,"I")
  1. .I '$G(INACT) Q:$$GET1^DIQ(409.831,SDI_",",.02)="YES"
  1. .S:SDRES1="" SDRES1=SDI
  1. .Q:$P(SDRESTYP,";",2)'="SC("
  1. .S SDRES=SDI
  1. I SDRES="",SDRES1'="" S SDRES=SDRES1
  1. Q SDRES
  1. ;
  1. GETGAF(DFN) ;
  1. N GAF,GAFR
  1. S GAF=$$NEWGAF^SDUTL2(DFN)
  1. S GAFR=""
  1. S:GAF="" GAF=-1
  1. S $P(GAFR,"|",1)=$S(+GAF:"New GAF Required",1:"No new GAF required")
  1. Q GAFR
  1. ;
  1. ETHNLIST(ETHNICITY,DFN) ;get ethnicity list
  1. ;INPUT:
  1. ; DFN = Patient ID pointer to PATIENT file
  1. ;RETURN:
  1. ; PETH - Patient Ethnicity list separated by pipe |
  1. ; Pointer to ETHNICITY file 10.2
  1. ; PETHN - Patient Ethnicity names separated by pipe |
  1. N SDI,SDID,PETH,PETHN
  1. S (PETH,PETHN)=""
  1. S SDI=0 F S SDI=$O(^DPT(DFN,.06,SDI)) Q:SDI'>0 D
  1. .S SDID=$P($G(^DPT(DFN,.06,SDI,0)),U,1)
  1. .S PETH=$S(PETH'="":PETH_"|",1:"")_SDID
  1. .S PETHN=$S(PETHN'="":PETHN_"|",1:"")_$P($G(^DIC(10.2,SDID,0)),U,1)
  1. S ETHNICITY("NAMES")=PETHN
  1. S ETHNICITY("IENS")=PETH
  1. Q
  1. RACELIST(RACELST,DFN) ;get list of race information for given patient
  1. ;INPUT:
  1. ; DFN = Patient ID pointer to PATIENT file
  1. ;RETURN:
  1. ; RACEIEN - Patient race list separated by pipe |
  1. ; Pointer to RACE file 10
  1. ; RACENAM - Patient race names separated by pipe |
  1. N SDI,SDID,RACEIEN,RACENAM
  1. S (RACEIEN,RACENAM)=""
  1. S SDI=0 F S SDI=$O(^DPT(DFN,.02,SDI)) Q:SDI'>0 D
  1. .S SDID=$P($G(^DPT(DFN,.02,SDI,0)),U,1)
  1. .S RACEIEN=$S(RACEIEN'="":RACEIEN_"|",1:"")_SDID
  1. .S RACENAM=$S(RACENAM'="":RACENAM_"|",1:"")_$P($G(^DIC(10,SDID,0)),U,1)
  1. S RACELST("NAMES")=RACENAM
  1. S RACELST("IENS")=RACEIEN
  1. Q
  1. ;
  1. HRN(DFN) ;Health Record Number
  1. N X
  1. S X=$G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0))
  1. Q $S($P(X,U,3):"",1:$P(X,U,2))
  1. ;
  1. FLAGS(DFN,FNUM) ;get PRF flags
  1. ;INPUT:
  1. ; DFN - Patient ID
  1. ; FNUM - PRF Flag file ID 26.15=PRF NATIONAL FLAG 26.11=PRF LOCAL FLAG
  1. ;RETURN:
  1. ; Each | piece contains the following ;; pieces:
  1. ; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
  1. ; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
  1. ; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
  1. ; 4. PRFLNAME - PRF Local Flag name
  1. ; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
  1. ;
  1. N PRFAID,PRFID,PRFLST,RET,STAT
  1. S RET=""
  1. S DFN=$G(DFN)
  1. Q:DFN="" ""
  1. Q:'$D(^DPT(DFN,0)) ""
  1. S FNUM=$G(FNUM)
  1. Q:(FNUM'=26.15)&(FNUM'=26.11) ""
  1. D FLST(.PRFLIST,FNUM)
  1. S PRFID="" F S PRFID=$O(PRFLIST(PRFID)) Q:PRFID="" D
  1. .S PRFAID="" F S PRFAID=$O(^DGPF(26.13,"AFLAG",PRFID,DFN,PRFAID)) Q:PRFAID="" D
  1. ..S STAT="" S STAT=$$GET1^DIQ(26.13,PRFAID_",",.03,"I") Q:STAT'=1
  1. ..S RET=RET_$S(RET'="":"|",1:"")_PRFAID_";;"_STAT_";;"_+PRFID_";;"_$P(PRFLIST(PRFID),U,1)_";;"_$P(PRFLIST(PRFID),U,2)
  1. Q RET
  1. FLST(PRFLIST,FNUM) ;build flag list
  1. N PRFID,PRFN
  1. K PRFLIST
  1. S PRFN="" F S PRFN=$O(^DGPF(FNUM,"B",PRFN)) Q:PRFN="" D
  1. .S PRFID="" F S PRFID=$O(^DGPF(FNUM,"B",PRFN,PRFID)) Q:PRFID="" D
  1. ..S PRFLIST(PRFID_";DGPF("_FNUM_",")=$$GET1^DIQ(FNUM,PRFID_",",.01)_U_$$GET1^DIQ(FNUM,PRFID_",",.02,"I")
  1. Q
  1. ;
  1. CHECKDURATION(T1,T2,SLT) ;Ensure the appointment lengths align with the time segment
  1. N H1,H2,M1,M2,SDL,SD1
  1. S H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
  1. S:M1=0 M1=60,H1=H1-1
  1. S:M2=0 M2=60,H2=H2-1
  1. S SD1=M2-M1+((H2-H1)*60),SDL=SD1\SLT
  1. I SDL*SLT'=+SD1 Q 0
  1. Q 1
  1. ;
  1. CREATE(DA,STARTDAY,SLT,DOW,INDEFINITEUNTIL,DATES,TIMES,SDDISPPERHR,SDRETURN,ERRORS) ;
  1. ;DA = Clinic IEN (SDCLINIC)
  1. ;SLT - Appointment length
  1. N D0,X,CNT,STARTTIME,T1,T2,NSL,CTR,DR,HY,MAX,SC,SD,SDREB,SDSTRTDT,SDZQ,ST,STR,Y1,INDEFINITELY,STIME,SDRETURN
  1. 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
  1. S POP=0
  1. S STARTTIME=STARTDAY*100
  1. S (HSI,SI)=$G(SDDISPPERHR,4)
  1. S:SI=1 SI=4,HSI=1
  1. S:SI=2 SI=4,HSI=2
  1. ;
  1. ;S DIC(0)="MAQEZL",(DIC,DIE)="^SC("_DA_",""T"",",DIC("W")=$P($T(DOW),";",3)
  1. S:'$D(^SC(DA,"T",0)) ^SC(DA,"T",0)="^44.002D"
  1. ;
  1. S D0=""
  1. F S (SD,D0)=$O(DATES(D0)) Q:D0="" D Q:POP
  1. .Q:D0?7"9"
  1. .S (CNT,INDEFINITELY)=0
  1. .I $O(DATES(D0))?7"9" S INDEFINITELY=1
  1. .S STARTTIME=""
  1. .F S STARTTIME=$O(TIMES(STARTTIME)) Q:STARTTIME="" D Q:POP
  1. ..S X=TIMES(STARTTIME)
  1. ..S T2=$P($P(X,"^",1),"-",2)
  1. ..S NSL=$P(X,"^",2)
  1. ..S T1=STARTTIME
  1. ..D G3 ;Set up time slots in the T node
  1. .;
  1. .D:'POP G5 ;Set up pattern for the date
  1. K DATES,TIMES
  1. Q
  1. ;
  1. G3 ;
  1. ;
  1. ;
  1. S SDTOP=1 ;????
  1. S SDZQ=1
  1. ;
  1. S LT=T2,H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
  1. S M2=M2-SLT
  1. G3A I M2<0 S M2=M2+60,H2=H2-1 G G3A
  1. S:M2?1N M2="0"_M2 S:H2?1N H2="0"_H2
  1. G4 S CNT=CNT+1,^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_NSL
  1. S M1=M1+SLT
  1. G4A I M1>59 S M1=M1-60,H1=H1+1 G G4A
  1. S:M1?1N M1="0"_M1 S:H1?1N H1="0"_H1
  1. I (H1_M1)>(H2_M2) Q
  1. G G4
  1. Q
  1. ;
  1. G5 ;
  1. S SDEL=0
  1. G:'CNT DEL1:'$D(SDREACT),DEL1:'$D(SDTOP)&$D(SDREACT)&'CNT,C^SDB
  1. S ^SC(DA,"T",D0,0)=D0,^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
  1. S X=^SC(DA,"T",0),^SC(DA,"T",0)="^44.002D^"_D0_"^"_($P(X,"^",4)+1)
  1. S DH=SLT*SI\60
  1. F ZDX=CNT:0 S ZDX=$O(^SC(DA,"T",D0,2,ZDX)) Q:ZDX="" K ^SC(DA,"T",D0,2,ZDX)
  1. F X=0:0 S X=$O(^SC(DA,"T",D0,2,X)) Q:X="" D
  1. .S Y=^SC(DA,"T",D0,2,X,0)
  1. .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)
  1. S (DH,DO,X)=""
  1. I $D(Y)=1 S SDEL=1 G D
  1. I $D(HSI) I HSI=1!(HSI=2) D CKSI1
  1. 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
  1. ;
  1. K Y
  1. 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
  1. G D
  1. 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)
  1. F HHY=0:0 S HHY=$O(Y(HHY)) Q:HHY="" I '$D(HY(HHY)) K Y(HHY)
  1. Q
  1. ;
  1. DEL1 S (DH,DO,X)="",SDEL=1
  1. D I $D(SDIN),SDIN>D0 S SDRE1=$S(SDRE:SDRE,1:9999999)
  1. S DH=X,OK=0,CTR=0
  1. S SDSOH=$S('$D(^SC(DA,"SL")):0,$P(^SC(DA,"SL"),"^",8)']"":0,1: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
  1. I X'>0,$D(SDIN),SDIN>D0 D
  1. .S SDRE1=$S(SDRE=0:9999999,1:SDRE)
  1. .S X=SDIN
  1. .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
  1. I OK S Y=X,DO=D0 G R
  1. S DO=9999999
  1. R K OK
  1. ;
  1. EN1 ;
  1. S D=D0
  1. I 'INDEFINITELY G 1
  1. S Y=""
  1. I '$D(^SC(DA,"T"_DOW,D0,1)) D
  1. .S Y=+$O(^SC(DA,"T"_DOW,D0))
  1. .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
  1. 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
  1. S ^SC(DA,"T"_DOW,DO,1)=DH,^SC(DA,"T"_DOW,DO,0)=DO D TX
  1. S X=D0 D B1^SDB1 S MAX=$$DAYSINFUTURE(DA,SD),SC=DA,SDSTRTDT=SD
  1. Q:'CNT
  1. D OVR^SDAUT1 I $G(DO)'=9999999 S SDRETURN("ClinicAvailability","DateIndefiniteScheduleEnds")=$$FMTISO^SDAMUTDT($G(DO)) S INDEFINITEUNTIL=$$FMTISO^SDAMUTDT($G(DO)) Q:'SDZQ
  1. Q
  1. ;
  1. DAYSINFUTURE(CLINICIEN,STARTDATE) ;
  1. N FUTUREBOOKINGNUM,FUTUREBOOKDATE,HOLIDAYFILEDATE
  1. ;
  1. S FUTUREBOOKINGNUM=$S($$GET1^DIQ(44,CLINICIEN,2002,"I"):$$GET1^DIQ(44,CLINICIEN,2002,"I"),1:390)
  1. S FUTUREBOOKDATE=$$FMADD^XLFDT(STARTDATE,FUTUREBOOKINGNUM)
  1. S HOLIDAYFILEDATE="",HOLIDAYFILEDATE=$O(^HOLIDAY("B",HOLIDAYFILEDATE),-1)
  1. ;
  1. I FUTUREBOOKDATE<HOLIDAYFILEDATE Q FUTUREBOOKINGNUM
  1. Q $$FMDIFF^XLFDT(HOLIDAYFILEDATE,STARTDATE)
  1. ;
  1. 1 I SDEL S POP=0 D APPCK I POP D DELERR G OVR
  1. 11 G:$D(^HOLIDAY(D,0))&('SDSOH) OVR
  1. S POP=0
  1. D:$D(SDIN) CHK2
  1. G:POP OVR
  1. S (POP,SDREB)=0
  1. S %=1
  1. D APPCK
  1. I POP D APPERR G:(%-1) OVR S SDREB=1
  1. S X=D,DO=X+1,^SC(DA,"ST",X,9)=D,SDREACT=1
  1. S:'$D(^SC(DA,"ST",0)) ^SC(DA,"ST",0)="^44.005DA^^" D B1^SDB1 ;
  1. OVR ;
  1. I D#100<22 S D=D+7 S POP=0 D:$D(SDIN) CHK2 Q
  1. S X1=D,X2=7 D C^%DTC S D=X S POP=0 D:$D(SDIN) CHK2 Q
  1. ;
  1. APPCK ;
  1. Q
  1. APPERR ;
  1. N %
  1. Q
  1. DELERR ;
  1. S Y=D
  1. CHK1 Q:'$D(SDIN)
  1. I Y=SDIN S POP=1
  1. Q
  1. ;
  1. CHK2 ;
  1. I SDIN<D,SDRE,SDRE'>D K SDIN Q
  1. I SDIN<D,SDRE=0 S POP=1 Q
  1. 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
  1. 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
  1. Q
  1. OB ;
  1. S SDSLOT=$E(STR,$F(STR,ST)-2)
  1. I SDSLOT?1P,SDSLOT'?1" " S ^SC(DA,"S",DR,1,Y,"OB")="O" K SDSLOT Q
  1. K ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
  1. Q
  1. TX ;
  1. 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
  1. ;
  1. ERRLOG(ERNUM,OPTIONALTXT) ;
  1. S POP=1
  1. D ERRLOG^SDESJSON(.SDRETURN,$G(ERNUM),$G(OPTIONALTXT))
  1. Q
  1. BUILDER ;
  1. N JSONERR
  1. S JSONERR=""
  1. D ENCODE^SDESJSON(.SDRETURN,.RETURN,.JSONERR)
  1. Q
  1. ;