DGPFUT	;ALB/RPM - PRF UTILITIES ;7:46 PM  30 Jan 2008
	;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08;Build 4
	;
	;Modified from FOIA VISTA,
	;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
	;General Public License See attached copy of the License.
	;
	;This program is free software; you can redistribute it and/or modify
	;it under the terms of the GNU General Public License as published by
	;the Free Software Foundation; either version 2 of the License, or
	;(at your option) any later version.
	;
	;This program is distributed in the hope that it will be useful,
	;but WITHOUT ANY WARRANTY; without even the implied warranty of
	;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	;GNU General Public License for more details.
	;
	;You should have received a copy of the GNU General Public License along
	;with this program; if not, write to the Free Software Foundation, Inc.,
	;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
	;
	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
	;
	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"
	. ;
	. ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
	. ;
	. ;S DGARR=$QUERY(@DGNAM@(""),-1)
	. S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
	. ;
	. ;END CHANGE
	. ;
	. I DGLTF,DGARR]"" D
	. . I $QS(DGARR,2)'=DGLTF D
	. . . ;
	. . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
	. . . ;
	. . . ;F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
	. . . F  S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
	. . . ;
	. . . ;END CHANGE
	. . . ;
	. . ;
	. . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
	. . ;
	. . ;S DGARR=$QUERY(@DGARR,-1)
	. . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
	. . ;
	. . ;END CHANGE
	. . ;
	;
	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)
