- 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 Jan 18, 2025@03:43:18 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