DGENEGT1 ;ALB/KCL,KWP,LBD,RGL,BRM,DLF,TDM,KUM,ARF,JAM - Enrollment Group Threshold API's ; 6/17/09 11:05am
;;5.3;Registration;**232,417,454,491,513,451,564,672,717,688,803,754,1018,1090,1111**;Aug 13, 1993;Build 18
;
;
NOTIFY(DGEGT,OLDEGT) ;
; Description: This is used to send a message to local mail group.
; The notification is used to communicate changes in the Enrollment
; Group Threshold (EGT) setting to users at the local site.
;
; Input:
; DGEGT - the new Enrollment Group Threshold array, passed by reference
; OLDEGT - the previous Enrollment Group Threshold array, passed by reference
;
; Output: None
;
N TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI
;
; init subject and sender
S XMSUB="Enrollment Group Threshold (EGT) Changed"
S (XMDUN,XMDUZ)="Registration Enrollment Module"
;
; recipient
S XMY("G.DGEN EGT UPDATES")=""
;
; get old EGT priority
S OLDPRI=$G(OLDEGT("PRIORITY"))
;
S XMTEXT="TEXT("
S TEXT(1)="The Secretary of the VA has officially changed the enrollment priority"
S TEXT(2)="grouping of veterans who shall receive care. This change may place"
S TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category."
S TEXT(4)=""
S TEXT(5)=""
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:"")
S TEXT(7)=""
S TEXT(8)=""
S TEXT(9)=" New Enrollment Group Threshold (EGT) Settings:"
S TEXT(10)=""
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:"")
S TEXT(12)=" EGT Type: "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))
S TEXT(13)=" EGT Effective Date: "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE"))
;
; mailman deliverey
D ^XMD
;
Q
;
;
DISPLAY() ;
; Description: Display Enrollment Group Threshold (EGT) settings.
;
N DGEGT
;
W !
I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT) W !,"Enrollment Group Threshold (EGT) settings not found."
E D
.W !,?3,"Enrollment Group Threshold (EGT) Settings"
.W !,?3,"========================================="
.W !
.W !?5,"Date Entered",?25,": ",$S('$G(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED")))
.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")))
.W !?5,"EGT Type",?25,": ",$S($G(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")))
.W !?5,"EGT Effective Date",?25,": ",$S('$G(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE")))
;
Q
;
ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ;
; Description: This function will determine if the enrollment is above
; the threshold.
;
;Input:
; DPTDFN - Patient File IEN
; ENRPRI - Enrollment Priority
; ENRGRP - Enrollment Sub-Group
; EGTPRI - EGT Priority (optional) - not used
; EGTGRP - EGT Sub-Group (optional) - not used
; EGTFLG - Flag to bypass additional EGT type 2 check (optional)
; It is used by $$ABOVE2 to prevent re-entering the
; sub-priority API ($$SUBPRI^DGENELA4)
; Output:
; Returns 1 if above 0 below.
;
I $G(ENRGRP)="" S ENRGRP=""
I $G(ENRPRI)="" S ENRPRI=""
N ABOVE,EGT,TODAY,X
I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) Q 1
D NOW^%DTC S TODAY=X
I TODAY<EGT("EFFDATE") Q 1
;
;EGT type 2 - Stop New Enrollments
; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491)
I EGT("TYPE")=2!(EGT("TYPE")=4) D Q ABOVE
.S ABOVE=0
.I ENRPRI<7 D Q
..I ENRPRI'>EGT("PRIORITY") S ABOVE=1 Q
.;do check for priorities 7 and 8
.I ENRPRI<EGT("PRIORITY") S ABOVE=1 Q
.I ENRGRP'>EGT("SUBGRP") S ABOVE=1 Q
.I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1
;
;EGT types 1 & 3
;do check for priorities 7 and 8
I ENRPRI>6&(ENRPRI=EGT("PRIORITY")) S ABOVE=0 D Q ABOVE
.I ENRGRP'>(EGT("SUBGRP")) S ABOVE=1
I ENRPRI'>(EGT("PRIORITY")) Q 1
Q 0
;
ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ;
;
; Input: DPTDFN - Patient File IEN
; ENRDT - enrollment effective date
; PRIORITY - enrollment priority
; SUBGRP - enrollment sub-priority (internal numeric value)
;
; Output: 1 or 0 for above or below EGT threshold
;
N ABOVE,TODAY,X,EGT
S ABOVE=1
S:'$G(SUBGRP) SUBGRP=""
S:'$G(PRIORITY) PRIORITY=""
S:'$G(ENRDT) ENRDT=""
D NOW^%DTC S TODAY=X
Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1
Q:'$G(EGT("EFFDATE")) 1
Q:TODAY<EGT("EFFDATE") 1
Q:EGT("TYPE")#2 $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) ;If EGT type 1 or 3
I '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) Q 0
Q ABOVE
;
OVRRIDE(DPTDFN,EGT) ;check for previous EGT override by HEC and new rules
N CVDT,ENRCAT,ENRDT,EGTENR,ENRIEN,DGPAT,STOP,CUR,CE
S (STOP,CUR)=0
I '$$GET^DGENELA(DPTDFN,.DGPAT) Q 0 ;Get current Patient file data
; Find most recent enrollment record
S ENRIEN=$$FINDCUR^DGENA(.DPTDFN)
F Q:STOP!CUR D
.I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
.I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
.S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
.; If status is Pending, Deceased, Not Eligible, or Not Applicable
.; ignore record and get previous
.I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
.S CUR=1
I STOP Q 0
S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
; If enrollment status was overridden at HEC, then cont. enroll.
I EGTENR("SOURCE")=2,ENRDT'<EGT("EFFDATE"),ENRCAT="E" Q 1
; DG*5.3*1111 - ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Modified comment below.
; If status is Deferred or Cancelled/Declined, quit (no cont. enroll.)
I "^4^7^11^12^13^22^"[(U_EGTENR("STATUS")_U) Q 0
; If Application Date or Effective Date of Change are prior to the
; EGT Effective Date then cont. enroll.
I ENRDT<EGT("EFFDATE") Q 1
; If Enrollment Record is Verified, and meets one of the special CE
; rules, then cont. enroll.
I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE Q CE>0
; Check previous enrollment records for Application Date/Effective
; Date and special CE rules
S (STOP,CE)=0
F Q:STOP D
.I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
.I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
.S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
.; If status is Pending, Deceased, Not Eligible; Ineligible Date,
.; or Not Applicable ignore record and get previous
.I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
.S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
.S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
.; If Application Date or Effective Date of Change are prior to the
.; EGT Effective Date then cont. enroll.
.I ENRDT<EGT("EFFDATE") S (STOP,CE)=1 Q
.; If Enrollment Record is Verified, and meets one of the special CE
.; rules, then cont. enroll.
.I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE S STOP=1,CE=CE>0 Q
Q CE
;
RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672)
N RTN,STAEXP
; If veteran ever had a verified enrollment with SC 10%+ and is now
; SC 0% non-compensable then cont. enroll
I EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0) Q 1
; If veteran ever had a verified enrollment with one of these
; eligibilities then cont. enroll: AA, HB, VA Pension
I EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")) Q 1
; If AO Exposure Location = Korean DMZ prior to ESR implementation,
; or AO Exposure Location = Vietnam prior to Special Treatment
; Authority (STA) termination
; then cont. enroll.
; **** NOTE: For patch DG*5.3*672 the ESR implementation date will
; be set to 12/29/2040. This will be changed to the actual ESR
; implementation date in a later patch.
; DG*5.3*688 - Date changed to 3/21/2009
I DGPAT("AO")="Y" D I $G(RTN) Q RTN
.I $S($D(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K",EGTENR("EFFDATE"),EGTENR("EFFDATE")<3090321 S RTN=1
.;I (EGTENR("ELIG","AOEXPLOC")="V" D ;Added with DG*5.3*754
.; DG*5.3*1018;KUM - Added Blue Water Navy check
.;I ((EGTENR("ELIG","AOEXPLOC")="V")!(EGTENR("ELIG","AOEXPLOC")="B")) D ;Added with DG*5.3*754
.; DG*5.3*1090 - Additional Agent Orange Exposure Locations added - T=THAILAND(U.S. OR ROYAL THAI MIL BASE), L=LAOS, C=CAMBODIA(MIMOT OR KREK,KAMPONG CHAM), G=GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS and J=JOHNSTON ATOLL
.I EGTENR("ELIG","AOEXPLOC")'="","VBTLCJG"[EGTENR("ELIG","AOEXPLOC") D ;Check exposure locations using initials
..S STAEXP=$$STAEXP^DGENELA4("AO") Q:STAEXP<1
..I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
; If SWAC/EC = YES prior to Special Treatment (STA) termination
; then cont. enroll.
I DGPAT("EC")="Y" D I $G(RTN) Q RTN ;Added with DG*5.3*754
.Q:EGTENR("ELIG","EC")'="Y"
.S STAEXP=$$STAEXP^DGENELA4("EC") Q:STAEXP<1
.I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
; If combat vet end date is before application date, cont. enroll
I $G(EGTENR("ELIG","CVELEDT"))'<ENRDT Q 1
; If veteran is enrolled due to MT status or Medicaid, cont. enroll
; UNLESS first verified enrollment record is due to MT status or
; Medicaid and the primary MT of that income year was changed to a
; status that would not enroll (e.g. due to IVM converted test,
; Hardship removal, or Medicaid removal).
I ((EGTENR("PRIORITY")=7!EGTENR("PRIORITY")=8)&("^2^16^"[(U_EGTENR("ELIG","MTSTA")_U)))!((EGTENR("PRIORITY")=5)&((EGTENR("ELIG","MTSTA")=4)!(EGTENR("ELIG","MEDICAID")=1))) S RTN=1 D Q RTN
.N ENIEN,ENR,MTDT,MTIEN
.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
..I '$$GET^DGENA(ENIEN,.ENR) Q
..I ((ENR("PRIORITY")=7!ENR("PRIORITY")=8)&("^2^16^"[(U_ENR("ELIG","MTSTA")_U)))!((ENR("PRIORITY")=5)&(ENR("ELIG","VAPEN")'="Y")&((ENR("ELIG","MTSTA")=4)!(ENR("ELIG","MEDICAID")=1))) D
...S MTDT=$E(ENR("APP"),1,3)_"1231",MTIEN=$$LST^DGMTU(MTDT) Q:'MTIEN
...I $P($G(^DGMT(408.31,MTIEN,0)),U,3)=6 S RTN=-1
Q 0
;
EDATE(APP,EFF) ; Compare the Application Date and Effective Date and
; return the earlier date
N EDT
S APP=$G(APP),EFF=$G(EFF)
S EDT=APP I 'EDT S EDT=EFF Q EDT
I EFF S:EFF<EDT EDT=EFF
Q EDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENEGT1 10763 printed Oct 16, 2024@18:43:16 Page 2
DGENEGT1 ;ALB/KCL,KWP,LBD,RGL,BRM,DLF,TDM,KUM,ARF,JAM - Enrollment Group Threshold API's ; 6/17/09 11:05am
+1 ;;5.3;Registration;**232,417,454,491,513,451,564,672,717,688,803,754,1018,1090,1111**;Aug 13, 1993;Build 18
+2 ;
+3 ;
NOTIFY(DGEGT,OLDEGT) ;
+1 ; Description: This is used to send a message to local mail group.
+2 ; The notification is used to communicate changes in the Enrollment
+3 ; Group Threshold (EGT) setting to users at the local site.
+4 ;
+5 ; Input:
+6 ; DGEGT - the new Enrollment Group Threshold array, passed by reference
+7 ; OLDEGT - the previous Enrollment Group Threshold array, passed by reference
+8 ;
+9 ; Output: None
+10 ;
+11 NEW TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI
+12 ;
+13 ; init subject and sender
+14 SET XMSUB="Enrollment Group Threshold (EGT) Changed"
+15 SET (XMDUN,XMDUZ)="Registration Enrollment Module"
+16 ;
+17 ; recipient
+18 SET XMY("G.DGEN EGT UPDATES")=""
+19 ;
+20 ; get old EGT priority
+21 SET OLDPRI=$GET(OLDEGT("PRIORITY"))
+22 ;
+23 SET XMTEXT="TEXT("
+24 SET TEXT(1)="The Secretary of the VA has officially changed the enrollment priority"
+25 SET TEXT(2)="grouping of veterans who shall receive care. This change may place"
+26 SET TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category."
+27 SET TEXT(4)=""
+28 SET TEXT(5)=""
+29 SET TEXT(6)=" Prior EGT Priority: "_$SELECT($GET(OLDPRI):$$EXTERNAL^DILFD(27.16,.02,"F",OLDPRI),1:"N/A")_$SELECT($GET(OLDEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",OLDEGT("SUBGRP")),1:"")
+30 SET TEXT(7)=""
+31 SET TEXT(8)=""
+32 SET TEXT(9)=" New Enrollment Group Threshold (EGT) Settings:"
+33 SET TEXT(10)=""
+34 SET TEXT(11)=" EGT Priority: "_$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY"))_$SELECT($GET(DGEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")),1:"")
+35 SET TEXT(12)=" EGT Type: "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))
+36 SET TEXT(13)=" EGT Effective Date: "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE"))
+37 ;
+38 ; mailman deliverey
+39 DO ^XMD
+40 ;
+41 QUIT
+42 ;
+43 ;
DISPLAY() ;
+1 ; Description: Display Enrollment Group Threshold (EGT) settings.
+2 ;
+3 NEW DGEGT
+4 ;
+5 WRITE !
+6 IF '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
WRITE !,"Enrollment Group Threshold (EGT) settings not found."
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !,?3,"Enrollment Group Threshold (EGT) Settings"
+9 WRITE !,?3,"========================================="
+10 WRITE !
+11 WRITE !?5,"Date Entered",?25,": ",$SELECT('$GET(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED")))
+12 WRITE !?5,"EGT Priority",?25,": ",$SELECT('$GET(DGEGT("PRIORITY")):"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY")))_$SELECT($GET(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")))
+13 WRITE !?5,"EGT Type",?25,": ",$SELECT($GET(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")))
+14 WRITE !?5,"EGT Effective Date",?25,": ",$SELECT('$GET(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE")))
End DoDot:1
+15 ;
+16 QUIT
+17 ;
ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ;
+1 ; Description: This function will determine if the enrollment is above
+2 ; the threshold.
+3 ;
+4 ;Input:
+5 ; DPTDFN - Patient File IEN
+6 ; ENRPRI - Enrollment Priority
+7 ; ENRGRP - Enrollment Sub-Group
+8 ; EGTPRI - EGT Priority (optional) - not used
+9 ; EGTGRP - EGT Sub-Group (optional) - not used
+10 ; EGTFLG - Flag to bypass additional EGT type 2 check (optional)
+11 ; It is used by $$ABOVE2 to prevent re-entering the
+12 ; sub-priority API ($$SUBPRI^DGENELA4)
+13 ; Output:
+14 ; Returns 1 if above 0 below.
+15 ;
+16 IF $GET(ENRGRP)=""
SET ENRGRP=""
+17 IF $GET(ENRPRI)=""
SET ENRPRI=""
+18 NEW ABOVE,EGT,TODAY,X
+19 IF '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT)
QUIT 1
+20 DO NOW^%DTC
SET TODAY=X
+21 IF TODAY<EGT("EFFDATE")
QUIT 1
+22 ;
+23 ;EGT type 2 - Stop New Enrollments
+24 ; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491)
+25 IF EGT("TYPE")=2!(EGT("TYPE")=4)
Begin DoDot:1
+26 SET ABOVE=0
+27 IF ENRPRI<7
Begin DoDot:2
+28 IF ENRPRI'>EGT("PRIORITY")
SET ABOVE=1
QUIT
End DoDot:2
QUIT
+29 ;do check for priorities 7 and 8
+30 IF ENRPRI<EGT("PRIORITY")
SET ABOVE=1
QUIT
+31 IF ENRGRP'>EGT("SUBGRP")
SET ABOVE=1
QUIT
+32 IF $$OVRRIDE(.DPTDFN,.EGT)
SET ABOVE=1
End DoDot:1
QUIT ABOVE
+33 ;
+34 ;EGT types 1 & 3
+35 ;do check for priorities 7 and 8
+36 IF ENRPRI>6&(ENRPRI=EGT("PRIORITY"))
SET ABOVE=0
Begin DoDot:1
+37 IF ENRGRP'>(EGT("SUBGRP"))
SET ABOVE=1
End DoDot:1
QUIT ABOVE
+38 IF ENRPRI'>(EGT("PRIORITY"))
QUIT 1
+39 QUIT 0
+40 ;
ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ;
+1 ;
+2 ; Input: DPTDFN - Patient File IEN
+3 ; ENRDT - enrollment effective date
+4 ; PRIORITY - enrollment priority
+5 ; SUBGRP - enrollment sub-priority (internal numeric value)
+6 ;
+7 ; Output: 1 or 0 for above or below EGT threshold
+8 ;
+9 NEW ABOVE,TODAY,X,EGT
+10 SET ABOVE=1
+11 if '$GET(SUBGRP)
SET SUBGRP=""
+12 if '$GET(PRIORITY)
SET PRIORITY=""
+13 if '$GET(ENRDT)
SET ENRDT=""
+14 DO NOW^%DTC
SET TODAY=X
+15 if '$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT)
QUIT 1
+16 if '$GET(EGT("EFFDATE"))
QUIT 1
+17 if TODAY<EGT("EFFDATE")
QUIT 1
+18 ;If EGT type 1 or 3
if EGT("TYPE")#2
QUIT $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1)
+19 IF '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1)
QUIT 0
+20 QUIT ABOVE
+21 ;
OVRRIDE(DPTDFN,EGT) ;check for previous EGT override by HEC and new rules
+1 NEW CVDT,ENRCAT,ENRDT,EGTENR,ENRIEN,DGPAT,STOP,CUR,CE
+2 SET (STOP,CUR)=0
+3 ;Get current Patient file data
IF '$$GET^DGENELA(DPTDFN,.DGPAT)
QUIT 0
+4 ; Find most recent enrollment record
+5 SET ENRIEN=$$FINDCUR^DGENA(.DPTDFN)
+6 FOR
if STOP!CUR
QUIT
Begin DoDot:1
+7 ;cannot check if no current enrollment
IF 'ENRIEN
SET STOP=1
QUIT
+8 ;need enr info to proceed
IF '$$GET^DGENA(ENRIEN,.EGTENR)
SET STOP=1
QUIT
+9 SET ENRIEN=$$FINDPRI^DGENA(ENRIEN)
+10 ; If status is Pending, Deceased, Not Eligible, or Not Applicable
+11 ; ignore record and get previous
+12 IF "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U)
QUIT
+13 SET CUR=1
End DoDot:1
+14 IF STOP
QUIT 0
+15 SET ENRDT=$$EDATE($GET(EGTENR("APP")),$GET(EGTENR("EFFDATE")))
if 'ENRDT
SET ENRDT=DT
+16 SET ENRCAT=$PIECE($GET(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
+17 ; If enrollment status was overridden at HEC, then cont. enroll.
+18 IF EGTENR("SOURCE")=2
IF ENRDT'<EGT("EFFDATE")
IF ENRCAT="E"
QUIT 1
+19 ; DG*5.3*1111 - ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Modified comment below.
+20 ; If status is Deferred or Cancelled/Declined, quit (no cont. enroll.)
+21 IF "^4^7^11^12^13^22^"[(U_EGTENR("STATUS")_U)
QUIT 0
+22 ; If Application Date or Effective Date of Change are prior to the
+23 ; EGT Effective Date then cont. enroll.
+24 IF ENRDT<EGT("EFFDATE")
QUIT 1
+25 ; If Enrollment Record is Verified, and meets one of the special CE
+26 ; rules, then cont. enroll.
+27 IF ENRCAT="E"
SET CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT)
IF CE
QUIT CE>0
+28 ; Check previous enrollment records for Application Date/Effective
+29 ; Date and special CE rules
+30 SET (STOP,CE)=0
+31 FOR
if STOP
QUIT
Begin DoDot:1
+32 ;cannot check if no current enrollment
IF 'ENRIEN
SET STOP=1
QUIT
+33 ;need enr info to proceed
IF '$$GET^DGENA(ENRIEN,.EGTENR)
SET STOP=1
QUIT
+34 SET ENRIEN=$$FINDPRI^DGENA(ENRIEN)
+35 ; If status is Pending, Deceased, Not Eligible; Ineligible Date,
+36 ; or Not Applicable ignore record and get previous
+37 IF "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U)
QUIT
+38 SET ENRDT=$$EDATE($GET(EGTENR("APP")),$GET(EGTENR("EFFDATE")))
if 'ENRDT
SET ENRDT=DT
+39 SET ENRCAT=$PIECE($GET(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
+40 ; If Application Date or Effective Date of Change are prior to the
+41 ; EGT Effective Date then cont. enroll.
+42 IF ENRDT<EGT("EFFDATE")
SET (STOP,CE)=1
QUIT
+43 ; If Enrollment Record is Verified, and meets one of the special CE
+44 ; rules, then cont. enroll.
+45 IF ENRCAT="E"
SET CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT)
IF CE
SET STOP=1
SET CE=CE>0
QUIT
End DoDot:1
+46 QUIT CE
+47 ;
RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672)
+1 NEW RTN,STAEXP
+2 ; If veteran ever had a verified enrollment with SC 10%+ and is now
+3 ; SC 0% non-compensable then cont. enroll
+4 IF EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0)
QUIT 1
+5 ; If veteran ever had a verified enrollment with one of these
+6 ; eligibilities then cont. enroll: AA, HB, VA Pension
+7 IF EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y"))
QUIT 1
+8 ; If AO Exposure Location = Korean DMZ prior to ESR implementation,
+9 ; or AO Exposure Location = Vietnam prior to Special Treatment
+10 ; Authority (STA) termination
+11 ; then cont. enroll.
+12 ; **** NOTE: For patch DG*5.3*672 the ESR implementation date will
+13 ; be set to 12/29/2040. This will be changed to the actual ESR
+14 ; implementation date in a later patch.
+15 ; DG*5.3*688 - Date changed to 3/21/2009
+16 IF DGPAT("AO")="Y"
Begin DoDot:1
+17 IF $SELECT($DATA(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K"
IF EGTENR("EFFDATE")
IF EGTENR("EFFDATE")<3090321
SET RTN=1
+18 ;I (EGTENR("ELIG","AOEXPLOC")="V" D ;Added with DG*5.3*754
+19 ; DG*5.3*1018;KUM - Added Blue Water Navy check
+20 ;I ((EGTENR("ELIG","AOEXPLOC")="V")!(EGTENR("ELIG","AOEXPLOC")="B")) D ;Added with DG*5.3*754
+21 ; DG*5.3*1090 - Additional Agent Orange Exposure Locations added - T=THAILAND(U.S. OR ROYAL THAI MIL BASE), L=LAOS, C=CAMBODIA(MIMOT OR KREK,KAMPONG CHAM), G=GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS and J=JOHNSTON ATOLL
+22 ;Check exposure locations using initials
IF EGTENR("ELIG","AOEXPLOC")'=""
IF "VBTLCJG"[EGTENR("ELIG","AOEXPLOC")
Begin DoDot:2
+23 SET STAEXP=$$STAEXP^DGENELA4("AO")
if STAEXP<1
QUIT
+24 IF EGTENR("EFFDATE")
IF EGTENR("EFFDATE")<STAEXP
SET RTN=1
End DoDot:2
End DoDot:1
IF $GET(RTN)
QUIT RTN
+25 ; If SWAC/EC = YES prior to Special Treatment (STA) termination
+26 ; then cont. enroll.
+27 ;Added with DG*5.3*754
IF DGPAT("EC")="Y"
Begin DoDot:1
+28 if EGTENR("ELIG","EC")'="Y"
QUIT
+29 SET STAEXP=$$STAEXP^DGENELA4("EC")
if STAEXP<1
QUIT
+30 IF EGTENR("EFFDATE")
IF EGTENR("EFFDATE")<STAEXP
SET RTN=1
End DoDot:1
IF $GET(RTN)
QUIT RTN
+31 ; If combat vet end date is before application date, cont. enroll
+32 IF $GET(EGTENR("ELIG","CVELEDT"))'<ENRDT
QUIT 1
+33 ; If veteran is enrolled due to MT status or Medicaid, cont. enroll
+34 ; UNLESS first verified enrollment record is due to MT status or
+35 ; Medicaid and the primary MT of that income year was changed to a
+36 ; status that would not enroll (e.g. due to IVM converted test,
+37 ; Hardship removal, or Medicaid removal).
+38 IF ((EGTENR("PRIORITY")=7!EGTENR("PRIORITY")=8)&("^2^16^"[(U_EGTENR("ELIG","MTSTA")_U)))!((EGTENR("PRIORITY")=5)&((EGTENR("ELIG","MTSTA")=4)!(EGTENR("ELIG","MEDICAID")=1)))
SET RTN=1
Begin DoDot:1
+39 NEW ENIEN,ENR,MTDT,MTIEN
+40 SET ENIEN=0
FOR
SET ENIEN=$ORDER(^DGEN(27.11,"C",+DPTDFN,ENIEN))
if 'ENIEN
QUIT
IF $PIECE($GET(^DGEN(27.11,+ENIEN,0)),U,4)=2
Begin DoDot:2
+41 IF '$$GET^DGENA(ENIEN,.ENR)
QUIT
+42 IF ((ENR("PRIORITY")=7!ENR("PRIORITY")=8)&("^2^16^"[(U_ENR("ELIG","MTSTA")_U)))!((ENR("PRIORITY")=5)&(ENR("ELIG","VAPEN")'="Y")&((ENR("ELIG","MTSTA")=4)!(ENR("ELIG","MEDICAID")=1)))
Begin DoDot:3
+43 SET MTDT=$EXTRACT(ENR("APP"),1,3)_"1231"
SET MTIEN=$$LST^DGMTU(MTDT)
if 'MTIEN
QUIT
+44 IF $PIECE($GET(^DGMT(408.31,MTIEN,0)),U,3)=6
SET RTN=-1
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
QUIT RTN
+45 QUIT 0
+46 ;
EDATE(APP,EFF) ; Compare the Application Date and Effective Date and
+1 ; return the earlier date
+2 NEW EDT
+3 SET APP=$GET(APP)
SET EFF=$GET(EFF)
+4 SET EDT=APP
IF 'EDT
SET EDT=EFF
QUIT EDT
+5 IF EFF
if EFF<EDT
SET EDT=EFF
+6 QUIT EDT
