source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGUTL3.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1DGUTL3 ;ALB/MTC,CKN - ELIGIBILITY UTILITIES ; 10/4/05 12:22pm
2 ;;5.3;Registration;**114,506,653**;Aug 13, 1993;Build 2
3 ;
4 Q
5ELIG(DFN,SOURCE,DEFAULT) ;-- This function will prompt for the eligibility for a patient. If
6 ; only one eligibility then it will be returned without prompting.
7 ;
8 ; INPUT: DFN - Patient
9 ; SOURCE - (1:PTF,2:ADMISSION,3:TRANSFER)
10 ; DEFALUT - IEN from file 8.1
11 ; OUTPUT: IEN of file 8^Name
12 ;
13 ;
14 N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y
15 ;
16 ;-- get eligility codes
17 D GETEL(DFN)
18 S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U)
19 I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
20 ;
21 S RESULT="",EMP=$P(VAEL(1),U,2),ALLEL=U_EMP
22 I '$D(VAEL) G ELIGQ
23 I $D(VAEL(1))=1 S RESULT=VAEL(1) G ELIGQ
24 ;-- if no default set default to primary eligibility
25 I DGDEF="" S DGDEF=VAEL(1)
26 ;
27DISP ;-- display choices
28 W !,"THIS PATIENT HAS OTHER ENTITLED ELIGIBILITIES:"
29 W !?5,$P(VAEL(1),U,2)
30 S X="" F S X=$O(VAEL(1,X)) Q:X'>0 D
31 . W !?5,$P(VAEL(1,X),U,2)
32 . S ALLEL=ALLEL_U_$P(VAEL(1,X),U,2)
33 ;
34 ;-- prompt for eligibility codes
35 ;
361 W !,"ENTER THE ELIGIBILITY FOR THIS "_$S(SOURCE=1:"MOVEMENT",SOURCE=2:"ADMISSION",SOURCE=3:"TRANSFER",1:"PATIENT")_": "_$P(DGDEF,U,2)_"// "
37 R X:DTIME
38 ;-- if timeout
39 G ELIGQ:'$T
40 ;-- if ^
41 G ELIGQ:X[U
42 ;-- if default (primary) quit
43 I X="" S RESULT=DGDEF G ELIGQ
44 ;-- find eligibility
45 S X=$$UPPER^VALM1(X)
46 G DISP:X["?",1:ALLEL'[(U_X)
47 ;
48 S EMP=X_$P($P(ALLEL,U_X,2),U) W $P($P(ALLEL,U_X,2),U)
49 I $P(VAEL(1),U,2)=EMP S RESULT=VAEL(1) G ELIGQ
50 S X="" F S X=$O(VAEL(1,X)) Q:X'>0 D
51 . I $P(VAEL(1,X),U,2)=EMP S RESULT=X_U_EMP
52 ;
53ELIGQ ;
54 K VAEL
55 Q +RESULT
56 ;
57GETEL(DFN) ;-- This function will get the eligibilities for the patient
58 ; specified by DFN and return all the active eligibilities in the
59 ; ARRAY specified.
60 ;
61 ; INPUT: DFN - Patient
62 ;
63 D ELIG^VADPT
64 Q
65 ;
66GETDEL(DFN,START,END) ;-- This function will scan the Eligibility Date
67 ; Sensitive file #8.3 for all active eligibilities for a date range.
68 ;
69 N DGI,DGJ,DGK
70 ;
71 S DGI=0 F S DGI=$O(^VAEL(8.3,"AE",DFN,DGI)) Q:DGI="" D
72 . S DGJ=$O(^VAEL(8.3,"AE",DFN,DGI,0)),DGK=^(DGJ)
73 . I $P(DGK,U,2) S VAEL(1)=DGI_U_$P($G(^DIC(8,DGI,0)),U)
74 . I '$P(DGK,U,2) S VAEL(1,DGI)=DGI_U_$P($G(^DIC(8,DGI,0)),U)
75 Q
76 ;
77ASKPR(DFN) ;-- This function will ask the user for the primary eligibility.
78 ;
79 N RESULT,VAEL,ALLEL,EMP,X,DGDEF,Y
80 ;
81 ;-- get eligility codes
82 S DEFAULT=$O(^VAEL(8.3,"AP",DFN,0))
83 S DGDEF=$P($G(^DIC(8,+$G(DEFAULT),0)),U)
84 I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
85 ;
86 S RESULT=""
87 ;
88TRY W !,"PRIMARY ELIGIBILITY CODE: "_$P(DGDEF,U,2)_"// "
89 R X:DTIME
90 ;-- if timeout
91 G PRIMQ:'$T
92 ;-- if ^
93 G PRIMQ:X[U
94 ;-- find eligibility
95 S X=$$UPPER^VALM1(X)
96 ;
97PRIMQ ;
98 K VAEL
99 Q +RESULT
100 ;
101BADADR(DFN) ;does this patient have a bad address?
102 ;
103 Q:'$G(DFN) ""
104 Q $P($G(^DPT(DFN,.11)),"^",16)
105 ;
106DELBAI(DFN) ;delete bad address indicator
107 N FDA,IENS
108 Q:'$G(DFN)
109 S IENS=DFN_",",FDA(2,IENS,.121)="@"
110 D FILE^DIE("E","FDA")
111 Q
112GETSHAD(DFN) ;Get current value of Proj 112/SHAD from Patient file.
113 ; Input: DFN - Patient ien
114 ; Output: Valid values - 1 (Yes), 0 (No), or null
115 ; -1 - error
116 Q:$G(DFN)="" -1 ;Quit with error if missing input parameter
117 Q $P($G(^DPT(DFN,.321)),"^",15)
Note: See TracBrowser for help on using the repository browser.