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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 9/18/06 12:05pm
2 ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653**;Aug 13,1993;Build 2
3 ;
4CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ;
5 ;Does validation checks on the eligibility contained in the DGELG array.
6 ;
7 ;Input:
8 ; DGELG - array containing eligibility data (pass by reference)
9 ; DGPAT - array containing patient data (pass by reference)
10 ; DGCDIS - array containing catastrophic disability determination (pass by reference)
11 ;
12 ;Output:
13 ; Function Value - returns 1 if all validation checks passed, 0 otherwise
14 ; ERRMSG - returns a message if validations fail (pass by reference)
15 ;
16 N SUCCESS,NATCODE,BAD,SUB,CODE,DGONV,DGTEXT,INELDATE
17 S SUCCESS=0
18 S ERRMSG=""
19 ;
20 D ;drops out of block on failure
21 .;
22 .;get optional arrays if not there
23 .I '$D(DGPAT),'$$GET^DGENPTA(DGELG("DFN"),.DGPAT) S ERRMSG="PATIENT NOT FOUND" Q
24 .I '$D(DGCDIS),'$$GET^DGENCDA(DGELG("DFN"),.DGCDIS) S ERRMSG="PATIENT NOT FOUND" Q
25 .;
26 .;do field level checks
27 .S SUB="" F S SUB=$O(DGELG(SUB)) Q:(SUB="") I SUB'="ELIG",SUB'="RATEDIS",'$$CHKFIELD(SUB,DGELG(SUB)) S ERRMSG="BAD VALUE, FIELD = "_$$GET1^DID(2,$$FIELD(SUB),"","LABEL") Q
28 .;
29 .Q:(SUB'="") ;didn't finish the loop
30 .;
31 .;also check SC % field of Rated Disabilities
32 .S SUB="" F S SUB=$O(DGELG("RATEDIS",SUB)) Q:(SUB="") I '$$CHKFIELD("PER",DGELG("RATEDIS",SUB,"PER")) S ERRMSG="BAD VALUE, FIELD = DISABILITY % OF THE RATED DISABILITIES MULTIPLE" Q
33 .Q:(SUB'="") ;didn't finish the loop
34 .;
35 .I DGELG("SC")="Y",DGELG("SCPER")="" S ERRMSG="SC% UNSPECIFIED FOR SC VET" Q
36 .;
37 .;!! put this check back when POS is added to the Z11 message
38 .;I DGPAT("VETERAN")="Y",'DGELG("POS") S ERRMSG="POS UNSPECIFIED" Q
39 .;
40 .I 'DGELG("ELIG","CODE") S ERRMSG="PRIMARY ELIGIBILITY IS UNSPECIFIED" Q
41 .;
42 .I (DGELG("VACKAMT")>0),(DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y") S ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'" Q
43 .;
44 .;
45 .;
46 .I (DGELG("SC")="N"),(DGELG("VADISAB")="Y") S ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS" Q
47 .;
48 .S BAD=1 D Q:BAD ;check primary eligibility
49 ..S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
50 ..Q:'NATCODE
51 ..;
52 ..I NATCODE=21 S ERRMSG="CATASTROPHICALLY DISABLED NOT ALLOWED AS PRIMARY ELIGIBILITY" Q
53 ..;
54 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")<50),(NATCODE'=3) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
55 ..;
56 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")>49),(NATCODE'=1) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
57 ..;
58 ..S DGONV=$O(^DIC(21,"B","OTHER NON-VETERANS","")),INELDATE=$P($G(^DPT(DFN,.15)),"^",2)
59 ..I INELDATE'="",DGPAT("INELDATE")'>0,DGELG("POS"),DGELG("POS")=DGONV,'$D(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE"))) D
60 ...S DGTEXT="Patient was previously determined to be ineligible for VA health care. Upon review, the individual is determined to be eligible for "
61 ...S DGTEXT=DGTEXT_"VA care. Please update period of service and other eligibility data as needed.."
62 ...D ADDMSG^DGENUPL3(.MSGS,DGTEXT,0)
63 ..;
64 ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(NATCODE=1)!(NATCODE=3) S BAD=0 Q ;primary eligibility OK
65 ..;
66 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE'=18 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PRISONER OF WAR" Q
67 ..;
68 ..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE=18 S BAD=0 Q
69 ..;
70 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE'=22 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PURPLE HEART RECIPIENT" Q
71 ..;
72 ..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE=22 S BAD=0 Q
73 ..;
74 ..; disabled DG*5.3*367, for Inel
75 ..;I (DGPAT("VETERAN")'=$P($G(^DIC(8.1,NATCODE,0)),"^",5)) S ERRMSG="PRIMARY ELIGIBILTY NOT CONSISTENT WITH VETERAN STATUS" Q
76 ..;
77 ..I DGELG("A&A")'="Y",NATCODE=2 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH A&A INDICATOR" Q
78 ..;
79 ..I DGELG("HB")'="Y",NATCODE=15 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH HOUSEBOUND INDICATOR" Q
80 ..;
81 ..I DGELG("VAPEN")'="Y",NATCODE=4 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH VA PENSION INDICATOR" Q
82 ..;
83 ..I DGELG("SC")="Y",((NATCODE=4)!(NATCODE=5)) S ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR" Q
84 ..;
85 ..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q
86 ..;
87 ..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q
88 ..;
89 ..;primary eligibility is good
90 ..S BAD=0
91 .;
92 .S SUCCESS=1
93 .;check eligibilities multiple
94 .S CODE=0 F S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:'CODE D Q:('SUCCESS)
95 ..S NATCODE=$$NATCODE^DGENELA(CODE)
96 ..Q:'NATCODE
97 ..I NATCODE=21,'DGCDIS("DATE") S SUCCESS=0,ERRMSG="CATASTROPHICALLY DISABLED ELIGIBILITY REQUIRES CATASTROPHICALLY DISABLED DETERMINATION DATE" Q
98 .;
99 Q SUCCESS
100 ;
101STORE(DGELG,DGPAT,DGCDIS,ERROR,SKIPCHK) ;
102 ;Stores an eligibility record for a patient. The patient record must
103 ;already exist. A lock on the Patient record is required, and is
104 ;released upon completion.
105 ;
106 ;Input:
107 ; DGELG - eligibility array (pass by reference)
108 ; DGPAT - patient array (optional, pass by reference)
109 ; DGCDIS - array containing the catastrophic disability determination (optional, pass by reference)
110 ; SKIPCHK - flag, set to 1 means that the consistency checks
111 ; were already done & should be skipped
112 ;
113 ;Output:
114 ; Function Value - returns 1 if successful, otherwise 0
115 ; ERROR - in event of failure returns an error message (pass by reference, optional)
116 ;
117 N SUCCESS,DATA,FIELD,DA,DFN,COUNT
118 S DFN=$G(DGELG("DFN"))
119 S SUCCESS=0
120 S ERROR=""
121 ;
122 D ;drops out of block on failure
123 .I '$$LOCK^DGENPTA1(DFN) S ERROR="UNABLE TO LOCK PATIENT RECORD" Q
124 .I $G(SKIPCHK)'=1,'$$CHECK(.DGELG,.DGPAT,.DGCDIS,.ERROR) Q
125 .S SUB="" F S SUB=$O(DGELG(SUB)) Q:SUB="" D
126 ..I SUB'="ELIG",SUB'="RATEDIS",SUB'="DFN" S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=DGELG(SUB)
127 .;
128 .;don't add the Primary Eligibility unless different, so as to not
129 .;fire off x-refs unless necessary
130 .I $P($G(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE") S DATA(.361)=DGELG("ELIG","CODE")
131 .;
132 .; Only update User Enrollee fields if the incoming UE status is
133 .; greater than the USER ENROLLEE VALID THROUGH on file.
134 .I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DATA(.3617),DATA(.3618)
135 .;
136 .I '$$UPD^DGENDBS(2,DFN,.DATA) S ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD" Q
137 .;
138 .;
139 .;delete eligibilities that do not belong
140 .D DELELIG^DGENELA2(DFN,.DGELG)
141 .;
142 .;overlay Rated Disabilities
143 .Q:'$$OVERLAY()
144 .;
145 .;Add the new Patient Eligibilities
146 .;Don't add the an eligibility unless different - so as to not
147 .;fire off the x-refs unless necessary.
148 .;Also, try to assign ien = the code (see input tranform of the field).
149 .K DA,DATA
150 .S DA(1)=DFN
151 .S DATA(.01)=0
152 .F S DATA(.01)=$O(DGELG("ELIG","CODE",DATA(.01))) Q:'DATA(.01) I '$D(^DPT(DFN,"E","B",DATA(.01))) I '$$ADD^DGENDBS(2.0361,.DA,.DATA,,$S($D(^DPT(DFN,"E",DATA(.01))):0,1:DATA(.01))) S ERROR="FILEMAN FAILED TO ADD PATIENT ELIGIBILITY" Q
153 .;
154 .S SUCCESS=1
155 ;
156 D UNLOCK^DGENPTA1(DFN)
157 Q SUCCESS
158 ;
159FIELD(SUB) ;
160 ;given a subscript from the ELIGIBILITY array, returns the field number
161 ;
162 Q:SUB="CODE" .361
163 Q:SUB="SC" .301
164 Q:SUB="SCPER" .302
165 Q:SUB="EFFDT" .3014
166 Q:SUB="POW" .525
167 Q:SUB="PH" .531
168 Q:SUB="A&A" .36205
169 Q:SUB="HB" .36215
170 Q:SUB="VAPEN" .36235
171 Q:SUB="VACKAMT" .36295
172 Q:SUB="DISRET" .3602
173 Q:SUB="DISLOD" .3603
174 Q:SUB="MEDICAID" .381
175 Q:SUB="MEDASKDT" .382 ;EVC - DG*5.3*653
176 Q:SUB="AO" .32102
177 Q:SUB="IR" .32103
178 Q:SUB="EC" .322013
179 Q:SUB="MTSTA" "" ;don't map Means Test Category
180 Q:SUB="P&T" .304
181 Q:SUB="POS" .323
182 Q:SUB="UNEMPLOY" .305
183 Q:SUB="SCAWDATE" .3012
184 Q:SUB="RATEINC" .293
185 Q:SUB="CLAIMNUM" .313
186 Q:SUB="CLAIMLOC" .314
187 Q:SUB="VADISAB" .3025
188 Q:SUB="ELIGSTA" .3611
189 Q:SUB="ELIGSTADATE" .3612
190 Q:SUB="ELIGVERIF" .3615
191 Q:SUB="ELIGENTBY" .3616
192 Q:SUB="RD" .01
193 Q:SUB="PER" 2
194 Q:SUB="RDSC" 3
195 Q:SUB="RDEXT" 4
196 Q:SUB="RDORIG" 5
197 Q:SUB="RDCURR" 6
198 Q:SUB="UEYEAR" .3617
199 Q:SUB="UESITE" .3618
200 Q:SUB="AOEXPLOC" .3213
201 Q:SUB="CVELEDT" .5295
202 Q:SUB="SHAD" .32115
203 ;
204 Q ""
205 ;
206CHKFIELD(SUB,VAL) ;
207 ;Description: Does field level validation of the value. Returns 1
208 ;if the value is good, 0 otherwise.
209 ;
210 Q:($G(VAL)="") 1 ;for now, all NULL values assumed okay
211 ;
212 N BAD S BAD=0
213 I (SUB="SCPER")!(SUB="PER"),(+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N) S BAD=1
214 I SUB="VACKAMT",+VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0) S BAD=1
215 I SUB="DISRET",VAL'=0,VAL'=1 S BAD=1
216 I SUB="DISLOD",VAL'=0,VAL'=1 S BAD=1
217 I SUB="MEDICAID",VAL'=0,VAL'=1 S BAD=1
218 I SUB="RATEINC",VAL'=0,VAL'=1 S BAD=1
219 I SUB="ELIGSTA",VAL'="P",VAL'="R",VAL'="V" S BAD=1
220 I SUB="POW",VAL'="Y",VAL'="N",VAL'="U" S BAD=1
221 Q 'BAD
222 ;
223 ;
224OVERLAY() ;
225 ;Description: Overlay the local Rated Disabilities with whatever HEC
226 ;sent.
227 ;
228 N SUCCESS S SUCCESS=1
229 ;
230 ;delete the rated disabilties multiple
231 D DELRDIS^DGENELA2(DFN)
232 ;
233 ;add the rated disabilities
234 K DATA,DA
235 S DA(1)=DFN
236 S COUNT=0
237 F S COUNT=$O(DGELG("RATEDIS",COUNT)) Q:'COUNT D
238 .S DATA(.01)=DGELG("RATEDIS",COUNT,"RD")
239 .I DATA(.01) D
240 ..S DATA(2)=DGELG("RATEDIS",COUNT,"PER")
241 ..S DATA(3)=DGELG("RATEDIS",COUNT,"RDSC")
242 ..S DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT")
243 ..S DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG")
244 ..S DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR")
245 ..I '$$ADD^DGENDBS(2.04,.DA,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES",SUCCESS=0
246 Q SUCCESS
Note: See TracBrowser for help on using the repository browser.