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,951,1017**;Aug 13, 1993;Build 1
  1.  ;     Last Edited: SHRPE/sgm - Sep 26, 2018 16:46
  1.  ;
  1.  ; ICR# TYPE DESCRIPTION
  1.  ;----- ---- ------------------------------
  1.  ;10026 Sup  ^DIR
  1.  ; 2052 Sup  $$GET1^DID
  1.  ; 2053 Sup  CHK^DIE
  1.  ; 2055 Sup  $$EXTERNAL^DILFD
  1.  ; 2701 Sup  ^MPIF001: $$GETICN, $$IFLOCAL
  1.  ;
  1.  Q   ;no direct entry
  1.  ;
  1. ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS,DIRX) ;
  1.  ; Wrap FileMan Classic Reader call
  1.  ; Input
  1.  ;    DGDIR0 - DIR(0) string
  1.  ;    DGDIRA - DIR("A") string (may be passed by reference [dg*951])
  1.  ;    DGDIRB - DIR("B") string
  1.  ;    DGDIRH - DIR("?") string (may be passed by reference [dg*951])
  1.  ;    DGDIRS - DIR("S") string
  1.  ;     .DIRX - [optional] - multi-function - DG*5.3*951
  1.  ;         a) you may pass .DIR() instead of individual variables
  1.  ;         b) if DIRX=-2 you wish this API to return -2 upon time-out
  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.  ;                    DG*5.3*951, if .DIRX is passed then upon time out
  1.  ;                       return -2
  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 X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1.  I $D(DIRX),$G(DIRX)'=-2 M DIR=DIRX
  1.  E  D
  1.  . S DIR(0)=DGDIR0
  1.  . S DIR("A")=$G(DGDIRA)
  1.  . I $D(DGDIRA)>9 M DIR("A")=DGDIRA("A")
  1.  . I $G(DGDIRB)]"" S DIR("B")=DGDIRB
  1.  . I $D(DGDIRH) S DIR("?")=DGDIRH
  1.  . I $D(DGDIRH)>9 M DIR("?")=DGDIRH
  1.  . I $G(DGDIRS)]"" S DIR("S")=DGDIRS
  1.  . Q
  1.  D ^DIR
  1.  ; DG*5.3*951 - original code did not distinguish between time-out
  1.  ; and "^"-out and just pressing ENTER.
  1.  I $D(DIRX) D  Q Z
  1.  . S Z=$S($D(DTOUT):-2,$D(DUOUT):-1,$D(DIROUT):-1,1:"")
  1.  . I Z="" S Z=$S(Y=-1:"",X="@":"@",1:$P(Y,U))
  1.  . Q
  1.  I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
  1.  Q $S(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. CKWP(DGROOT,DGTX) ;  ck word processing required fields
  1.  ;;Text did not have a minimum of 3 consecutive alpha characters
  1.  ;;Text contained TAB characters
  1.  ;;Text contained control characters
  1.  ;;Each <TAB> character was replaced with a single <space> character
  1.  ;;
  1.  ; rewritten in DG*5.3*951
  1.  ; Require a minimum of 3 alpha characters, no control codes
  1.  ; INPUT PARAMETERS:
  1.  ;   .DGROOT(n,0) = (required) text
  1.  ;   .DGTX(n)     = (optional) return additional text for calling
  1.  ;                   program to display
  1.  ;
  1.  ; EXTRINSIC FUNCTION returns:
  1.  ;     1:text is good, 0:text is not acceptable
  1.  ;
  1.  N X,Y,ALPHA,LINE,STR,NOCTRL,NOTAB,TEMP
  1.  S (ALPHA,LINE)=0,(NOCTRL,NOTAB)=1,STR=""
  1.  I $D(@DGROOT) D
  1.  . N I,X S I=0 F  S I=$O(@DGROOT@(I)) Q:I=""  S X=@DGROOT@(I,0) D
  1.  . . I 'ALPHA S STR=STR_X_" "
  1.  . . I 'ALPHA,STR?.E3A.E S ALPHA=1
  1.  . . I NOTAB,X[$C(9) S NOTAB=0
  1.  . . S X=$TR(X,$C(9))
  1.  . . I NOCTRL,X?.E1C.E S NOCTRL=0
  1.  . . Q
  1.  . Q
  1.  ;
  1.  I 'ALPHA S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+1),";"," ")
  1.  I 'NOTAB S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+2),";"," ")
  1.  I 'NOCTRL S LINE=LINE+1,DGTX(LINE)=$TR($T(CKWP+3),";"," ")
  1.  Q $D(DGTX)=0
  1.  ;
  1. DIQ(FILE,XDA,FLD) ;   retrieve single value from record; DG*5.3*951
  1.  N X,DGERR,DGWP,DIERR
  1.  S FILE=+$G(FILE) I FILE<2 Q ""
  1.  S FLD=$G(FLD) I '$L(FLD) Q ""
  1.  S XDA=$G(XDA) I 'XDA Q ""
  1.  I $E(XDA,$L(XDA))'="," S XDA=XDA_","
  1.  S X=$$GET1^DIQ(FILE,XDA,FLD,.DGWP,,"DGERR")
  1.  S:$D(DIERR) X=-1
  1.  Q X
  1.  ;
  1. GET1(FILE,FLD,FLG,ATT,PAD) ; call $$GET1^DID ; dg*951
  1.  N X,DGPFERR,DIERR,MSG
  1.  S MSG="Unexpected error encountered"
  1.  I '$G(FILE) Q MSG
  1.  I '$L($G(FLD)) Q MSG
  1.  I '$L($G(ATT)) Q MSG
  1.  S FLG=$G(FLG),PAD=$G(PAD)
  1.  S X=$$GET1^DID(FILE,FLD,FLG,ATT,,"DGPFERR")
  1.  I $D(DIERR) Q MSG
  1.  S:$L(PAD) X=X_" "_PAD
  1.  Q X
  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)
  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.  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. 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.  . N DIERR
  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.  . S DGSTAT=$S(DGRSLT(0)="INACTIVATE":0,DGRSLT(0)="ENTERED IN ERROR":0,DGRSLT(0)="REFRESH INACTIVE":0,1:1)
  1.  ;. I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
  1.  ;. E  S DGSTAT=1
  1.  ; DG*5.3*1017 using $S and adding "REFRESH INACTIVE" as possible action
  1.  Q DGSTAT
  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 or sub-dd#,field#
  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.  S DGFIL=$G(DGFIL),DGFLD=$G(DGFLD),DGVAL=$G(DGVAL)
  1.  I $L(DGFIL),$L(DGFLD),$L(DGVAL) D
  1.  . N DGPFERR,DIERR
  1.  . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL,"DGPFERR")
  1.  . I $D(DIERR) S VALID=0 Q
  1.  . I DGVALEX="" S VALID=0 Q
  1.  . I $$GET1(DGFIL,DGFLD,"","TYPE")'["POINTER" D
  1.  . . D:'$D(DIERR) CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT,"DGFERR")
  1.  . . I '$D(DIERR),DGRSLT="^" S VALID=0
  1.  . . Q
  1.  . I $D(DIERR) S VALID=0
  1.  Q VALID
  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 passed by reference
  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    ;1:word processing;
  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.  . N DGPFERR,DIERR
  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=1,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
  1.  . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0
  1.  . . Q
  1.  . I 'DGVLD D  Q
  1.  . . S DGERR=$$GET1(DGFILE,+DGFXR(DGN),,"LABEL","REQUIRED")
  1.  . . Q
  1.  . Q:DGWP=1  ;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(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, loads name/field xref array with parsed line data.
  1.  ;
  1.  ;  Input:
  1.  ;    DGRTN - (req) Routine name that contains the XREF line tag
  1.  ;   DGFLDA - (req) Array name for name/field xref passed by 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?^0/1 where
  1.  ;            0:single value field; 1:word proc field
  1.  ;
  1.  S DGRTN=$G(DGRTN) Q:DGRTN=""
  1.  I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
  1.  Q:($T(@DGRTN)="")
  1.  N LINE,OFF,REF
  1.  ;
  1.  F OFF=1:1 S REF="XREF+"_OFF_DGRTN D  Q:LINE=""
  1.  . N NM S LINE=$P($T(@REF),";",3,9)
  1.  . I $L(LINE) S NM=$P(LINE,";"),DGFLDA(NM)=$TR($P(LINE,";",2,4),";",U)
  1.  . Q
  1.  Q