DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
;;5.3;Registration;**425,554,650,951,1017**;Aug 13, 1993;Build 1
; Last Edited: SHRPE/sgm - Sep 26, 2018 16:46
;
; ICR# TYPE DESCRIPTION
;----- ---- ------------------------------
;10026 Sup ^DIR
; 2052 Sup $$GET1^DID
; 2053 Sup CHK^DIE
; 2055 Sup $$EXTERNAL^DILFD
; 2701 Sup ^MPIF001: $$GETICN, $$IFLOCAL
;
Q ;no direct entry
;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS,DIRX) ;
; Wrap FileMan Classic Reader call
; Input
; DGDIR0 - DIR(0) string
; DGDIRA - DIR("A") string (may be passed by reference [dg*951])
; DGDIRB - DIR("B") string
; DGDIRH - DIR("?") string (may be passed by reference [dg*951])
; DGDIRS - DIR("S") string
; .DIRX - [optional] - multi-function - DG*5.3*951
; a) you may pass .DIR() instead of individual variables
; b) if DIRX=-2 you wish this API to return -2 upon time-out
;
; Output
; Function Value - Internal value returned from ^DIR or -1 if user
; up-arrows, double up-arrows or the read times out.
; DG*5.3*951, if .DIRX is passed then upon time out
; return -2
;
; DIR(0) type Results
; ------------ -------------------------------
; DD IEN of selected entry
; Pointer IEN of selected entry
; Set of Codes Internal value of code
; Yes/No 0 for No, 1 for Yes
;
N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
I $D(DIRX),$G(DIRX)'=-2 M DIR=DIRX
E D
. S DIR(0)=DGDIR0
. S DIR("A")=$G(DGDIRA)
. I $D(DGDIRA)>9 M DIR("A")=DGDIRA("A")
. I $G(DGDIRB)]"" S DIR("B")=DGDIRB
. I $D(DGDIRH) S DIR("?")=DGDIRH
. I $D(DGDIRH)>9 M DIR("?")=DGDIRH
. I $G(DGDIRS)]"" S DIR("S")=DGDIRS
. Q
D ^DIR
; DG*5.3*951 - original code did not distinguish between time-out
; and "^"-out and just pressing ENTER.
I $D(DIRX) D Q Z
. S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
. I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U))
. Q
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q $S(X="@":"@",1:$P(Y,U))
;
CONTINUE() ;pause display
;
; Input: none
;
; Output: 1 - continue
; 0 - quit
;
N DIR,Y
S DIR(0)="E" D ^DIR
Q $S(Y'=1:0,1:1)
;
CKWP(DGROOT,DGTX) ; ck word processing required fields
;;Text did not have a minimum of 3 consecutive alpha characters
;;Text contained TAB characters
;;Text contained control characters
;;Each <TAB> character was replaced with a single <space> character
;;
; rewritten in DG*5.3*951
; Require a minimum of 3 alpha characters, no control codes
; INPUT PARAMETERS:
; .DGROOT(n,0) = (required) text
; .DGTX(n) = (optional) return additional text for calling
; program to display
;
; EXTRINSIC FUNCTION returns:
; 1:text is good, 0:text is not acceptable
;
N X,Y,ALPHA,LINE,STR,NOCTRL,NOTAB,TEMP
S (ALPHA,LINE)=0,(NOCTRL,NOTAB)=1,STR=""
I $D(@DGROOT) D
. N I,X S I=0 F S I=$O(@DGROOT@(I)) Q:I="" S X=@DGROOT@(I,0) D
. . I 'ALPHA S STR=STR_X_" "
. . I 'ALPHA,STR?.E3A.E S ALPHA=1
. . I NOTAB,X[$C(9) S NOTAB=0
. . S X=$TR(X,$C(9))
. . I NOCTRL,X?.E1C.E S NOCTRL=0
. . Q
. Q
;
I 'ALPHA S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+1),";"," ")
I 'NOTAB S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+2),";"," ")
I 'NOCTRL S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+3),";"," ")
Q $D(DGTX)=0
;
DIQ(FILE,XDA,FLD) ; retrieve single value from record; DG*5.3*951
N X,DGERR,DGWP,DIERR
S FILE=+$G(FILE) I FILE<2 Q ""
S FLD=$G(FLD) I '$L(FLD) Q ""
S XDA=$G(XDA) I 'XDA Q ""
I $E(XDA,$L(XDA))'="," S XDA=XDA_","
S X=$$GET1^DIQ(FILE,XDA,FLD,.DGWP,,"DGERR")
S:$D(DIERR) X=-1
Q X
;
GET1(FILE,FLD,FLG,ATT,PAD) ; call $$GET1^DID ; dg*951
N X,DGPFERR,DIERR,MSG
S MSG="Unexpected error encountered"
I '$G(FILE) Q MSG
I '$L($G(FLD)) Q MSG
I '$L($G(ATT)) Q MSG
S FLG=$G(FLG),PAD=$G(PAD)
S X=$$GET1^DID(FILE,FLD,FLG,ATT,,"DGPFERR")
I $D(DIERR) Q MSG
S:$L(PAD) X=X_" "_PAD
Q X
;
GETNXTF(DGDFN,DGLTF) ;get previous treating facility
;This function will return the treating facility with a DATE LAST
;TREATED value immediately prior to the date for the treating facility
;passed as the second parameter. The most recent treating facility
;will be returned when the second parameter is missing, null, or zero.
;
; Input:
; DGDFN - pointer to patient in PATIENT (#2) file
; DGLTF - (optional) last treating facility [default=0]
;
; Output:
; Function value - previous facility as a pointer to INSTITUTION (#4)
; file on success; 0 on failure
;
N DGARR ;fully subscripted array node
N DGDARR ;date sorted treating facilities
N DGINST ;institution pointer
N DGNAM ;name of sorted treating facilities array
N DGTFARR ;array of non-local treating facilities
;
;
I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
. ;
. ;validate last treating facility input parameter
. S DGLTF=+$G(DGLTF)
. S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
. ;
. ;build date sorted list
. S DGINST=0
. F S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST D
. . S DGDARR(DGTFARR(DGINST),DGINST)=""
. ;
. ;find entry for previous treating facility
. S DGNAM="DGDARR"
. S DGARR=$QUERY(@DGNAM@(""),-1)
. I DGLTF,DGARR]"" D
. . I $QS(DGARR,2)'=DGLTF D
. . . F S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
. . S DGARR=$QUERY(@DGARR,-1)
;
Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
;
ISDIV(DGSITE) ;is site local division
;
; Input:
; DGSITE - pointer to INSTITUTION (#4) file
;
; Output:
; Function value - 1 on success; 0 on failure
;
S DGSITE=+$G(DGSITE)
Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)
;
MPIOK(DGDFN,DGICN) ;return national ICN
;This function verifies that a given patient has a valid national
;Integration Control Number.
;
; Supported DBIA #2701: The supported DBIA is used to access MPI
; APIs to retrieve ICN and determine if ICN
; is local.
;
; Input:
; DGDFN - (required) IEN of patient in PATIENT (#2) file
; DGICN - (optional) passed by reference to contain national ICN
;
; Output:
; Function Value - 1 on valid national ICN;
; 0 on failure
; DGICN - Patient's Integrated Control Number
;
N DGRSLT
S DGRSLT=0
I $G(DGDFN)>0 D
. S DGICN=$$GETICN^MPIF001(DGDFN)
. ;
. ;ICN must be valid
. Q:(DGICN'>0)
. ;
. ;ICN must not be local
. Q:$$IFLOCAL^MPIF001(DGDFN)
. ;
. S DGRSLT=1
Q DGRSLT
;
STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
;
; Input:
; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
; HISTORY (#26.14) file in internal or external format
;
; Output:
; Function Value - Status value on success, -1 on failure
;
N DGERR ;FM message root
N DGRSLT ;CHK^DIE result array
N DGSTAT ;calculated status value
;
S DGSTAT=-1
I $G(DGACT)]"" D
. N DIERR
. I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
. Q:$D(DGERR)
. D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
. Q:$D(DGERR)
. S DGSTAT=$S(DGRSLT(0)="INACTIVATE":0,DGRSLT(0)="ENTERED IN ERROR":0,DGRSLT(0)="REFRESH INACTIVE":0,1:1)
;. I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
;. E S DGSTAT=1
; DG*5.3*1017 using $S and adding "REFRESH INACTIVE" as possible action
Q DGSTAT
;
TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
;
; Input:
; DGFIL - (required) File number
; DGFLD - (required) Field number or sub-dd#,field#
; DGVAL - (required) Field value to be validated
;
; Output:
; Function Value - Returns 1 if value is valid, 0 if value is invalid
;
N DGVALEX ;external value after conversion
N DGTYP ;field type
N DGRSLT ;results of CHK^DIE
N VALID ;function results
;
S VALID=1
S DGFIL=$G(DGFIL),DGFLD=$G(DGFLD),DGVAL=$G(DGVAL)
I $L(DGFIL),$L(DGFLD),$L(DGVAL) D
. N DGPFERR,DIERR
. S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL,"DGPFERR")
. I $D(DIERR) S VALID=0 Q
. I DGVALEX="" S VALID=0 Q
. I $$GET1(DGFIL,DGFLD,"","TYPE")'["POINTER" D
. . D:'$D(DIERR) CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT,"DGFERR")
. . I '$D(DIERR),DGRSLT="^" S VALID=0
. . Q
. I $D(DIERR) S VALID=0
Q VALID
;
VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
;
; Input:
; DGRTN - (required) Routine name that contains $TEXT table
; DGFILE - (required) File number for input values
; DGIP - (required) Input value array passed by reference
; DGERR - (optional) Returns error message passed by reference
;
; Output:
; Function Value - Returns 1 on all values valid, 0 on failure
;
I $G(DGRTN)=""!('$G(DGFILE)) Q 0
N DGVLD ;function return value
N DGFXR ;node name to field xref array
N DGREQ ;array of required fields
N DGWP ;1:word processing;
N DGN ;array node name
;
S DGVLD=1
S DGN=""
D BLDXR(DGRTN,.DGFXR)
;
F S DGN=$O(DGFXR(DGN)) Q:DGN="" D Q:'DGVLD
. N DGPFERR,DIERR
. S DGREQ=$P(DGFXR(DGN),U,2)
. S DGWP=$P(DGFXR(DGN),U,3)
. I DGREQ D ;required field check
. . I DGWP=1,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
. . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0
. . Q
. I 'DGVLD D Q
. . S DGERR=$$GET1(DGFILE,+DGFXR(DGN),,"LABEL","REQUIRED")
. . Q
. Q:DGWP=1 ;don't check word processing fields for invalid values
. ;check for invalid values
. I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D Q
. . S DGVLD=0,DGERR=$$GET1(DGFILE,+DGFXR(DGN),,"LABEL","NOT VALID")
Q DGVLD
;
BLDXR(DGRTN,DGFLDA) ;build name/field xref array
;This procedure reads in the text from the XREF line tag of the DGRTN
;input parameter, loads name/field xref array with parsed line data.
;
; Input:
; DGRTN - (req) Routine name that contains the XREF line tag
; DGFLDA - (req) Array name for name/field xref passed by reference
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
; DGFLDA - Name/field xref array
; format: DGFLDA(subscript)=field#^required?^0/1 where
; 0:single value field; 1:word proc field
;
S DGRTN=$G(DGRTN) Q:DGRTN=""
I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
Q:($T(@DGRTN)="")
N LINE,OFF,REF
;
F OFF=1:1 S REF="XREF+"_OFF_DGRTN D Q:LINE=""
. N NM S LINE=$P($T(@REF),";",3,9)
. I $L(LINE) S NM=$P(LINE,";"),DGFLDA(NM)=$TR($P(LINE,";",2,4),";",U)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFUT 10646 printed Mar 13, 2025@21:53:22 Page 2
DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
+1 ;;5.3;Registration;**425,554,650,951,1017**;Aug 13, 1993;Build 1
+2 ; Last Edited: SHRPE/sgm - Sep 26, 2018 16:46
+3 ;
+4 ; ICR# TYPE DESCRIPTION
+5 ;----- ---- ------------------------------
+6 ;10026 Sup ^DIR
+7 ; 2052 Sup $$GET1^DID
+8 ; 2053 Sup CHK^DIE
+9 ; 2055 Sup $$EXTERNAL^DILFD
+10 ; 2701 Sup ^MPIF001: $$GETICN, $$IFLOCAL
+11 ;
+12 ;no direct entry
QUIT
+13 ;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS,DIRX) ;
+1 ; Wrap FileMan Classic Reader call
+2 ; Input
+3 ; DGDIR0 - DIR(0) string
+4 ; DGDIRA - DIR("A") string (may be passed by reference [dg*951])
+5 ; DGDIRB - DIR("B") string
+6 ; DGDIRH - DIR("?") string (may be passed by reference [dg*951])
+7 ; DGDIRS - DIR("S") string
+8 ; .DIRX - [optional] - multi-function - DG*5.3*951
+9 ; a) you may pass .DIR() instead of individual variables
+10 ; b) if DIRX=-2 you wish this API to return -2 upon time-out
+11 ;
+12 ; Output
+13 ; Function Value - Internal value returned from ^DIR or -1 if user
+14 ; up-arrows, double up-arrows or the read times out.
+15 ; DG*5.3*951, if .DIRX is passed then upon time out
+16 ; return -2
+17 ;
+18 ; DIR(0) type Results
+19 ; ------------ -------------------------------
+20 ; DD IEN of selected entry
+21 ; Pointer IEN of selected entry
+22 ; Set of Codes Internal value of code
+23 ; Yes/No 0 for No, 1 for Yes
+24 ;
+25 NEW X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+26 IF $DATA(DIRX)
IF $GET(DIRX)'=-2
MERGE DIR=DIRX
+27 IF '$TEST
Begin DoDot:1
+28 SET DIR(0)=DGDIR0
+29 SET DIR("A")=$GET(DGDIRA)
+30 IF $DATA(DGDIRA)>9
MERGE DIR("A")=DGDIRA("A")
+31 IF $GET(DGDIRB)]""
SET DIR("B")=DGDIRB
+32 IF $DATA(DGDIRH)
SET DIR("?")=DGDIRH
+33 IF $DATA(DGDIRH)>9
MERGE DIR("?")=DGDIRH
+34 IF $GET(DGDIRS)]""
SET DIR("S")=DGDIRS
+35 QUIT
End DoDot:1
+36 DO ^DIR
+37 ; DG*5.3*951 - original code did not distinguish between time-out
+38 ; and "^"-out and just pressing ENTER.
+39 IF $DATA(DIRX)
Begin DoDot:1
+40 SET Z=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,$DATA(DIROUT):-1,1:"")
+41 IF Z=""
SET Z=$SELECT(Y=-1:"",X="@":"@",1:$PIECE(Y,U))
+42 QUIT
End DoDot:1
QUIT Z
+43 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+44 QUIT $SELECT(X="@":"@",1:$PIECE(Y,U))
+45 ;
CONTINUE() ;pause display
+1 ;
+2 ; Input: none
+3 ;
+4 ; Output: 1 - continue
+5 ; 0 - quit
+6 ;
+7 NEW DIR,Y
+8 SET DIR(0)="E"
DO ^DIR
+9 QUIT $SELECT(Y'=1:0,1:1)
+10 ;
CKWP(DGROOT,DGTX) ; ck word processing required fields
+1 ;;Text did not have a minimum of 3 consecutive alpha characters
+2 ;;Text contained TAB characters
+3 ;;Text contained control characters
+4 ;;Each <TAB> character was replaced with a single <space> character
+5 ;;
+6 ; rewritten in DG*5.3*951
+7 ; Require a minimum of 3 alpha characters, no control codes
+8 ; INPUT PARAMETERS:
+9 ; .DGROOT(n,0) = (required) text
+10 ; .DGTX(n) = (optional) return additional text for calling
+11 ; program to display
+12 ;
+13 ; EXTRINSIC FUNCTION returns:
+14 ; 1:text is good, 0:text is not acceptable
+15 ;
+16 NEW X,Y,ALPHA,LINE,STR,NOCTRL,NOTAB,TEMP
+17 SET (ALPHA,LINE)=0
SET (NOCTRL,NOTAB)=1
SET STR=""
+18 IF $DATA(@DGROOT)
Begin DoDot:1
+19 NEW I,X
SET I=0
FOR
SET I=$ORDER(@DGROOT@(I))
if I=""
QUIT
SET X=@DGROOT@(I,0)
Begin DoDot:2
+20 IF 'ALPHA
SET STR=STR_X_" "
+21 IF 'ALPHA
IF STR?.E3A.E
SET ALPHA=1
+22 IF NOTAB
IF X[$CHAR(9)
SET NOTAB=0
+23 SET X=$TRANSLATE(X,$CHAR(9))
+24 IF NOCTRL
IF X?.E1C.E
SET NOCTRL=0
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 ;
+28 IF 'ALPHA
SET LINE=LINE+1
SET DGTX(LINE)=$TRANSLATE($TEXT(CKWP+1),";"," ")
+29 IF 'NOTAB
SET LINE=LINE+1
SET DGTX(LINE)=$TRANSLATE($TEXT(CKWP+2),";"," ")
+30 IF 'NOCTRL
SET LINE=LINE+1
SET DGTX(LINE)=$TRANSLATE($TEXT(CKWP+3),";"," ")
+31 QUIT $DATA(DGTX)=0
+32 ;
DIQ(FILE,XDA,FLD) ; retrieve single value from record; DG*5.3*951
+1 NEW X,DGERR,DGWP,DIERR
+2 SET FILE=+$GET(FILE)
IF FILE<2
QUIT ""
+3 SET FLD=$GET(FLD)
IF '$LENGTH(FLD)
QUIT ""
+4 SET XDA=$GET(XDA)
IF 'XDA
QUIT ""
+5 IF $EXTRACT(XDA,$LENGTH(XDA))'=","
SET XDA=XDA_","
+6 SET X=$$GET1^DIQ(FILE,XDA,FLD,.DGWP,,"DGERR")
+7 if $DATA(DIERR)
SET X=-1
+8 QUIT X
+9 ;
GET1(FILE,FLD,FLG,ATT,PAD) ; call $$GET1^DID ; dg*951
+1 NEW X,DGPFERR,DIERR,MSG
+2 SET MSG="Unexpected error encountered"
+3 IF '$GET(FILE)
QUIT MSG
+4 IF '$LENGTH($GET(FLD))
QUIT MSG
+5 IF '$LENGTH($GET(ATT))
QUIT MSG
+6 SET FLG=$GET(FLG)
SET PAD=$GET(PAD)
+7 SET X=$$GET1^DID(FILE,FLD,FLG,ATT,,"DGPFERR")
+8 IF $DATA(DIERR)
QUIT MSG
+9 if $LENGTH(PAD)
SET X=X_" "_PAD
+10 QUIT X
+11 ;
GETNXTF(DGDFN,DGLTF) ;get previous treating facility
+1 ;This function will return the treating facility with a DATE LAST
+2 ;TREATED value immediately prior to the date for the treating facility
+3 ;passed as the second parameter. The most recent treating facility
+4 ;will be returned when the second parameter is missing, null, or zero.
+5 ;
+6 ; Input:
+7 ; DGDFN - pointer to patient in PATIENT (#2) file
+8 ; DGLTF - (optional) last treating facility [default=0]
+9 ;
+10 ; Output:
+11 ; Function value - previous facility as a pointer to INSTITUTION (#4)
+12 ; file on success; 0 on failure
+13 ;
+14 ;fully subscripted array node
NEW DGARR
+15 ;date sorted treating facilities
NEW DGDARR
+16 ;institution pointer
NEW DGINST
+17 ;name of sorted treating facilities array
NEW DGNAM
+18 ;array of non-local treating facilities
NEW DGTFARR
+19 ;
+20 ;
+21 IF $GET(DGDFN)>0
IF $$BLDTFL^DGPFUT2(DGDFN,.DGTFARR)
Begin DoDot:1
+22 ;
+23 ;validate last treating facility input parameter
+24 SET DGLTF=+$GET(DGLTF)
+25 SET DGLTF=$SELECT(DGLTF&($DATA(DGTFARR(DGLTF))):DGLTF,1:0)
+26 ;
+27 ;build date sorted list
+28 SET DGINST=0
+29 FOR
SET DGINST=$ORDER(DGTFARR(DGINST))
if 'DGINST
QUIT
Begin DoDot:2
+30 SET DGDARR(DGTFARR(DGINST),DGINST)=""
End DoDot:2
+31 ;
+32 ;find entry for previous treating facility
+33 SET DGNAM="DGDARR"
+34 SET DGARR=$QUERY(@DGNAM@(""),-1)
+35 IF DGLTF
IF DGARR]""
Begin DoDot:2
+36 IF $QSUBSCRIPT(DGARR,2)'=DGLTF
Begin DoDot:3
+37 FOR
SET DGARR=$QUERY(@DGARR,-1)
if +$QSUBSCRIPT(DGARR,2)=DGLTF
QUIT
End DoDot:3
+38 SET DGARR=$QUERY(@DGARR,-1)
End DoDot:2
End DoDot:1
+39 ;
+40 QUIT $SELECT($GET(DGARR)]"":+$QSUBSCRIPT(DGARR,2),1:0)
+41 ;
ISDIV(DGSITE) ;is site local division
+1 ;
+2 ; Input:
+3 ; DGSITE - pointer to INSTITUTION (#4) file
+4 ;
+5 ; Output:
+6 ; Function value - 1 on success; 0 on failure
+7 ;
+8 SET DGSITE=+$GET(DGSITE)
+9 QUIT $SELECT($DATA(^DG(40.8,"AD",DGSITE)):1,1:0)
+10 ;
MPIOK(DGDFN,DGICN) ;return national ICN
+1 ;This function verifies that a given patient has a valid national
+2 ;Integration Control Number.
+3 ;
+4 ; Supported DBIA #2701: The supported DBIA is used to access MPI
+5 ; APIs to retrieve ICN and determine if ICN
+6 ; is local.
+7 ;
+8 ; Input:
+9 ; DGDFN - (required) IEN of patient in PATIENT (#2) file
+10 ; DGICN - (optional) passed by reference to contain national ICN
+11 ;
+12 ; Output:
+13 ; Function Value - 1 on valid national ICN;
+14 ; 0 on failure
+15 ; DGICN - Patient's Integrated Control Number
+16 ;
+17 NEW DGRSLT
+18 SET DGRSLT=0
+19 IF $GET(DGDFN)>0
Begin DoDot:1
+20 SET DGICN=$$GETICN^MPIF001(DGDFN)
+21 ;
+22 ;ICN must be valid
+23 if (DGICN'>0)
QUIT
+24 ;
+25 ;ICN must not be local
+26 if $$IFLOCAL^MPIF001(DGDFN)
QUIT
+27 ;
+28 SET DGRSLT=1
End DoDot:1
+29 QUIT DGRSLT
+30 ;
STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
+1 ;
+2 ; Input:
+3 ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
+4 ; HISTORY (#26.14) file in internal or external format
+5 ;
+6 ; Output:
+7 ; Function Value - Status value on success, -1 on failure
+8 ;
+9 ;FM message root
NEW DGERR
+10 ;CHK^DIE result array
NEW DGRSLT
+11 ;calculated status value
NEW DGSTAT
+12 ;
+13 SET DGSTAT=-1
+14 IF $GET(DGACT)]""
Begin DoDot:1
+15 NEW DIERR
+16 IF DGACT?1.N
SET DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
+17 if $DATA(DGERR)
QUIT
+18 DO CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
+19 if $DATA(DGERR)
QUIT
+20 SET DGSTAT=$SELECT(DGRSLT(0)="INACTIVATE":0,DGRSLT(0)="ENTERED IN ERROR":0,DGRSLT(0)="REFRESH INACTIVE":0,1:1)
End DoDot:1
+21 ;. I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
+22 ;. E S DGSTAT=1
+23 ; DG*5.3*1017 using $S and adding "REFRESH INACTIVE" as possible action
+24 QUIT DGSTAT
+25 ;
TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
+1 ;
+2 ; Input:
+3 ; DGFIL - (required) File number
+4 ; DGFLD - (required) Field number or sub-dd#,field#
+5 ; DGVAL - (required) Field value to be validated
+6 ;
+7 ; Output:
+8 ; Function Value - Returns 1 if value is valid, 0 if value is invalid
+9 ;
+10 ;external value after conversion
NEW DGVALEX
+11 ;field type
NEW DGTYP
+12 ;results of CHK^DIE
NEW DGRSLT
+13 ;function results
NEW VALID
+14 ;
+15 SET VALID=1
+16 SET DGFIL=$GET(DGFIL)
SET DGFLD=$GET(DGFLD)
SET DGVAL=$GET(DGVAL)
+17 IF $LENGTH(DGFIL)
IF $LENGTH(DGFLD)
IF $LENGTH(DGVAL)
Begin DoDot:1
+18 NEW DGPFERR,DIERR
+19 SET DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL,"DGPFERR")
+20 IF $DATA(DIERR)
SET VALID=0
QUIT
+21 IF DGVALEX=""
SET VALID=0
QUIT
+22 IF $$GET1(DGFIL,DGFLD,"","TYPE")'["POINTER"
Begin DoDot:2
+23 if '$DATA(DIERR)
DO CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT,"DGFERR")
+24 IF '$DATA(DIERR)
IF DGRSLT="^"
SET VALID=0
+25 QUIT
End DoDot:2
+26 IF $DATA(DIERR)
SET VALID=0
End DoDot:1
+27 QUIT VALID
+28 ;
VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
+1 ;
+2 ; Input:
+3 ; DGRTN - (required) Routine name that contains $TEXT table
+4 ; DGFILE - (required) File number for input values
+5 ; DGIP - (required) Input value array passed by reference
+6 ; DGERR - (optional) Returns error message passed by reference
+7 ;
+8 ; Output:
+9 ; Function Value - Returns 1 on all values valid, 0 on failure
+10 ;
+11 IF $GET(DGRTN)=""!('$GET(DGFILE))
QUIT 0
+12 ;function return value
NEW DGVLD
+13 ;node name to field xref array
NEW DGFXR
+14 ;array of required fields
NEW DGREQ
+15 ;1:word processing;
NEW DGWP
+16 ;array node name
NEW DGN
+17 ;
+18 SET DGVLD=1
+19 SET DGN=""
+20 DO BLDXR(DGRTN,.DGFXR)
+21 ;
+22 FOR
SET DGN=$ORDER(DGFXR(DGN))
if DGN=""
QUIT
Begin DoDot:1
+23 NEW DGPFERR,DIERR
+24 SET DGREQ=$PIECE(DGFXR(DGN),U,2)
+25 SET DGWP=$PIECE(DGFXR(DGN),U,3)
+26 ;required field check
IF DGREQ
Begin DoDot:2
+27 IF DGWP=1
IF '$$CKWP("DGIP(DGN)")
SET DGVLD=0
QUIT
+28 IF 'DGWP
IF $GET(DGIP(DGN))']""
SET DGVLD=0
+29 QUIT
End DoDot:2
+30 IF 'DGVLD
Begin DoDot:2
+31 SET DGERR=$$GET1(DGFILE,+DGFXR(DGN),,"LABEL","REQUIRED")
+32 QUIT
End DoDot:2
QUIT
+33 ;don't check word processing fields for invalid values
if DGWP=1
QUIT
+34 ;check for invalid values
+35 IF '$$TESTVAL(DGFILE,+DGFXR(DGN),$PIECE($GET(DGIP(DGN)),U))
Begin DoDot:2
+36 SET DGVLD=0
SET DGERR=$$GET1(DGFILE,+DGFXR(DGN),,"LABEL","NOT VALID")
End DoDot:2
QUIT
End DoDot:1
if 'DGVLD
QUIT
+37 QUIT DGVLD
+38 ;
BLDXR(DGRTN,DGFLDA) ;build name/field xref array
+1 ;This procedure reads in the text from the XREF line tag of the DGRTN
+2 ;input parameter, loads name/field xref array with parsed line data.
+3 ;
+4 ; Input:
+5 ; DGRTN - (req) Routine name that contains the XREF line tag
+6 ; DGFLDA - (req) Array name for name/field xref passed by reference
+7 ;
+8 ; Output:
+9 ; Function Value - Returns 1 on success, 0 on failure
+10 ; DGFLDA - Name/field xref array
+11 ; format: DGFLDA(subscript)=field#^required?^0/1 where
+12 ; 0:single value field; 1:word proc field
+13 ;
+14 SET DGRTN=$GET(DGRTN)
if DGRTN=""
QUIT
+15 IF $EXTRACT(DGRTN,1)'="^"
SET DGRTN="^"_DGRTN
+16 if ($TEXT(@DGRTN)="")
QUIT
+17 NEW LINE,OFF,REF
+18 ;
+19 FOR OFF=1:1
SET REF="XREF+"_OFF_DGRTN
Begin DoDot:1
+20 NEW NM
SET LINE=$PIECE($TEXT(@REF),";",3,9)
+21 IF $LENGTH(LINE)
SET NM=$PIECE(LINE,";")
SET DGFLDA(NM)=$TRANSLATE($PIECE(LINE,";",2,4),";",U)
+22 QUIT
End DoDot:1
if LINE=""
QUIT
+23 QUIT
