source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENELA4.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: 7.4 KB
RevLine 
[613]1DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN - Patient Eligibility API ; 04/24/2006 9:09 AM
2 ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653**;Aug 13,1993;Build 2
3 ;
4 ;
5PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
6 ; Description: Used to compute the priority group and subgroup for a
7 ; patient, also returning the subset of the eligibility data on which
8 ; the priority subgroup is based.
9 ;
10 ;Input:
11 ; DFN - ien of patient
12 ; DGELG - ELIGIBILITY object array (optional, pass by reference)
13 ; ENRDATE - The Enrollment Date. This date is used in the priority
14 ; determination only if the application date is not passed.
15 ; APPDATE - The Enrollment Application Date. This date is used
16 ; to determine the priority. If the application date
17 ; is not passed then the enrollment date (ENRDATE) is used.
18 ;
19 ;Output:
20 ; Function Value - returns the priority and subgroup computed by the
21 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
22 ; DGELGSUB - this local array will contain the eligibility data on
23 ; which the priority determination was based, pass by reference
24 ; if needed.
25 ;
26 N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
27 K DGELGSUB S DGELGSUB=""
28 S (HICODE,HIPRI,SUBGRP,HISUB)=""
29 D
30 .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;can not proceed with eligibility
31 .; can't proceed without an Enrollment Date or Application Date
32 .I '$G(ENRDATE),'$G(APPDATE) Q
33 .I $$GET^DGENPTA(DFN,.DGPAT)
34 .; determine priority/subgroup based on primary eligibility
35 .S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
36 .S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE))
37 .S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
38 .S CODE=""
39 .;
40 .; determine if other eligibilities result in higher priority/subgroup
41 .F S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1)) D
42 ..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE))
43 ..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
44 ..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
45 ..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
46 .;
47 .;set the DGELGSUB() array with the eligibility information used in the
48 .;priority determination
49 .S DGELGSUB("CODE")=HICODE,DGELGSUB("SC")=DGELG("SC"),DGELGSUB("SCPER")=DGELG("SCPER"),DGELGSUB("POW")=DGELG("POW"),DGELGSUB("A&A")=DGELG("A&A"),DGELGSUB("HB")=DGELG("HB")
50 .S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
51 .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
52 .;Purple Heart Added to DGELGSUB
53 .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
54 .;Added for HVE Phase III (DG*5.3*564)
55 .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
56 .;added dg*5.3*659
57 .S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
58 .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
59 ;
60 Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
61 ;
62 ;
63PRI(CODE,DGELG,ENRDATE,APPDATE) ;
64 ; Description: Returns the priority group and subgroup based on a
65 ; single eligibility code.
66 ;Input -
67 ; CODE - pointer to file #8.1, MAS Eligibility Code
68 ; DGELG - local array obtained by calling $$GET, pass by reference
69 ; ENRDATE - The Enrollment Date. This date is used in the priority
70 ; determination only if the application date is not passed.
71 ; APPDATE - The Enrollment Application Date. This date is used
72 ; to determine the priority. If the application date
73 ; is not passed then the enrollment date (ENRDATE) is used.
74 ;
75 ;Output -
76 ; Function Value - returns the priority and subgroup computed by the
77 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
78 ;
79 N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR
80 S SUBGRP=""
81 ;
82 ; use the Application Date when determining the priority, otherwise use
83 ; the Enrollment Date (ESP DG*5,3*491)
84 S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
85 ;
86 ;get the name of the national eligibility code
87 S CODENAME=$$CODENAME^DGENELA(CODE)
88 ;
89 ;get the means test code
90 S MTSTA=""
91 I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
92 ;
93 ;get MT and GMT thresholds
94 S DGMTI=$P($$LST^DGMTU(DFN),"^")
95 S MTTHR=$P($G(^DGMT(408.31,+DGMTI,0)),"^",12)
96 S GMTTHR=$P($G(^DGMT(408.31,+DGMTI,0)),"^",27)
97 ;
98 ;get the Enrollment Group Threshold (EGT) setting
99 S DGEGT=""
100 I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
101 ;
102 D ;drops out when priority determined
103 .S PRIORITY=""
104 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
105 .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q
106 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
107 .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=1)!(DGELG("DISLOD")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q
108 .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
109 .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
110 .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("AO")="Y")!(DGELG("EC")="Y")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
111 .I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
112 .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D Q
113 ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
114 ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
115 .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
116 .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
117 ;
118 Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
119 ;
120SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
121 ;
122 N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
123 Q:'$G(DFN)
124 S U="^"
125 S:$G(PRIORITY)="" PRIORITY=""
126 S:$G(SUBGRP)="" SUBGRP=""
127 D NOW^%DTC S TODAY=X
128 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set
129 Q:TODAY<EGT("EFFDATE") SUBGRP ;EGT is not in effect
130 I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
131 I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
132 I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
133 ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
134 S DGENRIEN=$$FINDCUR^DGENA(DFN)
135 I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
136 S DONE=0
137 F Q:DONE D
138 .I 'DGENRIEN S DONE=2 Q
139 .I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
140 .S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
141 .Q:DGENRC("STATUS")=6 ;deceased
142 .I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
143 .S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
144 .I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
145 .; HEC is the authoritative source on continuous enrollment
146 .I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
147 ;
148 Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
149 ;
150SUBCNV(SUBGRP) ;return new subgrp
151 I SUBGRP=1 Q 5
152 I SUBGRP=3 Q 7
153 Q SUBGRP
Note: See TracBrowser for help on using the repository browser.