SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB - SDES2 UTILITIES Continued ;FEB 08, 2024
;;5.3;Scheduling;**870,861,873**;Aug 13, 1993;Build 10
;;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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2UTIL1 4488 printed Apr 09, 2024@22:01:14 Page 2
SDES2UTIL1 ;ALB/MGD/TJB/MGD,TJB - SDES2 UTILITIES Continued ;FEB 08, 2024
+1 ;;5.3;Scheduling;**870,861,873**;Aug 13, 1993;Build 10
+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 ;
