DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
;;5.3;Registration;**425,554,650,1015**;Aug 13, 1993;Build 21
;
;ihs/cmi/maw 08/02/2012 PATCH 1015 check in MPIOK for MPI routines
Q ;no direct entry
;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
;
; Input
; DGDIR0 - DIR(0) string
; DGDIRA - DIR("A") string
; DGDIRB - DIR("B") string
; DGDIRH - DIR("?") string
; DGDIRS - DIR("S") string
;
; Output
; Function Value - Internal value returned from ^DIR or -1 if user
; up-arrows, double up-arrows or the read times out.
;
; 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 DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables
;
S DIR(0)=DGDIR0
S DIR("A")=$G(DGDIRA)
I $G(DGDIRB)]"" S DIR("B")=DGDIRB
I $D(DGDIRH) S DIR("?")=DGDIRH
I $G(DGDIRS)]"" S DIR("S")=DGDIRS
D ^DIR
Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,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)
;
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
; 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 ;word processing flag
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
. S DGREQ=$P(DGFXR(DGN),U,2)
. S DGWP=$P(DGFXR(DGN),U,3)
. I DGREQ D ;required field check
. . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
. . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
. I 'DGVLD D Q
. . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
. Q:DGWP ;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^DID(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 and loads name/field xref array with parsed line data.
;
; Input:
; DGRTN - (required) Routine name that contains the XREF line tag
; DGFLDA - (required) 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?^word proc?
;
S DGRTN=$G(DGRTN)
Q:DGRTN=""
I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
Q:($T(@DGRTN)="")
N DGTAG
N DGOFF
N DGLINE
;
F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE="" D
. S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
Q
;
CKWP(DGROOT) ;ck word processing required fields
;This function verifies that at least one line in the word processing
;array contains text more than one space long.
;
; Input:
; DGROOT - (required) Word processing root
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
;
N DGLIN
N DGRSLT
S DGRSLT=0
I $D(@DGROOT) D
. S DGLIN=""
. F S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN="" D Q:DGRSLT
. . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
Q DGRSLT
;
TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
;
; Input:
; DGFIL - (required) File number
; DGFLD - (required) Field number
; 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
I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
. S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
. I DGVALEX="" S VALID=0 Q
. I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
. . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
Q VALID
;
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
. 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)
. I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
. E S DGSTAT=1
Q DGSTAT
;
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
;
I '$T(GETICN^MPIF001) Q 1 ;ihs/cmi/maw 08/02/2012 PATCH 1015 not using ICN at all sites yet
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
;
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)
DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
+1 ;;5.3;Registration;**425,554,650,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;ihs/cmi/maw 08/02/2012 PATCH 1015 check in MPIOK for MPI routines
+4 ;no direct entry
QUIT
+5 ;
ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
+1 ;
+2 ; Input
+3 ; DGDIR0 - DIR(0) string
+4 ; DGDIRA - DIR("A") string
+5 ; DGDIRB - DIR("B") string
+6 ; DGDIRH - DIR("?") string
+7 ; DGDIRS - DIR("S") string
+8 ;
+9 ; Output
+10 ; Function Value - Internal value returned from ^DIR or -1 if user
+11 ; up-arrows, double up-arrows or the read times out.
+12 ;
+13 ; DIR(0) type Results
+14 ; ------------ -------------------------------
+15 ; DD IEN of selected entry
+16 ; Pointer IEN of selected entry
+17 ; Set of Codes Internal value of code
+18 ; Yes/No 0 for No, 1 for Yes
+19 ;
+20 ;^DIR variables
NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+21 ;
+22 SET DIR(0)=DGDIR0
+23 SET DIR("A")=$GET(DGDIRA)
+24 IF $GET(DGDIRB)]""
SET DIR("B")=DGDIRB
+25 IF $DATA(DGDIRH)
SET DIR("?")=DGDIRH
+26 IF $GET(DGDIRS)]""
SET DIR("S")=DGDIRS
+27 DO ^DIR
+28 QUIT $SELECT($DATA(DUOUT):-1,$DATA(DTOUT):-1,$DATA(DIROUT):-1,X="@":"@",1:$PIECE(Y,U))
+29 ;
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 ;
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
+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 ;word processing flag
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 SET DGREQ=$PIECE(DGFXR(DGN),U,2)
+24 SET DGWP=$PIECE(DGFXR(DGN),U,3)
+25 ;required field check
IF DGREQ
Begin DoDot:2
+26 IF DGWP
IF '$$CKWP("DGIP(DGN)")
SET DGVLD=0
QUIT
+27 IF 'DGWP
IF $GET(DGIP(DGN))']""
SET DGVLD=0
QUIT
End DoDot:2
+28 IF 'DGVLD
Begin DoDot:2
+29 SET DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
End DoDot:2
QUIT
+30 ;don't check word processing fields for invalid values
IF DGWP
QUIT
+31 ;check for invalid values
+32 IF '$$TESTVAL(DGFILE,+DGFXR(DGN),$PIECE($GET(DGIP(DGN)),U))
Begin DoDot:2
+33 SET DGVLD=0
SET DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
End DoDot:2
QUIT
End DoDot:1
IF 'DGVLD
QUIT
+34 QUIT DGVLD
+35 ;
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 and loads name/field xref array with parsed line data.
+3 ;
+4 ; Input:
+5 ; DGRTN - (required) Routine name that contains the XREF line tag
+6 ; DGFLDA - (required) Array name for name/field xref passed by
+7 ; reference
+8 ;
+9 ; Output:
+10 ; Function Value - Returns 1 on success, 0 on failure
+11 ; DGFLDA - Name/field xref array
+12 ; format: DGFLDA(subscript)=field#^required?^word proc?
+13 ;
+14 SET DGRTN=$GET(DGRTN)
+15 IF DGRTN=""
QUIT
+16 IF $EXTRACT(DGRTN,1)'="^"
SET DGRTN="^"_DGRTN
+17 IF ($TEXT(@DGRTN)="")
QUIT
+18 NEW DGTAG
+19 NEW DGOFF
+20 NEW DGLINE
+21 ;
+22 FOR DGOFF=1:1
SET DGTAG="XREF+"_DGOFF_DGRTN
SET DGLINE=$TEXT(@DGTAG)
IF DGLINE=""
QUIT
Begin DoDot:1
+23 SET DGFLDA($PIECE(DGLINE,";",3))=$PIECE(DGLINE,";",4)_U_+$PIECE(DGLINE,";",5)_U_+$PIECE(DGLINE,";",6)
End DoDot:1
+24 QUIT
+25 ;
CKWP(DGROOT) ;ck word processing required fields
+1 ;This function verifies that at least one line in the word processing
+2 ;array contains text more than one space long.
+3 ;
+4 ; Input:
+5 ; DGROOT - (required) Word processing root
+6 ;
+7 ; Output:
+8 ; Function Value - Returns 1 on success, 0 on failure
+9 ;
+10 NEW DGLIN
+11 NEW DGRSLT
+12 SET DGRSLT=0
+13 IF $DATA(@DGROOT)
Begin DoDot:1
+14 SET DGLIN=""
+15 FOR
SET DGLIN=$ORDER(@DGROOT@(DGLIN))
IF DGLIN=""
QUIT
Begin DoDot:2
+16 IF $GET(@DGROOT@(DGLIN,0))]""
IF @DGROOT@(DGLIN,0)'=" "
SET DGRSLT=1
End DoDot:2
IF DGRSLT
QUIT
End DoDot:1
+17 QUIT DGRSLT
+18 ;
TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
+1 ;
+2 ; Input:
+3 ; DGFIL - (required) File number
+4 ; DGFLD - (required) Field number
+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 IF $GET(DGFIL)>0
IF ($GET(DGFLD)>0)
IF ($GET(DGVAL)'="")
Begin DoDot:1
+17 SET DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
+18 IF DGVALEX=""
SET VALID=0
QUIT
+19 IF $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER"
Begin DoDot:2
+20 DO CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT)
IF DGRSLT="^"
SET VALID=0
QUIT
End DoDot:2
End DoDot:1
+21 QUIT VALID
+22 ;
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 IF DGACT?1.N
SET DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
+16 IF $DATA(DGERR)
QUIT
+17 DO CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
+18 IF $DATA(DGERR)
QUIT
+19 IF DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR")
SET DGSTAT=0
+20 IF '$TEST
SET DGSTAT=1
End DoDot:1
+21 QUIT DGSTAT
+22 ;
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 ;ihs/cmi/maw 08/02/2012 PATCH 1015 not using ICN at all sites yet
IF '$TEXT(GETICN^MPIF001)
QUIT 1
+18 NEW DGRSLT
+19 SET DGRSLT=0
+20 IF $GET(DGDFN)>0
Begin DoDot:1
+21 SET DGICN=$$GETICN^MPIF001(DGDFN)
+22 ;
+23 ;ICN must be valid
+24 IF (DGICN'>0)
QUIT
+25 ;
+26 ;ICN must not be local
+27 IF $$IFLOCAL^MPIF001(DGDFN)
QUIT
+28 ;
+29 SET DGRSLT=1
End DoDot:1
+30 QUIT DGRSLT
+31 ;
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)
