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

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

initial load of WorldVistAEHR
File size: 8.9 KB
RevLine 
[613]1DGRRPSEE ; ALB/SGG - rtnDGRR PatientServices Enrollment and Eligibility ;09/30/03 ; Compiled November 24, 2003 11:54:30
2 ;;5.3;Registration;**557**;Aug 13, 1993
3 ;
4 ;
5DOC ;<DataSet Name='EnrollmentEligibility'
6 ;
7 ;.04 ENROLLMENT STATUS (RP27.15'IX), [0;4]
8 ; 27.01 CURRENT ENROLLMENT (P27.11'I), [ENR;1]
9 ; .04 ENROLLMENT STATUS (RP27.15'IX), [0;4]
10 ; .01 NAME (RF), [0;1]
11 ;
12 ;.07 ENROLLMENT PRIORITY (SXI), [0;7]
13 ;
14 ;.3721 RATED DISABILITIES (VA) (Multiple-2.04), [.372;0]
15 ; .01 RATED DISABILITIES (VA) (MP31'X), [0;1]
16 ; 2 DISABILITY % (RNJ3,0X), [0;2]
17 ; 3 SERVICE CONNECTED (SX), [0;3]
18 ; '0' FOR NO;
19 ; '1' FOR YES;
20 ;
21 ;361 PATIENT ELIGIBILITIES (Multiple-2.0361), [E;0]
22 ; .01 ELIGIBILITY (M*P8'X), [0;1] MAS ELIGIBILITY CODE (R*P8.1'), [0;9]
23 ; .03 LONG ID (FX), [0;3]
24 ; .04 SHORT ID (F), [0;4]
25 ;
26 ;.14 CURRENT MEANS TEST STATUS (P408.32'I), [0;14]
27 ; .01 NAME (RFI), [0;1]
28 ;
29 ;.152 INELIGIBLE DATE (DX), [.15;2]
30 ;.301 SERVICE CONNECTED? (RSXa), [.3;1]
31 ;.302 SERVICE CONNECTED PERCENTAGE (NJ3,0Xa), [.3;2]
32 ;.305 UNEMPLOYABLE (S), [.3;5]
33 ;.307 INELIGIBLE REASON (FX), [.3;7]
34 ;.313 CLAIM NUMBER (FXO), [.31;3]
35 ;.323 PERIOD OF SERVICE (*P21'Xa), [.32;3]
36 ;.361 PRIMARY ELIGIBILITY CODE (*P8'Xa), [.36;1] MAS ELIGIBILITY CODE (R*P8.1'), [0;9]
37 ;27.11 .12 ENROLLMENT SUBGROUP (S), [0;12]
38 ;
39 ;.3611 ELIGIBILITY STATUS (SX), [.361;1]
40 ; 'P' FOR PENDING VERIFICATION;
41 ; 'R' FOR PENDING RE-VERIFICATION;
42 ; 'V' FOR PENDING VERIFICATION;
43 ;
44 ;391 TYPE (RP391'a), [TYPE;1]
45 ;1901 VETERAN (Y/N)? (RSXa), [VET;1]
46 ;.32102 AGENT ORANGE EXPOS. INDICATED? (RSX), [.321;2]
47 ;.32103 RADIATION EXPOSURE INDICATED? (RSX), [.321;3]
48 ;.322013 ENVIRONMENTAL CONTAMINANTS? (RSX), [.322;13]
49 ;.5291 COMBAT SERVICE INDICATED? (RSX) [.52;11]
50 ; MILITARY SEXUAL TRAUMA (MST) $$GETSTAT^DGMSTAPI
51 ; HEAD/NECK CANCER (CNV) $$GETCUR^DGNTAPI
52 ;57.4 SPINAL CORD INJURY (S), [57;4]
53 ;
54GETPSARY(PSARRAY) ;
55 NEW CNT,DGAO,DGIR,DGENV,DGCS,DGHNC,DGMST
56 SET CNT=$G(CNT)+1,PSARRAY(CNT)="<DataSet Name='EnrollmentEligibility'"
57 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EnrollmentDate^"_$$ENRLDATE()
58 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EnrollmentStatus^"_$$ENRLSTAT()
59 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EnrollmentPriority^"_$$ENRLPRIO()
60 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EnrollmentSubgroup^"_$$ENRLSUBG()
61 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^CurrentMeansTestStatus^"_$$CMEANTST()
62 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^IneligibleDate^"_$$INELDATE()
63 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^ServiceConnected^"_$$SERVCONC()
64 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^ServiceConnectedPercentage^"_$$SERVCPER()
65 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Unemployable^"_$$UNEMPLOY()
66 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^IneligibleReason^"_$$INELIGRS()
67 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^ClaimNumber^"_$$CLAIMNUM()
68 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^PeriodOfService^"_$$PEROFSRV()
69 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^PrimaryEligibilityCode^"_$$ELIGPRIM()
70 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EligibilityStatus^"_$$ELIGSTAT()
71 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Type^"_$$PATNTYPE()
72 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Veteran^"_$$VETERAN()
73 D CLASS(PTID)
74 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^AgentOrangeExposure^"_$G(DGAO)
75 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^IonizingRadiationExposure^"_$G(DGIR)
76 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^EnvironmentalContaminantExposure^"_$G(DGENV)
77 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^CombatServiceIndicated^"_$G(DGCS)
78 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^MilitarySexualTrauma^"_$G(DGMST)
79 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^HeadNeckCancer^"_$G(DGHNC)
80 SET CNT=$G(CNT)+1,PSARRAY(CNT)="^SpinalCordInjuryStatus^"_$$SPINALCI()
81 SET CNT=$G(CNT)+1,PSARRAY(CNT)=">"
82 DO ELIGIBLE
83 DO DISABLED
84 SET CNT=$G(CNT)+1,PSARRAY(CNT)="</DataSet>"_"^^^1"
85 QUIT
86 ;
87 ;
88ENRLDATE() ;
89 NEW DATA
90 SET DATA=$P($G(^DPT(PTID,"ENR")),"^",1)
91 IF DATA'="" SET DATA=$P($G(^DGEN(27.11,DATA,0)),"^",10)
92 QUIT DATA
93 ;
94ENRLSTAT() ;
95 NEW DATA
96 SET DATA=$P($G(^DPT(PTID,"ENR")),"^",1)
97 IF DATA'="" SET DATA=$P($G(^DGEN(27.11,DATA,0)),"^",4)
98 IF DATA'="" SET DATA=$P($G(^DGEN(27.15,DATA,0)),"^",1)
99 QUIT DATA
100 ;
101ENRLPRIO() ;
102 NEW DATA
103 SET DATA=$P($G(^DPT(PTID,"ENR")),"^",1)
104 IF DATA'="" SET DATA=$P($G(^DGEN(27.11,DATA,0)),"^",7)
105 SET DATA=$S(DATA=1:"GROUP 1",DATA=2:"GROUP 2",DATA=3:"GROUP 3",DATA=4:"GROUP 4",DATA=5:"GROUP 5",DATA=6:"GROUP 6",DATA=7:"GROUP 7",DATA=8:"GROUP 8",1:"")
106 QUIT DATA
107 ;
108ENRLSUBG() ;
109 NEW DATA
110 SET DATA=$P($G(^DPT(PTID,"ENR")),"^",1)
111 IF DATA'="" SET DATA=$P($G(^DGEN(27.11,DATA,0)),"^",12)
112 SET DATA=$S(DATA=1:"a",DATA=3:"c",DATA=5:"e",DATA=7:"g",1:"")
113 QUIT DATA
114 ;
115CMEANTST() ;
116 NEW DATA
117 SET DATA=$P(GLOB(0),"^",14)
118 IF DATA'="" SET DATA=$P($G(^DG(408.32,DATA,0)),"^",1)
119 QUIT DATA
120 ;
121INELDATE() ;
122 QUIT $P(GLOB(.15),"^",2)
123 ;
124SERVCONC() ;
125 NEW DATA
126 SET DATA=$P(GLOB(.3),"^",1)
127 SET DATA=$S(DATA="Y":"YES",DATA="N":"NO",1:"")
128 QUIT DATA
129 ;
130SERVCPER() ;
131 QUIT $P(GLOB(.3),"^",2)
132 ;
133UNEMPLOY() ;
134 N DATA
135 SET DATA=$P(GLOB(.3),"^",5)
136 SET DATA=$S(DATA="Y":"YES",DATA="N":"NO",1:"")
137 QUIT DATA
138 ;
139INELIGRS() ;
140 QUIT $P(GLOB(.3),"^",7)
141 ;
142CLAIMNUM() ;
143 QUIT $P(GLOB(.31),"^",3)
144 ;
145PEROFSRV() ;
146 NEW DATA
147 SET DATA=$P(GLOB(.32),"^",3)
148 IF DATA'="" SET DATA=$P($G(^DIC(21,DATA,0)),"^",1)
149 QUIT DATA
150 ;
151ELIGPRIM() ;
152 NEW DATA
153 SET DATA=$P(GLOB(.36),"^",1)
154 IF DATA'="" SET DATA=$P($G(^DIC(8,DATA,0)),"^",9)
155 IF DATA'="" SET DATA=$P($G(^DIC(8.1,DATA,0)),"^",1)
156 QUIT DATA
157 ;
158ELIGSTAT() ;
159 NEW DATA
160 SET DATA=$P(GLOB(.361),"^",1)
161 SET DATA=$S(DATA="P":"PENDING VERIFICATION",DATA="R":"PENDING RE-VERIFICATION",DATA="V":"PENDING VERIFICATION",1:"")
162 QUIT DATA
163 ;
164PATNTYPE() ;
165 NEW DATA
166 SET DATA=$P($G(^DPT(PTID,"TYPE")),"^",1)
167 I DATA'="" SET DATA=$P($G(^DG(391,DATA,0)),"^",1)
168 QUIT DATA
169 ;
170VETERAN() ;
171 NEW DATA
172 SET DATA=$P($G(^DPT(PTID,"VET")),"^",1)
173 SET DATA=$S(DATA="Y":"YES",DATA="N":"NO",1:"")
174 QUIT DATA
175 ;
176CLASS(PTID) ;Get A/O, Ion. Rad., Env. Cont., Combat Svc, MST, HNC
177 I $G(PTID)="" Q
178 N DGARRY,DGERR,DGIENS,DGNTAPI
179 S DGIENS=$$IENS^DILF(PTID)
180 D GETS^DIQ(2,DGIENS,".32102;.32103;.322013;.5291","E","DGARRY","DGERR")
181 I '$D(DGERR) D
182 .S DGAO=$G(DGARRY(2,DGIENS,.32102,"E"))
183 .S DGIR=$G(DGARRY(2,DGIENS,.32103,"E"))
184 .S DGENV=$G(DGARRY(2,DGIENS,.322013,"E"))
185 .S DGCS=$G(DGARRY(2,DGIENS,.5291,"E"))
186 ; Get MST information
187 S DGMST=$$GETSTAT^DGMSTAPI(PTID)
188 ;MST Status (#3) field from MST History (#29.11) file
189 S DGMST=$P($G(DGMST),U,6)
190 ; Get Head/Neck Cancer information
191 S DGNTAPI=$$GETCUR^DGNTAPI(PTID,"DGNTAPI")
192 ; NTR Indicator (#.02) field from Nose and Throad Radium History (#28.11) file
193 S DGHNC=$P($G(DGNTAPI("IND")),U,2)
194 Q
195 ;
196SPINALCI() ;
197 NEW DATA
198 SET DATA=$P(GLOB(57),"^",4)
199 IF DATA=1 S DATA="PARAPLEGIA-TRAUMATIC"
200 IF DATA=2 S DATA="QUADRIPLEGIA-TRAUMATIC"
201 IF DATA=3 S DATA="PARAPLEGIA-NONTRAUMATIC"
202 IF DATA=4 S DATA="QUADRIPLEGIA-NONTRAUMATIC"
203 IF DATA="X" S DATA="NOT APPLICABLE"
204 QUIT DATA
205 ;
206DISABLED ;
207 NEW DABLECNT,ROWCNT,DABLERTD,DABLEPER,DABLECON
208 SET DABLECNT=0,ROWCNT=0
209 FOR SET DABLECNT=$O(^DPT(PTID,.372,DABLECNT)) QUIT:(DABLECNT<1) DO
210 .SET GLOB(.372)=$G(^DPT(PTID,.372,DABLECNT,0))
211 .SET DABLERTD=$P(GLOB(.372),"^",1)
212 .SET DABLERTD=$P($G(^DIC(31,+DABLERTD,0)),"^",1)
213 .Q:DABLERTD=""
214 .SET DABLEPER=$P(GLOB(.372),"^",2)
215 .SET DABLECON=$S($P(GLOB(.372),"^",3)=0:"NO",$P(GLOB(.372),"^",3)=1:"YES",1:"")
216 .IF +$L(DABLERTD_DABLEPER_DABLECON) DO
217 ..SET ROWCNT=ROWCNT+1
218 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="<RatedDisability Row='"_ROWCNT_"'"
219 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Disability^"_DABLERTD_"^^DISABLED^"_ROWCNT
220 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Percent^"_DABLEPER_"^^DISABLED^"_ROWCNT
221 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Connected^"_DABLECON_"^^DISABLED^"_ROWCNT
222 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="></RatedDisability>"
223 IF ROWCNT=0 DO
224 .SET CNT=$G(CNT)+1,PSARRAY(CNT)="<RatedDisability Row='1' Disability='' Percent='' Connected=''></RatedDisability>"
225 QUIT
226 ;
227ELIGIBLE ;
228 NEW ELIGCNT,ROWCNT,ELIGIBLE,ELIGLONG,ELIGSHRT
229 SET ELIGCNT=0,ROWCNT=0
230 FOR SET ELIGCNT=$O(^DPT(PTID,"E",ELIGCNT)) QUIT:(ELIGCNT<1) DO
231 .SET GLOB("E")=$G(^DPT(PTID,"E",ELIGCNT,0))
232 .SET ELIGIBLE=$P(GLOB("E"),"^",1)
233 .IF ELIGIBLE'="" SET ELIGIBLE=$P($G(^DIC(8,ELIGIBLE,0)),"^",9)
234 .IF ELIGIBLE'="" SET ELIGIBLE=$P($G(^DIC(8.1,ELIGIBLE,0)),"^",1)
235 .SET ELIGLONG=$P(GLOB("E"),"^",3)
236 .SET ELIGSHRT=$P(GLOB("E"),"^",4)
237 .IF +$L(ELIGIBLE_ELIGLONG_ELIGSHRT) DO
238 ..SET ROWCNT=ROWCNT+1
239 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="<PatientEligibility Row='"_ROWCNT_"'"
240 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^Eligibility^"_ELIGIBLE_"^^ELIGIBLE^"_ROWCNT
241 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^LongID^"_ELIGLONG_"^^ELIGIBLE^"_ROWCNT
242 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="^ShortID^"_ELIGSHRT_"^^ELIGIBLE^"_ROWCNT
243 ..SET CNT=$G(CNT)+1,PSARRAY(CNT)="></PatientEligibility>"
244 IF ROWCNT=0 DO
245 .SET CNT=$G(CNT)+1,PSARRAY(CNT)="<PatientEligibility Row='1' Eligibility='' LongID='' ShortID=''></PatientEligibility>"
246 QUIT
Note: See TracBrowser for help on using the repository browser.