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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1DGQEUT1 ;ALB/RPM - VIC REPLACEMENT UTILITIES #1 ; 10/03/05
2 ;;5.3;Registration;**571,679,732**;Aug 13, 1993;Build 2
3 ;
4 ; This routine contains the following VIC Redesign API's:
5 ; INITARR - initialize data array
6 ; $$GETPAT - build Patient data array
7 ; $$GETELIG - build Patient Eligibility data array
8 ; $$GETPH - determine Purple Heart status
9 ; $$GETPOW - determine Prisoner of War status
10 ; $$FNDPOW - search for Prisoner of War eligibility code
11 ; $$ISENRPND - is enrollment status pending
12 ;
13 Q ;no direct entry
14 ;
15INITARR(DGVIC) ;Procedure used to initialize VIC data array nodes.
16 ;
17 ; Input:
18 ; none
19 ;
20 ; Output:
21 ; DGVIC - array of VIC data (pass by reference)
22 ;
23 N DGSUB ;array subscript
24 ;
25 ;init patient identifier nodes
26 S DGVIC("DFN")=""
27 F DGSUB="NAME","SSN","DOB","LAST","FIRST","MIDDLE","SUFFIX","PREFIX" D
28 . S DGVIC(DGSUB)=""
29 ;
30 ;init address nodes
31 F DGSUB="STREET1","STREET2","STREET3","CITY","STATE","ZIP","ADRTYPE" D
32 . S DGVIC(DGSUB)=""
33 ;
34 ;init vic eligibility nodes
35 F DGSUB="SC","ENRSTAT","ELIGSTAT","MST","COMBVET","POW","PH" D
36 . S DGVIC(DGSUB)=""
37 ;
38 ;init facility nodes
39 F DGSUB="FACNUM","FACNAME","VISN" D
40 . S DGVIC(DGSUB)=""
41 ;
42 ;init card print release status node
43 S DGVIC("STAT")=""
44 ;
45 ;init document type node
46 S DGVIC("DOCTYPE")="VIC"
47 ;
48 Q
49 ;
50 ;
51GETPAT(DGDFN,DGPAT) ;build Patient object
52 ; This function retrieves patient demographic data needed to produce
53 ; a Veteran ID Card and returns the data in an array format.
54 ;
55 ; Supported Reference:
56 ; DBIA #10103: $$FMTE^XLFDT
57 ;
58 ; Input:
59 ; DGDFN - (required) pointer to patient in PATIENT (#2) file
60 ;
61 ; Output:
62 ; Function value - returns 1 on success, 0 on failure
63 ; DGPAT - array of patient demographics, pass by reference
64 ; Array subscripts are:
65 ; "DFN" - Pointer to patient in PATIENT (#2) file
66 ; "NAME" - Patient Full Name
67 ; "SSN" - Social Security Number
68 ; "DOB" - Date of Birth (mmddyyyy)
69 ; "LAST" - Family Name from name components
70 ; "FIRST" - Given Name from name components
71 ; "MIDDLE" - Middle Name from name components
72 ; "SUFFIX" - Suffix from name components
73 ; "PREFIX" - Prefix from name components
74 ; "STREET1" - Line 1 of mailing address
75 ; "STREET2" - Line 2 of mailing address
76 ; "STREET3" - Line 3 of mailing address
77 ; "CITY" - Mailing address city
78 ; "STATE" - Mailing address state
79 ; "ZIP" - Mailing address ZIP code
80 ; "ADRTYPE" - Mailing address type
81 ; [0:unable to determine,1:permanent,
82 ; 2:temporary,3:confidential,4:facility]
83 ; "ICN" - Integration Control Number
84 ; "FACNUM" - Local Station number
85 ; "FACNAME" - Local Facility name
86 ; "VISN" - Local Facility's VISN
87 ;
88 N DGRSLT
89 ;
90 S DGRSLT=0
91 ;
92 I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D ;drop out of block on first failure
93 . ;
94 . ;get name, ssn, dob, dfn
95 . Q:'$$GETIDS^DGQEDEMO(DGDFN,.DGPAT)
96 . ;
97 . ;format Date of Birth to mmddyyyy
98 . S DGPAT("DOB")=$TR($$FMTE^XLFDT(DGPAT("DOB"),"5Z"),"/","")
99 . ;
100 . ;get name components
101 . Q:'$$GETNAMC^DGQEDEMO(DGDFN,.DGPAT)
102 . ;
103 . ;get mailing address
104 . Q:'$$GETADDR^DGQEDEMO(DGDFN,.DGPAT)
105 . ;
106 . ;get national ICN
107 . S DGPAT("ICN")=$$GETICN^DGQEDEMO(DGDFN)
108 . ;
109 . ;get facility info
110 . D GETSITE^DGQEDEMO(.DGPAT)
111 . ;
112 . ;success
113 . S DGRSLT=1
114 ;
115 Q DGRSLT
116 ;
117GETELIG(DGDFN,DGELG) ;build Patient Eligibility object
118 ; This function retrieves patient data needed to determine the
119 ; patient's VIC eligibility and returns the data in an array format.
120 ;
121 ; Supported References:
122 ; DBIA #10061: ELIG^VADPT
123 ; DBIA #2716: $$GETSTAT^DGMSTAPI
124 ; DBIA #4156: $$CVEDT^DGCV
125 ;
126 ; Input:
127 ; DGDFN - (required) pointer to patient in PATIENT (#2) file
128 ;
129 ; Output:
130 ; Function value - returns 1 on success, 0 on failure
131 ; DGELG - array of eligibility indicators, pass by reference
132 ; Array subscripts are:
133 ; "SC" - Service Connected indicator
134 ; "ENRSTAT" - Enrollment Status
135 ; "ELIGSTAT" - Eligibility Status
136 ; "MST" - Military Sexual Trauma Status
137 ; "COMBVET" - Combat Veteran Status
138 ; "POW" - Prisoner of War Indicator
139 ; "PH" - Purple Heart Indicator
140 ;
141 N DFN ;input parameter to ELIG^VADPT
142 N DGRSLT ;function value
143 N VAEL ;VADPT return array
144 N VAERR ;VADPT error value
145 ;
146 S DGRSLT=0
147 ;
148 I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D
149 . ;
150 . ;get Eligibility Status and Service Connection
151 . S DFN=DGDFN
152 . D ELIG^VADPT
153 . S DGELG("ELIGSTAT")=$P($G(VAEL(8)),U)
154 . S DGELG("SC")=+$G(VAEL(3))
155 . ;
156 . ;get current Enrollment Status
157 . S DGELG("ENRSTAT")=$$STATUS^DGENA(DGDFN)
158 . ;
159 . ;get MST Status
160 . S DGELG("MST")=$P($$GETSTAT^DGMSTAPI(DGDFN),U,2)
161 . ;
162 . ;get Combat Veteran Status
163 . S DGELG("COMBVET")=+$$CVEDT^DGCV(DGDFN)
164 . ;
165 . ;get Purple Heart Indicator
166 . S DGELG("PH")=$$GETPH(DGDFN)
167 . ;
168 . ;get POW indicator
169 . S DGELG("POW")=$S($$ISENRPND(DGELG("ENRSTAT")):"P",1:$$FNDPOW(.VAEL))
170 . ;
171 . ;success
172 . S DGRSLT=1
173 ;
174 Q DGRSLT
175 ;
176GETPH(DGDFN) ;get purple heart indicator
177 ;This function retrieves the Current PH Indicator and Current PH
178 ;Status and returns a single interpretation value.
179 ;
180 ; Supported References:
181 ; DBIA #10061: SVC^VADPT
182 ;
183 ; Input:
184 ; DGDFN - pointer to patient in PATIENT (#2) file
185 ;
186 ; Output:
187 ; Function value - returns "Y" to print indicator on VIC; "N" to
188 ; not print indicator on VIC; "P" to hold request
189 ; until confirmation; "" when Registration interview
190 ; question is unanswered.
191 ;
192 N DFN ;input parameter to SVC^VADPT
193 N DGPHIND ;current purple heart indicator
194 N DGPHSTAT ;current purple heart status
195 N DGRSLT ;function value
196 N VAERR ;VADPT error value
197 N VASV ;VADPT return array
198 ;
199 S DGRSLT=""
200 ;
201 I $G(DGDFN)>0,$D(^DPT(DGDFN)) D
202 . ;
203 . ;get purple heart indicator and status
204 . S DFN=DGDFN
205 . D SVC^VADPT
206 . S DGPHIND=$G(VASV(9))
207 . S DGPHSTAT=$P($G(VASV(9,1)),U,2)
208 . ;
209 . ;interpret status
210 . I DGPHIND=1 S DGRSLT=$S(DGPHSTAT="CONFIRMED":"Y",1:"P")
211 . I DGPHIND=0 S DGRSLT="N"
212 ;
213 Q DGRSLT
214 ;
215GETPOW(DGDFN) ;get POW indicator
216 ;This function retrieves the eligibility codes for a given patient and
217 ;returns the POW indicator.
218 ;
219 ; Supported References:
220 ; DBIA #10061: ELIG^VADPT
221 ;
222 ; Input:
223 ; DGDFN - pointer to patient in PATIENT (#2) file
224 ;
225 ; Output:
226 ; Function value - returns results from call to $$FNDPOW
227 ;
228 N DFN
229 N VAEL ;VADPT result array
230 N VAERR ;VADPT error message
231 ;
232 S DFN=$G(DGDFN)
233 D ELIG^VADPT
234 ;
235 Q $$FNDPOW(.VAEL)
236 ;
237FNDPOW(DGEL) ;find POW eligibility code
238 ;This function searches a list of eligibility codes for PRISONER OF
239 ;WAR and returns the boolean result.
240 ;
241 ; Input:
242 ; DGEL - result array from call to ELIG^VADPT
243 ;
244 ; Output:
245 ; Function value - returns "Y" when PRISONER OF WAR found;
246 ; otherwise "N"
247 ;
248 N DGEC ;eligibility code number
249 N DGRSLT ;function value
250 ;
251 S DGRSLT="N"
252 ;
253 ;Check primary eligibility code
254 I $P($G(DGEL(1)),U,2)="PRISONER OF WAR" Q "Y"
255 ;
256 S DGEC=0
257 F S DGEC=$O(DGEL(1,DGEC)) Q:'DGEC D Q:DGRSLT="Y"
258 . I $P(DGEL(1,DGEC),U,2)="PRISONER OF WAR" S DGRSLT="Y"
259 ;
260 Q DGRSLT
261 ;
262ISENRPND(DGST) ;is veteran's enrollment status pending?
263 ;
264 ; Input:
265 ; DGST - pointer to enrollment status in ENROLLMENT STATUS (#27.15)
266 ; file.
267 ;
268 ; Output:
269 ; Function value - returns 1 when status is pending; otherwise 0
270 ;
271 S DGST=+$G(DGST)
272 Q $S('DGST:1,DGST=1:1,DGST=15:1,DGST=16:1,DGST=17:1,DGST=18:1,1:0)
Note: See TracBrowser for help on using the repository browser.