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

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

initial load of WorldVistAEHR

File size: 9.0 KB
Line 
1DGENEGT1 ;ALB/KCL,ISA/KWP,LBD,RGL,BRM - Enrollment Group Threshold API's ; 7/28/04 12:54pm
2 ;;5.3;Registration;**232,417,454,491,513,451,564,672,717**;Aug 13, 1993
3 ;
4 ;
5NOTIFY(DGEGT,OLDEGT) ;
6 ; Description: This is used to send a message to local mail group.
7 ; The notification is used to communicate changes in the Enrollment
8 ; Group Threshold (EGT) setting to users at the local site.
9 ;
10 ; Input:
11 ; DGEGT - the new Enrollment Group Threshold array, passed by reference
12 ; OLDEGT - the previous Enrollment Group Threshold array, passed by reference
13 ;
14 ; Output: None
15 ;
16 N TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI
17 ;
18 ; init subject and sender
19 S XMSUB="Enrollment Group Threshold (EGT) Changed"
20 S (XMDUN,XMDUZ)="Registration Enrollment Module"
21 ;
22 ; recipient
23 S XMY("G.DGEN EGT UPDATES")=""
24 ;
25 ; get old EGT priority
26 S OLDPRI=$G(OLDEGT("PRIORITY"))
27 ;
28 S XMTEXT="TEXT("
29 S TEXT(1)="The Secretary of the VA has officially changed the enrollment priority"
30 S TEXT(2)="grouping of veterans who shall receive care. This change may place"
31 S TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category."
32 S TEXT(4)=""
33 S TEXT(5)=""
34 S TEXT(6)=" Prior EGT Priority: "_$S($G(OLDPRI):$$EXTERNAL^DILFD(27.16,.02,"F",OLDPRI),1:"N/A")_$S($G(OLDEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",OLDEGT("SUBGRP")),1:"")
35 S TEXT(7)=""
36 S TEXT(8)=""
37 S TEXT(9)=" New Enrollment Group Threshold (EGT) Settings:"
38 S TEXT(10)=""
39 S TEXT(11)=" EGT Priority: "_$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY"))_$S($G(DGEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")),1:"")
40 S TEXT(12)=" EGT Type: "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))
41 S TEXT(13)=" EGT Effective Date: "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE"))
42 ;
43 ; mailman deliverey
44 D ^XMD
45 ;
46 Q
47 ;
48 ;
49DISPLAY() ;
50 ; Description: Display Enrollment Group Threshold (EGT) settings.
51 ;
52 N DGEGT
53 ;
54 W !
55 I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT) W !,"Enrollment Group Threshold (EGT) settings not found."
56 E D
57 .W !,?3,"Enrollment Group Threshold (EGT) Settings"
58 .W !,?3,"========================================="
59 .W !
60 .W !?5,"Date Entered",?25,": ",$S('$G(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED")))
61 .W !?5,"EGT Priority",?25,": ",$S('$G(DGEGT("PRIORITY")):"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY")))_$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")))
62 .W !?5,"EGT Type",?25,": ",$S($G(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")))
63 .W !?5,"EGT Effective Date",?25,": ",$S('$G(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE")))
64 ;
65 Q
66 ;
67ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ;
68 ; Description: This function will determine if the enrollment is above
69 ; the threshold.
70 ;
71 ;Input:
72 ; DPTDFN - Patient File IEN
73 ; ENRPRI - Enrollment Priority
74 ; ENRGRP - Enrollment Sub-Group
75 ; EGTPRI - EGT Priority (optional) - not used
76 ; EGTGRP - EGT Sub-Group (optional) - not used
77 ; EGTFLG - Flag to bypass additional EGT type 2 check (optional)
78 ; It is used by $$ABOVE2 to prevent re-entering the
79 ; sub-priority API ($$SUBPRI^DGENELA4)
80 ; Output:
81 ; Returns 1 if above 0 below.
82 ;
83 I $G(ENRGRP)="" S ENRGRP=""
84 I $G(ENRPRI)="" S ENRPRI=""
85 N ABOVE,EGT,TODAY,X
86 I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) Q 1
87 D NOW^%DTC S TODAY=X
88 I TODAY<EGT("EFFDATE") Q 1
89 ;
90 ;EGT type 2 - Stop New Enrollments
91 ; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491)
92 I EGT("TYPE")=2!(EGT("TYPE")=4) D Q ABOVE
93 .S ABOVE=0
94 .I ENRPRI<7 D Q
95 ..I ENRPRI'>EGT("PRIORITY") S ABOVE=1 Q
96 .;do check for priorities 7 and 8
97 .I ENRPRI<EGT("PRIORITY") S ABOVE=1 Q
98 .I ENRGRP'>EGT("SUBGRP") S ABOVE=1 Q
99 .I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1
100 ;
101 ;EGT types 1 & 3
102 ;do check for priorities 7 and 8
103 I ENRPRI>6&(ENRPRI=EGT("PRIORITY")) S ABOVE=0 D Q ABOVE
104 .I ENRGRP'>(EGT("SUBGRP")) S ABOVE=1
105 I ENRPRI'>(EGT("PRIORITY")) Q 1
106 Q 0
107 ;
108ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ;
109 ;
110 ; Input: DPTDFN - Patient File IEN
111 ; ENRDT - enrollment effective date
112 ; PRIORITY - enrollment priority
113 ; SUBGRP - enrollment sub-priority (internal numeric value)
114 ;
115 ; Output: 1 or 0 for above or below EGT threshold
116 ;
117 N ABOVE,TODAY,X,EGT
118 S ABOVE=1
119 S:'$G(SUBGRP) SUBGRP=""
120 S:'$G(PRIORITY) PRIORITY=""
121 S:'$G(ENRDT) ENRDT=""
122 D NOW^%DTC S TODAY=X
123 Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1
124 Q:'$G(EGT("EFFDATE")) 1
125 Q:TODAY<EGT("EFFDATE") 1
126 Q:EGT("TYPE")#2 $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) ;If EGT type 1 or 3
127 I '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) Q 0
128 Q ABOVE
129 ;
130OVRRIDE(DPTDFN,EGT) ;check for previous EGT override by HEC and new rules
131 N CVDT,ENRCAT,ENRDT,EGTENR,ENRIEN,DGPAT,STOP,CUR,CE
132 S (STOP,CUR)=0
133 I '$$GET^DGENELA(DPTDFN,.DGPAT) Q 0 ;Get current Patient file data
134 ; Find most recent enrollment record
135 S ENRIEN=$$FINDCUR^DGENA(.DPTDFN)
136 F Q:STOP!CUR D
137 .I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
138 .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
139 .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
140 .; If status is Pending, Deceased, Not Eligible, or Not Applicable
141 .; ignore record and get previous
142 .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
143 .S CUR=1
144 I STOP Q 0
145 S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
146 S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
147 ; If enrollment status was overridden at HEC, then cont. enroll.
148 I EGTENR("SOURCE")=2,ENRDT'<EGT("EFFDATE"),ENRCAT="E" Q 1
149 ; If status is Rejected or Cancelled/Declined, quit (no cont. enroll.)
150 I "^4^7^11^12^13^22^"[(U_EGTENR("STATUS")_U) Q 0
151 ; If Application Date or Effective Date of Change are prior to the
152 ; EGT Effective Date then cont. enroll.
153 I ENRDT<EGT("EFFDATE") Q 1
154 ; If Enrollment Record is Verified, and meets one of the special CE
155 ; rules, then cont. enroll.
156 I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE Q CE>0
157 ; Check previous enrollment records for Application Date/Effective
158 ; Date and special CE rules
159 S (STOP,CE)=0
160 F Q:STOP D
161 .I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
162 .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
163 .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
164 .; If status is Pending, Deceased, Not Eligible; Ineligible Date,
165 .; or Not Applicable ignore record and get previous
166 .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
167 .S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
168 .S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
169 .; If Application Date or Effective Date of Change are prior to the
170 .; EGT Effective Date then cont. enroll.
171 .I ENRDT<EGT("EFFDATE") S (STOP,CE)=1 Q
172 .; If Enrollment Record is Verified, and meets one of the special CE
173 .; rules, then cont. enroll.
174 .I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE S STOP=1,CE=CE>0 Q
175 Q CE
176 ;
177RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672)
178 N RTN
179 ; If veteran ever had a verified enrollment with SC 10%+ and is now
180 ; SC 0% non-compensable then cont. enroll
181 I EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0) Q 1
182 ; If veteran ever had a verified enrollment with one of these
183 ; eligibilities then cont. enroll: AA, HB, VA Pension
184 I EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")) Q 1
185 ; If AO Exposure Location = Korean DMZ prior to ESR implementation,
186 ; then cont. enroll.
187 ; **** NOTE: For patch DG*5.3*672 the ESR implementation date will
188 ; be set to 12/29/2040. This will be changed to the actual ESR
189 ; implementation date in a later patch.
190 I DGPAT("AO")="Y" D I $G(RTN) Q RTN
191 .I $S($D(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K",EGTENR("EFFDATE"),EGTENR("EFFDATE")<3401229 S RTN=1
192 ; If combat vet end date is before application date, cont. enroll
193 I $G(EGTENR("ELIG","CVELEDT"))'<ENRDT Q 1
194 ; If veteran is enrolled due to MT status or Medicaid, cont. enroll
195 ; UNLESS first verified enrollment record is due to MT status or
196 ; Medicaid and the primary MT of that income year was changed to a
197 ; status that would not enroll (e.g. due to IVM converted test,
198 ; Hardship removal, or Medicaid removal).
199 I ((EGTENR("PRIORITY")=7)&("^2^16^"[(U_EGTENR("ELIG","MTSTA")_U)))!((EGTENR("PRIORITY")=5)&((EGTENR("ELIG","MTSTA")=4)!(EGTENR("ELIG","MEDICAID")=1))) S RTN=1 D Q RTN
200 .N ENIEN,ENR,MTDT,MTIEN
201 .S ENIEN=0 F S ENIEN=$O(^DGEN(27.11,"C",+DPTDFN,ENIEN)) Q:'ENIEN I $P($G(^DGEN(27.11,+ENIEN,0)),U,4)=2 D Q
202 ..I '$$GET^DGENA(ENIEN,.ENR) Q
203 ..I ((ENR("PRIORITY")=7)&("^2^16^"[(U_ENR("ELIG","MTSTA")_U)))!((ENR("PRIORITY")=5)&(ENR("ELIG","VAPEN")'="Y")&((ENR("ELIG","MTSTA")=4)!(ENR("ELIG","MEDICAID")=1))) D
204 ...S MTDT=$E(ENR("APP"),1,3)_"1231",MTIEN=$$LST^DGMTU(MTDT) Q:'MTIEN
205 ...I $P($G(^DGMT(408.31,MTIEN,0)),U,3)=6 S RTN=-1
206 Q 0
207 ;
208EDATE(APP,EFF) ; Compare the Application Date and Effective Date and
209 ; return the earlier date
210 N EDT
211 S APP=$G(APP),EFF=$G(EFF)
212 S EDT=APP I 'EDT S EDT=EFF Q EDT
213 I EFF S:EFF<EDT EDT=EFF
214 Q EDT
Note: See TracBrowser for help on using the repository browser.