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

DGPFUT.m

Go to the documentation of this file.
  1. DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
  1. ;;5.3;Registration;**425,554,650,1015**;Aug 13, 1993;Build 21
  1. ;
  1. ;ihs/cmi/maw 08/02/2012 PATCH 1015 check in MPIOK for MPI routines
  1. Q ;no direct entry
  1. ;
  1. ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
  1. ;
  1. ; Input
  1. ; DGDIR0 - DIR(0) string
  1. ; DGDIRA - DIR("A") string
  1. ; DGDIRB - DIR("B") string
  1. ; DGDIRH - DIR("?") string
  1. ; DGDIRS - DIR("S") string
  1. ;
  1. ; Output
  1. ; Function Value - Internal value returned from ^DIR or -1 if user
  1. ; up-arrows, double up-arrows or the read times out.
  1. ;
  1. ; DIR(0) type Results
  1. ; ------------ -------------------------------
  1. ; DD IEN of selected entry
  1. ; Pointer IEN of selected entry
  1. ; Set of Codes Internal value of code
  1. ; Yes/No 0 for No, 1 for Yes
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables
  1. ;
  1. S DIR(0)=DGDIR0
  1. S DIR("A")=$G(DGDIRA)
  1. I $G(DGDIRB)]"" S DIR("B")=DGDIRB
  1. I $D(DGDIRH) S DIR("?")=DGDIRH
  1. I $G(DGDIRS)]"" S DIR("S")=DGDIRS
  1. D ^DIR
  1. Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
  1. ;
  1. CONTINUE() ;pause display
  1. ;
  1. ; Input: none
  1. ;
  1. ; Output: 1 - continue
  1. ; 0 - quit
  1. ;
  1. N DIR,Y
  1. S DIR(0)="E" D ^DIR
  1. Q $S(Y'=1:0,1:1)
  1. ;
  1. VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
  1. ;
  1. ; Input:
  1. ; DGRTN - (required) Routine name that contains $TEXT table
  1. ; DGFILE - (required) File number for input values
  1. ; DGIP - (required) Input value array
  1. ; DGERR - (optional) Returns error message passed by reference
  1. ;
  1. ; Output:
  1. ; Function Value - Returns 1 on all values valid, 0 on failure
  1. ;
  1. I $G(DGRTN)=""!('$G(DGFILE)) Q 0
  1. N DGVLD ;function return value
  1. N DGFXR ;node name to field xref array
  1. N DGREQ ;array of required fields
  1. N DGWP ;word processing flag
  1. N DGN ;array node name
  1. ;
  1. S DGVLD=1
  1. S DGN=""
  1. D BLDXR(DGRTN,.DGFXR)
  1. ;
  1. F S DGN=$O(DGFXR(DGN)) Q:DGN="" D Q:'DGVLD
  1. . S DGREQ=$P(DGFXR(DGN),U,2)
  1. . S DGWP=$P(DGFXR(DGN),U,3)
  1. . I DGREQ D ;required field check
  1. . . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
  1. . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
  1. . I 'DGVLD D Q
  1. . . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
  1. . Q:DGWP ;don't check word processing fields for invalid values
  1. . ;check for invalid values
  1. . I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D Q
  1. . . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
  1. Q DGVLD
  1. ;
  1. BLDXR(DGRTN,DGFLDA) ;build name/field xref array
  1. ;This procedure reads in the text from the XREF line tag of the DGRTN
  1. ;input parameter and loads name/field xref array with parsed line data.
  1. ;
  1. ; Input:
  1. ; DGRTN - (required) Routine name that contains the XREF line tag
  1. ; DGFLDA - (required) Array name for name/field xref passed by
  1. ; reference
  1. ;
  1. ; Output:
  1. ; Function Value - Returns 1 on success, 0 on failure
  1. ; DGFLDA - Name/field xref array
  1. ; format: DGFLDA(subscript)=field#^required?^word proc?
  1. ;
  1. S DGRTN=$G(DGRTN)
  1. Q:DGRTN=""
  1. I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
  1. Q:($T(@DGRTN)="")
  1. N DGTAG
  1. N DGOFF
  1. N DGLINE
  1. ;
  1. F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE="" D
  1. . S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
  1. Q
  1. ;
  1. CKWP(DGROOT) ;ck word processing required fields
  1. ;This function verifies that at least one line in the word processing
  1. ;array contains text more than one space long.
  1. ;
  1. ; Input:
  1. ; DGROOT - (required) Word processing root
  1. ;
  1. ; Output:
  1. ; Function Value - Returns 1 on success, 0 on failure
  1. ;
  1. N DGLIN
  1. N DGRSLT
  1. S DGRSLT=0
  1. I $D(@DGROOT) D
  1. . S DGLIN=""
  1. . F S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN="" D Q:DGRSLT
  1. . . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
  1. Q DGRSLT
  1. ;
  1. TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
  1. ;
  1. ; Input:
  1. ; DGFIL - (required) File number
  1. ; DGFLD - (required) Field number
  1. ; DGVAL - (required) Field value to be validated
  1. ;
  1. ; Output:
  1. ; Function Value - Returns 1 if value is valid, 0 if value is invalid
  1. ;
  1. N DGVALEX ;external value after conversion
  1. N DGTYP ;field type
  1. N DGRSLT ;results of CHK^DIE
  1. N VALID ;function results
  1. ;
  1. S VALID=1
  1. I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
  1. . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
  1. . I DGVALEX="" S VALID=0 Q
  1. . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
  1. . . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
  1. Q VALID
  1. ;
  1. STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
  1. ;
  1. ; Input:
  1. ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
  1. ; HISTORY (#26.14) file in internal or external format
  1. ;
  1. ; Output:
  1. ; Function Value - Status value on success, -1 on failure
  1. ;
  1. N DGERR ;FM message root
  1. N DGRSLT ;CHK^DIE result array
  1. N DGSTAT ;calculated status value
  1. ;
  1. S DGSTAT=-1
  1. I $G(DGACT)]"" D
  1. . I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
  1. . Q:$D(DGERR)
  1. . D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
  1. . Q:$D(DGERR)
  1. . I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
  1. . E S DGSTAT=1
  1. Q DGSTAT
  1. ;
  1. MPIOK(DGDFN,DGICN) ;return national ICN
  1. ;This function verifies that a given patient has a valid national
  1. ;Integration Control Number.
  1. ;
  1. ; Supported DBIA #2701: The supported DBIA is used to access MPI
  1. ; APIs to retrieve ICN and determine if ICN
  1. ; is local.
  1. ;
  1. ; Input:
  1. ; DGDFN - (required) IEN of patient in PATIENT (#2) file
  1. ; DGICN - (optional) passed by reference to contain national ICN
  1. ;
  1. ; Output:
  1. ; Function Value - 1 on valid national ICN;
  1. ; 0 on failure
  1. ; DGICN - Patient's Integrated Control Number
  1. ;
  1. I '$T(GETICN^MPIF001) Q 1 ;ihs/cmi/maw 08/02/2012 PATCH 1015 not using ICN at all sites yet
  1. N DGRSLT
  1. S DGRSLT=0
  1. I $G(DGDFN)>0 D
  1. . S DGICN=$$GETICN^MPIF001(DGDFN)
  1. . ;
  1. . ;ICN must be valid
  1. . Q:(DGICN'>0)
  1. . ;
  1. . ;ICN must not be local
  1. . Q:$$IFLOCAL^MPIF001(DGDFN)
  1. . ;
  1. . S DGRSLT=1
  1. Q DGRSLT
  1. ;
  1. GETNXTF(DGDFN,DGLTF) ;get previous treating facility
  1. ;This function will return the treating facility with a DATE LAST
  1. ;TREATED value immediately prior to the date for the treating facility
  1. ;passed as the second parameter. The most recent treating facility
  1. ;will be returned when the second parameter is missing, null, or zero.
  1. ;
  1. ; Input:
  1. ; DGDFN - pointer to patient in PATIENT (#2) file
  1. ; DGLTF - (optional) last treating facility [default=0]
  1. ;
  1. ; Output:
  1. ; Function value - previous facility as a pointer to INSTITUTION (#4)
  1. ; file on success; 0 on failure
  1. ;
  1. N DGARR ;fully subscripted array node
  1. N DGDARR ;date sorted treating facilities
  1. N DGINST ;institution pointer
  1. N DGNAM ;name of sorted treating facilities array
  1. N DGTFARR ;array of non-local treating facilities
  1. ;
  1. ;
  1. I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
  1. . ;
  1. . ;validate last treating facility input parameter
  1. . S DGLTF=+$G(DGLTF)
  1. . S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
  1. . ;
  1. . ;build date sorted list
  1. . S DGINST=0
  1. . F S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST D
  1. . . S DGDARR(DGTFARR(DGINST),DGINST)=""
  1. . ;
  1. . ;find entry for previous treating facility
  1. . S DGNAM="DGDARR"
  1. . S DGARR=$QUERY(@DGNAM@(""),-1)
  1. . I DGLTF,DGARR]"" D
  1. . . I $QS(DGARR,2)'=DGLTF D
  1. . . . F S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
  1. . . S DGARR=$QUERY(@DGARR,-1)
  1. ;
  1. Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
  1. ;
  1. ISDIV(DGSITE) ;is site local division
  1. ;
  1. ; Input:
  1. ; DGSITE - pointer to INSTITUTION (#4) file
  1. ;
  1. ; Output:
  1. ; Function value - 1 on success; 0 on failure
  1. ;
  1. S DGSITE=+$G(DGSITE)
  1. Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)