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