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

DGUTL3.m

Go to the documentation of this file. 
  1. DGUTL3 ;ALB/MTC,CKN - ELIGIBILITY UTILITIES ; 10/4/05 12:22pm
  1.  ;;5.3;Registration;**114,506,653,1015**;Aug 13, 1993;Build 21
  1.  ;
  1.  Q
  1. ELIG(DFN,SOURCE,DEFAULT) ;-- This function will prompt for the eligibility for a patient. If
  1.  ;   only one eligibility then it will be returned without prompting.
  1.  ;
  1.  ;   INPUT:  DFN - Patient
  1.  ;           SOURCE - (1:PTF,2:ADMISSION,3:TRANSFER)
  1.  ;           DEFALUT - IEN from file 8.1
  1.  ;  OUTPUT:  IEN of file 8^Name
  1.  ;
  1.  ;
  1.  N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y
  1.  ;
  1.  ;-- get eligility codes
  1.  D GETEL(DFN)
  1.  S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U)
  1.  I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
  1.  ;
  1.  S RESULT="",EMP=$P(VAEL(1),U,2),ALLEL=U_EMP
  1.  I '$D(VAEL) G ELIGQ
  1.  I $D(VAEL(1))=1 S RESULT=VAEL(1) G ELIGQ
  1.  ;-- if no default set default to primary eligibility
  1.  I DGDEF="" S DGDEF=VAEL(1)
  1.  ;
  1. DISP ;-- display choices
  1.  W !,"THIS PATIENT HAS OTHER ENTITLED ELIGIBILITIES:"
  1.  W !?5,$P(VAEL(1),U,2)
  1.  S X="" F  S X=$O(VAEL(1,X)) Q:X'>0  D
  1.  . W !?5,$P(VAEL(1,X),U,2)
  1.  . S ALLEL=ALLEL_U_$P(VAEL(1,X),U,2)
  1.  ;
  1.  ;-- prompt for eligibility codes
  1.  ;
  1. 1 W !,"ENTER THE ELIGIBILITY FOR THIS "_$S(SOURCE=1:"MOVEMENT",SOURCE=2:"ADMISSION",SOURCE=3:"TRANSFER",1:"PATIENT")_": "_$P(DGDEF,U,2)_"// "
  1.  R X:DTIME
  1.  ;-- if timeout
  1.  G ELIGQ:'$T
  1.  ;-- if ^
  1.  G ELIGQ:X[U
  1.  ;-- if default (primary) quit
  1.  I X="" S RESULT=DGDEF G ELIGQ
  1.  ;-- find eligibility
  1.  S X=$$UPPER^VALM1(X)
  1.  G DISP:X["?",1:ALLEL'[(U_X)
  1.  ;
  1.  S EMP=X_$P($P(ALLEL,U_X,2),U) W $P($P(ALLEL,U_X,2),U)
  1.  I $P(VAEL(1),U,2)=EMP S RESULT=VAEL(1) G ELIGQ
  1.  S X="" F  S X=$O(VAEL(1,X)) Q:X'>0  D
  1.  . I $P(VAEL(1,X),U,2)=EMP S RESULT=X_U_EMP
  1.  ;
  1. ELIGQ ;
  1.  K VAEL
  1.  Q +RESULT
  1.  ;
  1. GETEL(DFN) ;-- This function will get the eligibilities for the patient
  1.  ;  specified by DFN and return all the active eligibilities in the
  1.  ;  ARRAY specified.
  1.  ;
  1.  ;  INPUT:  DFN - Patient
  1.  ;
  1.  D ELIG^VADPT
  1.  Q
  1.  ;
  1. GETDEL(DFN,START,END) ;-- This function will scan the Eligibility Date
  1.  ; Sensitive file #8.3 for all active eligibilities for a date range.
  1.  ;
  1.  N DGI,DGJ,DGK
  1.  ;
  1.  S DGI=0 F  S DGI=$O(^VAEL(8.3,"AE",DFN,DGI)) Q:DGI=""  D
  1.  . S DGJ=$O(^VAEL(8.3,"AE",DFN,DGI,0)),DGK=^(DGJ)
  1.  . I $P(DGK,U,2) S VAEL(1)=DGI_U_$P($G(^DIC(8,DGI,0)),U)
  1.  . I '$P(DGK,U,2) S VAEL(1,DGI)=DGI_U_$P($G(^DIC(8,DGI,0)),U)
  1.  Q
  1.  ;
  1. ASKPR(DFN) ;-- This function will ask the user for the primary eligibility.
  1.  ;
  1.  N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y
  1.  ;
  1.  ;-- get eligility codes
  1.  S DEFAULT=$O(^VAEL(8.3,"AP",DFN,0))
  1.  S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U)
  1.  I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
  1.  ;
  1.  S RESULT=""
  1.  ;
  1. TRY W !,"PRIMARY ELIGIBILITY CODE: "_$P(DGDEF,U,2)_"// "
  1.  R X:DTIME
  1.  ;-- if timeout
  1.  G PRIMQ:'$T
  1.  ;-- if ^
  1.  G PRIMQ:X[U
  1.  ;-- find eligibility
  1.  S X=$$UPPER^VALM1(X)
  1.  ;
  1. PRIMQ ;
  1.  K VAEL
  1.  Q +RESULT
  1.  ;
  1. BADADR(DFN) ;does this patient have a bad address?
  1.  ;
  1.  Q:'$G(DFN) ""
  1.  Q $P($G(^DPT(DFN,.11)),"^",16)
  1.  ;
  1. DELBAI(DFN) ;delete bad address indicator
  1.  N FDA,IENS
  1.  Q:'$G(DFN)
  1.  S IENS=DFN_",",FDA(2,IENS,.121)="@"
  1.  D FILE^DIE("E","FDA")
  1.  Q
  1. GETSHAD(DFN) ;Get current value of Proj 112/SHAD from Patient file.
  1.  ;   Input:  DFN - Patient ien
  1.  ;  Output: Valid values - 1 (Yes), 0 (No), or null
  1.  ;                    -1 - error
  1.  Q:$G(DFN)="" -1 ;Quit with error if missing input parameter
  1.  Q $P($G(^DPT(DFN,.321)),"^",15)