Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENEGT1

DGENEGT1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. NOTIFY(DGEGT,OLDEGT) ;
  1. ; Description: This is used to send a message to local mail group.
  1. ; The notification is used to communicate changes in the Enrollment
  1. ; Group Threshold (EGT) setting to users at the local site.
  1. ;
  1. ; Input:
  1. ; DGEGT - the new Enrollment Group Threshold array, passed by reference
  1. ; OLDEGT - the previous Enrollment Group Threshold array, passed by reference
  1. ;
  1. ; Output: None
  1. ;
  1. N TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI
  1. ;
  1. ; init subject and sender
  1. S XMSUB="Enrollment Group Threshold (EGT) Changed"
  1. S (XMDUN,XMDUZ)="Registration Enrollment Module"
  1. ;
  1. ; recipient
  1. S XMY("G.DGEN EGT UPDATES")=""
  1. ;
  1. ; get old EGT priority
  1. S OLDPRI=$G(OLDEGT("PRIORITY"))
  1. ;
  1. S XMTEXT="TEXT("
  1. S TEXT(1)="The Secretary of the VA has officially changed the enrollment priority"
  1. S TEXT(2)="grouping of veterans who shall receive care. This change may place"
  1. S TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category."
  1. S TEXT(4)=""
  1. S TEXT(5)=""
  1. 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:"")
  1. S TEXT(7)=""
  1. S TEXT(8)=""
  1. S TEXT(9)=" New Enrollment Group Threshold (EGT) Settings:"
  1. S TEXT(10)=""
  1. 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:"")
  1. S TEXT(12)=" EGT Type: "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))
  1. S TEXT(13)=" EGT Effective Date: "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE"))
  1. ;
  1. ; mailman deliverey
  1. D ^XMD
  1. ;
  1. Q
  1. ;
  1. ;
  1. DISPLAY() ;
  1. ; Description: Display Enrollment Group Threshold (EGT) settings.
  1. ;
  1. N DGEGT
  1. ;
  1. W !
  1. I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT) W !,"Enrollment Group Threshold (EGT) settings not found."
  1. E D
  1. .W !,?3,"Enrollment Group Threshold (EGT) Settings"
  1. .W !,?3,"========================================="
  1. .W !
  1. .W !?5,"Date Entered",?25,": ",$S('$G(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED")))
  1. .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")))
  1. .W !?5,"EGT Type",?25,": ",$S($G(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")))
  1. .W !?5,"EGT Effective Date",?25,": ",$S('$G(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE")))
  1. ;
  1. Q
  1. ;
  1. ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ;
  1. ; Description: This function will determine if the enrollment is above
  1. ; the threshold.
  1. ;
  1. ;Input:
  1. ; DPTDFN - Patient File IEN
  1. ; ENRPRI - Enrollment Priority
  1. ; ENRGRP - Enrollment Sub-Group
  1. ; EGTPRI - EGT Priority (optional) - not used
  1. ; EGTGRP - EGT Sub-Group (optional) - not used
  1. ; EGTFLG - Flag to bypass additional EGT type 2 check (optional)
  1. ; It is used by $$ABOVE2 to prevent re-entering the
  1. ; sub-priority API ($$SUBPRI^DGENELA4)
  1. ; Output:
  1. ; Returns 1 if above 0 below.
  1. ;
  1. I $G(ENRGRP)="" S ENRGRP=""
  1. I $G(ENRPRI)="" S ENRPRI=""
  1. N ABOVE,EGT,TODAY,X
  1. I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) Q 1
  1. D NOW^%DTC S TODAY=X
  1. I TODAY<EGT("EFFDATE") Q 1
  1. ;
  1. ;EGT type 2 - Stop New Enrollments
  1. ; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491)
  1. I EGT("TYPE")=2!(EGT("TYPE")=4) D Q ABOVE
  1. .S ABOVE=0
  1. .I ENRPRI<7 D Q
  1. ..I ENRPRI'>EGT("PRIORITY") S ABOVE=1 Q
  1. .;do check for priorities 7 and 8
  1. .I ENRPRI<EGT("PRIORITY") S ABOVE=1 Q
  1. .I ENRGRP'>EGT("SUBGRP") S ABOVE=1 Q
  1. .I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1
  1. ;
  1. ;EGT types 1 & 3
  1. ;do check for priorities 7 and 8
  1. I ENRPRI>6&(ENRPRI=EGT("PRIORITY")) S ABOVE=0 D Q ABOVE
  1. .I ENRGRP'>(EGT("SUBGRP")) S ABOVE=1
  1. I ENRPRI'>(EGT("PRIORITY")) Q 1
  1. Q 0
  1. ;
  1. ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ;
  1. ;
  1. ; Input: DPTDFN - Patient File IEN
  1. ; ENRDT - enrollment effective date
  1. ; PRIORITY - enrollment priority
  1. ; SUBGRP - enrollment sub-priority (internal numeric value)
  1. ;
  1. ; Output: 1 or 0 for above or below EGT threshold
  1. ;
  1. N ABOVE,TODAY,X,EGT
  1. S ABOVE=1
  1. S:'$G(SUBGRP) SUBGRP=""
  1. S:'$G(PRIORITY) PRIORITY=""
  1. S:'$G(ENRDT) ENRDT=""
  1. D NOW^%DTC S TODAY=X
  1. Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1
  1. Q:'$G(EGT("EFFDATE")) 1
  1. Q:TODAY<EGT("EFFDATE") 1
  1. Q:EGT("TYPE")#2 $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) ;If EGT type 1 or 3
  1. I '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) Q 0
  1. Q ABOVE
  1. ;
  1. OVRRIDE(DPTDFN,EGT) ;check for previous EGT override by HEC and new rules
  1. N CVDT,ENRCAT,ENRDT,EGTENR,ENRIEN,DGPAT,STOP,CUR,CE
  1. S (STOP,CUR)=0
  1. I '$$GET^DGENELA(DPTDFN,.DGPAT) Q 0 ;Get current Patient file data
  1. ; Find most recent enrollment record
  1. S ENRIEN=$$FINDCUR^DGENA(.DPTDFN)
  1. F Q:STOP!CUR D
  1. .I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
  1. .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
  1. .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
  1. .; If status is Pending, Deceased, Not Eligible, or Not Applicable
  1. .; ignore record and get previous
  1. .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
  1. .S CUR=1
  1. I STOP Q 0
  1. S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
  1. S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
  1. ; If enrollment status was overridden at HEC, then cont. enroll.
  1. I EGTENR("SOURCE")=2,ENRDT'<EGT("EFFDATE"),ENRCAT="E" Q 1
  1. ; DG*5.3*1111 - ENROLLMENT STATUS (file #27.15) entries of REJECTED renamed to DEFERRED. Modified comment below.
  1. ; If status is Deferred or Cancelled/Declined, quit (no cont. enroll.)
  1. I "^4^7^11^12^13^22^"[(U_EGTENR("STATUS")_U) Q 0
  1. ; If Application Date or Effective Date of Change are prior to the
  1. ; EGT Effective Date then cont. enroll.
  1. I ENRDT<EGT("EFFDATE") Q 1
  1. ; If Enrollment Record is Verified, and meets one of the special CE
  1. ; rules, then cont. enroll.
  1. I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE Q CE>0
  1. ; Check previous enrollment records for Application Date/Effective
  1. ; Date and special CE rules
  1. S (STOP,CE)=0
  1. F Q:STOP D
  1. .I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment
  1. .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed
  1. .S ENRIEN=$$FINDPRI^DGENA(ENRIEN)
  1. .; If status is Pending, Deceased, Not Eligible; Ineligible Date,
  1. .; or Not Applicable ignore record and get previous
  1. .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q
  1. .S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT
  1. .S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2)
  1. .; If Application Date or Effective Date of Change are prior to the
  1. .; EGT Effective Date then cont. enroll.
  1. .I ENRDT<EGT("EFFDATE") S (STOP,CE)=1 Q
  1. .; If Enrollment Record is Verified, and meets one of the special CE
  1. .; rules, then cont. enroll.
  1. .I ENRCAT="E" S CE=$$RULES(DPTDFN,.EGTENR,.EGT,.DGPAT) I CE S STOP=1,CE=CE>0 Q
  1. Q CE
  1. ;
  1. RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672)
  1. N RTN,STAEXP
  1. ; If veteran ever had a verified enrollment with SC 10%+ and is now
  1. ; SC 0% non-compensable then cont. enroll
  1. I EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0) Q 1
  1. ; If veteran ever had a verified enrollment with one of these
  1. ; eligibilities then cont. enroll: AA, HB, VA Pension
  1. I EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")) Q 1
  1. ; If AO Exposure Location = Korean DMZ prior to ESR implementation,
  1. ; or AO Exposure Location = Vietnam prior to Special Treatment
  1. ; Authority (STA) termination
  1. ; then cont. enroll.
  1. ; **** NOTE: For patch DG*5.3*672 the ESR implementation date will
  1. ; be set to 12/29/2040. This will be changed to the actual ESR
  1. ; implementation date in a later patch.
  1. ; DG*5.3*688 - Date changed to 3/21/2009
  1. I DGPAT("AO")="Y" D I $G(RTN) Q RTN
  1. .I $S($D(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K",EGTENR("EFFDATE"),EGTENR("EFFDATE")<3090321 S RTN=1
  1. .;I (EGTENR("ELIG","AOEXPLOC")="V" D ;Added with DG*5.3*754
  1. .; DG*5.3*1018;KUM - Added Blue Water Navy check
  1. .;I ((EGTENR("ELIG","AOEXPLOC")="V")!(EGTENR("ELIG","AOEXPLOC")="B")) D ;Added with DG*5.3*754
  1. .; 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
  1. .I EGTENR("ELIG","AOEXPLOC")'="","VBTLCJG"[EGTENR("ELIG","AOEXPLOC") D ;Check exposure locations using initials
  1. ..S STAEXP=$$STAEXP^DGENELA4("AO") Q:STAEXP<1
  1. ..I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
  1. ; If SWAC/EC = YES prior to Special Treatment (STA) termination
  1. ; then cont. enroll.
  1. I DGPAT("EC")="Y" D I $G(RTN) Q RTN ;Added with DG*5.3*754
  1. .Q:EGTENR("ELIG","EC")'="Y"
  1. .S STAEXP=$$STAEXP^DGENELA4("EC") Q:STAEXP<1
  1. .I EGTENR("EFFDATE"),EGTENR("EFFDATE")<STAEXP S RTN=1
  1. ; If combat vet end date is before application date, cont. enroll
  1. I $G(EGTENR("ELIG","CVELEDT"))'<ENRDT Q 1
  1. ; If veteran is enrolled due to MT status or Medicaid, cont. enroll
  1. ; UNLESS first verified enrollment record is due to MT status or
  1. ; Medicaid and the primary MT of that income year was changed to a
  1. ; status that would not enroll (e.g. due to IVM converted test,
  1. ; Hardship removal, or Medicaid removal).
  1. 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
  1. .N ENIEN,ENR,MTDT,MTIEN
  1. .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
  1. ..I '$$GET^DGENA(ENIEN,.ENR) Q
  1. ..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
  1. ...S MTDT=$E(ENR("APP"),1,3)_"1231",MTIEN=$$LST^DGMTU(MTDT) Q:'MTIEN
  1. ...I $P($G(^DGMT(408.31,MTIEN,0)),U,3)=6 S RTN=-1
  1. Q 0
  1. ;
  1. EDATE(APP,EFF) ; Compare the Application Date and Effective Date and
  1. ; return the earlier date
  1. N EDT
  1. S APP=$G(APP),EFF=$G(EFF)
  1. S EDT=APP I 'EDT S EDT=EFF Q EDT
  1. I EFF S:EFF<EDT EDT=EFF
  1. Q EDT