source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENU.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN - Enrollment Utilities; 04/24/2006 9:20 AM
2 ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653**;Aug 13,1993;Build 2
3 ;
4DISPLAY(DFN) ;
5 ;Description: Display status message, current enrollment and
6 ; preferred facility information
7 ;Input:
8 ; DFN - Patient IEN
9 ; Output: none
10 ;
11 N STATUS
12 S STATUS=$$STATUS^DGENA(DFN)
13 I 'STATUS W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
14 E I STATUS=2 D
15 .W !!,"Patient is enrolled in the VA Patient Enrollment System..."
16 ; Purple Heart added status 21
17 E I (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) D
18 .W !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
19 E D
20 .W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
21 D CUR(DFN)
22 Q
23 ;
24CUR(DFN) ;
25 ;Description - displays current enrollment, category, enrollment group threshold, and preferred facility
26 ;
27 N FACNAME,PREFAC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
28 I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
29 ;Get enrollment category
30 S DGENCAT=$$CATEGORY^DGENA4(DFN)
31 ;Display Category in reverse video
32 D REV
33 ;Get enrollment group threshold
34 S DGEGTIEN=$$FINDCUR^DGENEGT
35 S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
36 ;Preferred facility
37 S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
38 W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
39 W !?3,"Enrollment Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
40 W !?3,IORVON,"Enrollment Category : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
41 W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
42 W !?3,"Enrollment Priority",?35,": ",$S($G(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
43 W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-")
44 W !?3,"Enrollment Group Threshold",?35,": ",$S($G(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$G(DGEGT("PRIORITY")))),$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$G(DGEGT("SUBGRP"))))
45 W !
46 Q
47REV ;Get variables to display text in reverse video
48 N X
49 S X="IORVON;IORVOFF"
50 D ENDR^%ZISS
51 Q
52PATID(DFN) ;
53 ;Description - Called by FileMan as an identifier for the Patient file.
54 ;Displays current enrollment status, priority, and preferred facility.
55 ;
56 ;Input:
57 ; DFN - ien to Patient file
58 ;
59 N PREFAC,DGENR,OUTPUT
60 I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D
61 .S OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
62 E D
63 .S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_" ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_" ",1,26)
64 S PREFAC=$$PREF^DGENPTA(DFN)
65 S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^")
66 I $G(IOM) I ($X#$G(IOM))<6 D
67 .D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
68 E D
69 .D EN^DDIOL(OUTPUT,,"!?10")
70 Q
71 ;
72EXT(SUB,VAL) ;
73 ;Description: Given the subscript used in the PATIENT ENROLLMENT array,
74 ; and a field value, returns the external representation of the
75 ; value, as defined in the fields output transform of the PATIENT
76 ; ENROLLMENT file.
77 ;Input:
78 ; SUB - subscript in the array defined by the PATIENT ENROLLMENT object
79 ; VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
80 ;Output:
81 ; Function Value - returns the external value of the attribute as
82 ; defined by the PATIENT ENROLLMENT file
83 ;
84 Q:(($G(SUB)="")!($G(VAL)="")) ""
85 ;
86 N FLD
87 S FLD=$$FIELD(SUB)
88 ;
89 Q:(FLD="") ""
90 Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
91 ;
92FIELD(SUB) ;
93 ;Description: given a subscript in the enrollment array, returns the
94 ; corresponding field number
95 N FLD S FLD=""
96 D ;drops out of block once SUB is determined
97 .I SUB="APP" S FLD=.01 Q
98 .I SUB="DATE" S FLD=.1 Q
99 .I SUB="END" S FLD=.11 Q
100 .I SUB="DFN" S FLD=.02 Q
101 .I SUB="SOURCE" S FLD=.03 Q
102 .I SUB="STATUS" S FLD=.04 Q
103 .I SUB="REASON" S FLD=.05 Q
104 .I SUB="REMARKS" S FLD=25 Q
105 .I SUB="FACREC" S FLD=.06 Q
106 .I SUB="PRIORITY" S FLD=.07 Q
107 .I SUB="EFFDATE" S FLD=.08 Q
108 .I SUB="PRIORREC" S FLD=.09 Q
109 .I SUB="SUBGRP" S FLD=.12 Q
110 .I SUB="CODE" S FLD=50.01 Q
111 .I SUB="SC" S FLD=50.02 Q
112 .I SUB="SCPER" S FLD=50.03 Q
113 .I SUB="POW" S FLD=50.04 Q
114 .I SUB="A&A" S FLD=50.05 Q
115 .I SUB="HB" S FLD=50.06 Q
116 .I SUB="VAPEN" S FLD=50.07 Q
117 .I SUB="VACKAMT" S FLD=50.08 Q
118 .I SUB="DISRET" S FLD=50.09 Q
119 .I SUB="DISLOD" S FLD=50.2 Q ;field added with DG*5.3*672
120 .I SUB="MEDICAID" S FLD=50.1 Q
121 .I SUB="AO" S FLD=50.11 Q
122 .I SUB="IR" S FLD=50.12 Q
123 .I SUB="EC" S FLD=50.13 Q
124 .I SUB="MTSTA" S FLD=50.14 Q
125 .I SUB="VCD" S FLD=50.15 Q
126 .I SUB="PH" S FLD=50.16 Q
127 .I SUB="UNEMPLOY" S FLD=50.17 Q
128 .I SUB="CVELEDT" S FLD=50.18 Q
129 .I SUB="SHAD" S FLD=50.19 Q ;field added with DG*5.3*653
130 .I SUB="DATETIME" S FLD=75.01 Q
131 .I SUB="USER" S FLD=75.02 Q
132 .I SUB="RADEXPM" S FLD=76 Q
133 Q FLD
134 ;
135PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
136 ;Description: requests user to enter a single field value.
137 ;Input:
138 ; FILE - the file #
139 ; FIELD - the field #
140 ; DEFAULT - default value, internal form
141 ; REQUIRE - a flag, (+value)'=0 means to require a value to be
142 ; entered and to return failure otherwise (optional)
143 ; PRMPTNM - Optional
144 ; 0 - display field LABEL
145 ; 1 - Prompt field TITLE
146 ;Output:
147 ; Function Value - 0 on failure, 1 on success
148 ; RESPONSE - value entered by user, pass by reference
149 ;
150 Q:(('$G(FILE))!('$G(FIELD))) 0
151 S REQUIRE=$G(REQUIRE)
152 S PRMPTNM=$G(PRMPTNM)
153 N DIR,DA,QUIT,AGAIN
154 ;
155 S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO"
156 I $G(DEFAULT)'="" DO
157 . S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
158 . S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
159 S QUIT=0
160 F D Q:QUIT
161 . D ^DIR
162 . I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q
163 . I X="@" D Q:AGAIN
164 . . S AGAIN=0
165 . . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1(" Are you sure")_"X") S AGAIN=1 Q
166 . . S RESPONSE="" ; This might trigger the "required" message below.
167 . E I X="" S RESPONSE=$G(DEFAULT)
168 . E S RESPONSE=$P(Y,"^")
169 . ;
170 . ; quit this loop if the user entered value OR value not required
171 . I RESPONSE'="" S QUIT=1 Q
172 . I 'REQUIRE S QUIT=1 Q
173 . W !,"This is a required response. Enter '^' to exit"
174 I $D(DTOUT)!$D(DUOUT) Q 0
175 Q 1
176 ;
177INST() ;
178 ; Description: Determine the institution affiliation associated with a user.
179 ;
180 ; Input:
181 ; DUZ(2) - Pointer to the INSTITUTION (#4) file (institution
182 ; affiliated with user, prompted at Kernel sign-on)
183 ;
184 ; Output:
185 ; Function Value - Returns pointer to the INSTITUTION (#4) file
186 ; entry that is associated with the user, otherwise the pointer
187 ; to the INSTITUTION (#4) file entry of the primary VA Medical
188 ; Center division is returned.
189 ;
190 Q $S($G(DUZ(2)):DUZ(2),1:$P($$SITE^VASITE(),"^"))
191 ;
192GETINST(DGPREFAC,DGINST) ;Get Institution file data
193 ; Input -- DGPREFAC Institution file IEN
194 ; Output -- 1=Successful and 0=Failure
195 ; DGINST - Institution file Array
196 N DGINST0,DGINST99,DGOKF
197 S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0=""
198 S DGINST("NAME")=$P(DGINST0,U)
199 S DGINST99=$G(^DIC(4,DGPREFAC,99))
200 S DGINST("STANUM")=$P(DGINST99,U)
201 S DGOKF=1
202GETQ Q +$G(DGOKF)
Note: See TracBrowser for help on using the repository browser.