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

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

initial load of WorldVistAEHR
File size: 6.7 KB
Line 
1DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN - Patient Eligibility API ; 9/18/06 12:01pm
2 ;;5.3;Registration;**121,147,232,314,451,564,631,672,659,583,653**;Aug 13,1993;Build 2
3 ;
4GET(DFN,DGELG) ;
5 ;Description: Used to obtain the patient eligibility data.
6 ; The data is placed in the local DGELG array.
7 ;Input:
8 ; DFN - internal entry number of a record in the PATIENT file
9 ;Output:
10 ; Function Value - returns 1 on success, 0 on failure
11 ; DGELG - this is a local array that will be used to return patient eligibility data. The array subscripts and the fields mapped to are defined below. (pass by reference)
12 ;
13 ;subscript field name
14 ;"DFN" ien Patient record
15 ;"ELIG","CODE" Primary Eligibility Code
16 ;"ELIG","CODE",<ien> Patient Eligibilities
17 ;"SC" Service Connected
18 ;"SCPER" Service Connected Percentage
19 ;"EFFDT" SC Combined Effective Date
20 ;"POW" POW Status Indicated
21 ;"A&A" Receiving A&A Benefits
22 ;"HB" Receiving Housebound Benefits
23 ;"VAPEN" Receiving a VA Pension
24 ;"VACKAMT" Total Annual VA Check Amount
25 ;"DISRET" Military Disability Retirement
26 ;"DISLOD" Discharge Due to Disability (added with DG 672)
27 ;"MEDICAID" Medicaid
28 ;"MEDASKDT" Date Medicaid Last Asked
29 ;"AO" Exposed to Agent Orange
30 ;"IR" Radiation Exposure Indicated
31 ;"RADEXPM" Radiation Exposure Method
32 ;"EC" Environmental Contaminants
33 ;"MTSTA" Means Test Status
34 ;P&T P&T
35 ;POS PERIOD OF SERVICE
36 ;UNEMPLOY UNEMPLOYABLE
37 ;SCAWDATE SC AWARD DATE
38 ;RATEINC RATED INCOMPETENT
39 ;CLAIMNUM CLAIM NUMBER
40 ;CLAIMLOC CLAIM FOLDER LOCATION
41 ;VADISAB RECEIVING VA DISABILITY?
42 ;ELIGSTA ELIGIBILITY STATUS
43 ;ELIGSTADATE ELIGIBILITY STATUS DATE
44 ;ELIGVERIF ELIGIBILITY VERIF. METHOD
45 ;ELIGVSITE ELIGIBILITY VERIFICATION SITE
46 ;ELIGENTBY ELIGIBILITY STATUS ENTERED BY
47 ;RATEDIS
48 ; <COUNT>,"RD" RATED DISABILITY
49 ; <COUNT>,"PER" DISABILITY %
50 ; <COUNT>,"RDSC" SERVICE CONNECTED
51 ; <COUNT>,"RDEXT" EXTREMITY
52 ; <COUNT>,"RDORIG" ORIGINAL RD EFFECTIVE DATE
53 ; <COUNT>."RDCURR" CURRENT RD EFFECTIVE DATE
54 ;"VCD" Veteran Catastrophically Disabled? (#.39)
55 ;"PH" PURPLE HEART INDICATED
56 ;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION
57 ;"CVELEDT" COMBAT VETERAN END DATE
58 ;"SHAD" SHAD EXPOSURE
59 ;
60 K DGELG
61 S DGELG=""
62 Q:'$D(^DPT(DFN)) 0
63 N NODE,SUBREC,COUNT,CODE,IEN
64 ;
65 S DGELG("DFN")=DFN
66 S DGELG("VCD")=$$VCD^DGENA5(DFN)
67 ;
68 ;
69 S NODE=$G(^DPT(DFN,.29))
70 S DGELG("RATEINC")=$P(NODE,"^",12)
71 ;
72 S NODE=$G(^DPT(DFN,.3))
73 S DGELG("SC")=$P(NODE,"^")
74 S DGELG("SCPER")=$P(NODE,"^",2)
75 S DGELG("P&T")=$P(NODE,"^",4)
76 S DGELG("UNEMPLOY")=$P(NODE,"^",5)
77 S DGELG("SCAWDATE")=$P(NODE,"^",12)
78 S DGELG("VADISAB")=$P(NODE,"^",11)
79 S DGELG("EFFDT")=$P(NODE,"^",14)
80 ;
81 S NODE=$G(^DPT(DFN,.31))
82 S DGELG("CLAIMNUM")=$P(NODE,"^",3)
83 S DGELG("CLAIMLOC")=$P(NODE,"^",4)
84 ;
85 S NODE=$G(^DPT(DFN,.32))
86 S DGELG("POS")=$P(NODE,"^",3)
87 ;
88 S NODE=$G(^DPT(DFN,.36))
89 S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility
90 S DGELG("DISRET")=$P(NODE,"^",12)
91 S DGELG("DISLOD")=$P(NODE,"^",13)
92 ;
93 S NODE=$G(^DPT(DFN,.38))
94 S DGELG("MEDICAID")=$P(NODE,"^")
95 S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked
96 ;
97 S NODE=$G(^DPT(DFN,.361))
98 S DGELG("ELIGSTA")=$P(NODE,"^")
99 S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
100 S DGELG("ELIGVERIF")=$P(NODE,"^",5)
101 S DGELG("ELIGENTBY")=$P(NODE,"^",6)
102 ;
103 S NODE=$G(^DPT(DFN,.362))
104 S DGELG("VACKAMT")=$P(NODE,"^",20)
105 S DGELG("VAPEN")=$P(NODE,"^",14)
106 S DGELG("A&A")=$P(NODE,"^",12)
107 S DGELG("HB")=$P(NODE,"^",13)
108 ;
109 ;
110 S NODE=$G(^DPT(DFN,.321))
111 S DGELG("AO")=$P(NODE,"^",2)
112 S DGELG("IR")=$P(NODE,"^",3)
113 S DGELG("RADEXPM")=$P(NODE,"^",12)
114 S DGELG("AOEXPLOC")=$P(NODE,"^",13)
115 S DGELG("SHAD")=$P(NODE,"^",15) ;added with DG*5.3*653
116 ;
117 S NODE=$G(^DPT(DFN,.322))
118 S DGELG("EC")=$P(NODE,"^",13)
119 ;
120 S NODE=$G(^DPT(DFN,.52))
121 S DGELG("POW")=$P(NODE,"^",5)
122 S DGELG("CVELEDT")=$P(NODE,"^",15)
123 ;
124 ; Purple Heart Indicator
125 S NODE=$G(^DPT(DFN,.53))
126 S DGELG("PH")=$P(NODE,"^")
127 ;
128 ;means test category
129 S DGELG("MTSTA")=""
130 S IEN=$P($$LST^DGMTU(DFN),"^")
131 I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3)
132 ;
133 ;get the other eligibilities multiple
134 S SUBREC=0
135 F S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC D
136 .S CODE=+$G(^DPT(DFN,"E",SUBREC,0))
137 .;
138 .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actually removed - but the "B" x-ref has been deleted at this point
139 .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC
140 ;
141 ;rated disability multiple
142 S SUBREC=0,COUNT=0
143 F S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC D
144 .S NODE=$G(^DPT(DFN,.372,SUBREC,0))
145 .Q:'$P(NODE,"^")
146 .S COUNT=COUNT+1
147 .S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^")
148 .S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2)
149 .S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3)
150 .S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4)
151 .S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5)
152 .S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6)
153 ;
154 Q 1
155 ;
156NATNAME(CODE) ;
157 ;Description: Given an entry in file #8, Eligibility Code file,
158 ; finds the corresponding entry in file 8.1, MAS Eligbility Code file,
159 ; and returns the name
160 ;Input:
161 ; CODE - pointer to file #8
162 ;Output:
163 ; Function Value - name of corresponding code in file #8.1
164 ;
165 Q:'$G(CODE) ""
166 Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9))
167 ;
168NATCODE(CODE) ;
169 ;Description: Given an entry in file #8, Eligibility Code file,
170 ; finds the corresponding entry in file 8.1, MAS Eligbility Code file
171 ;Input:
172 ; CODE - pointer to file #8
173 ;Output:
174 ; Function Value - pointer to file #8.1
175 ;
176 Q:'$G(CODE) ""
177 Q $P($G(^DIC(8,CODE,0)),"^",9)
178 ;
179CODENAME(CODE) ;
180 ;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
181 ; it returns the name of the code
182 ;Input:
183 ; CODE - pointer to file #8.1
184 ;Output:
185 ; Function Value - name of the code pointed to
186 ;
187 Q:'$G(CODE) ""
188 Q $P($G(^DIC(8.1,CODE,0)),"^")
189 ;
190ELIGSTAT(DFN,DGELG) ;
191 ;Description: Used to get the ELIGIBILITY STATUS and the
192 ;ELIGIBILITY STATUS DATE of the patient.
193 ;
194 ;Input:
195 ; DFN - ien of patient record
196 ;
197 ;Ouput:
198 ; Function Value - 1 on success, 0 on failure
199 ; DGELG array (pass by reference)
200 ; "ELIGSTA" - ELIGIBILITY STATUS
201 ; "ELIGSTADATE" - ELIGIBILITY STATUS DATE
202 ;
203 N NODE,SUCCESS
204 D
205 .S SUCCESS=1
206 .I '$G(DFN) S SUCCESS=0 Q
207 .S NODE=$G(^DPT(DFN,.361))
208 .S DGELG("ELIGSTA")=$P(NODE,"^")
209 .S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
210 Q SUCCESS
Note: See TracBrowser for help on using the repository browser.