DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM,JLS,HM,RN,ARF,JAM - Patient Eligibility API ;5/10/11 12:03pm
;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,803,754,841,909,972,952,993,1018,1090,1098,1103,1109**;Aug 13,1993;Build 13
;
;
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE,DGENRYN) ; DG*5.3*993 Added 6th parameter DGENRYN
; Description: Used to compute the priority group and subgroup for a
; patient, also returning the subset of the eligibility data on which
; the priority subgroup is based.
;
;Input:
; DFN - ien of patient
; DGELG - ELIGIBILITY object array (optional, pass by reference)
; ENRDATE - The Enrollment Date. This date is used in the priority
; determination only if the application date is not passed.
; APPDATE - The Enrollment Application Date. This date is used
; to determine the priority. If the application date
; is not passed then the enrollment date (ENRDATE) is used.
; DGENRYN - (Optinal) ENROLL Y/N question for registration 0=NO 1=YES DG*5.3*993
;
;Output:
; Function Value - returns the priority and subgroup computed by the
; function as a 2 piece string 'PRIORITY^SUBGROUP'
; DGELGSUB - this local array will contain the eligibility data on
; which the priority determination was based, pass by reference
; if needed.
;
N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
K DGELGSUB S DGELGSUB=""
S (HICODE,HIPRI,SUBGRP,HISUB)=""
D
.I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;cannot proceed with eligibility
.; can't proceed without an Enrollment Date or Application Date
.I '$G(ENRDATE),'$G(APPDATE) Q
.I $$GET^DGENPTA(DFN,.DGPAT)
.; determine priority/subgroup based on primary eligibility
.S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
.S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE),$G(DGENRYN)) ; DG*5.3*993 Added 5th parameter DGENRYN
.S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
.S CODE=""
.;
.; determine if other eligibilities result in higher priority/subgroup
.F S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1)) D
..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE),$G(DGENRYN)) ; DG*5.3*993 Added 5th parameter DGENRYN
..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
.;
.;set the DGELGSUB() array with the eligibility information used in the
.;priority determination
.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")
.S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
.S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
.;Purple Heart Added to DGELGSUB
.S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
.;Added for HVE Phase III (DG*5.3*564)
.S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
.;added dg*5.3*659
.S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
.S DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
.S DGELGSUB("MOH")=DGELG("MOH")
.S DGELGSUB("MOHAWRDDATE")=DGELG("MOHAWRDDATE") ;added with DG*5.3*972 HM
.S DGELGSUB("MOHSTATDATE")=DGELG("MOHSTATDATE") ;added with DG*5.3*972 HM
.S DGELGSUB("MOHEXEMPDATE")=DGELG("MOHEXEMPDATE") ;added with DG*5.3*972 HM
.S DGELGSUB("CLE")=DGELG("CLE") ;added with DG*5.3*909
.S DGELGSUB("CLEDT")=DGELG("CLEDT") ;added with DG*5.3*909
.S DGELGSUB("CLEST")=DGELG("CLEST") ;added with DG*5.3*909
.S DGELGSUB("CLESOR")=DGELG("CLESOR") ;added with DG*5.3*909
.S DGELGSUB("OTHTYPE")=DGELG("OTHTYPE") ; DG*5.3*952
.I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
;
Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
;
;
PRI(CODE,DGELG,ENRDATE,APPDATE,DGENRYN) ; DG*5.3*993 Added 5th parameter DGENRYN
; Description: Returns the priority group and subgroup based on a
; single eligibility code.
;Input -
; CODE - pointer to file #8.1, MAS Eligibility Code
; DGELG - local array obtained by calling $$GET, pass by reference
; ENRDATE - The Enrollment Date. This date is used in the priority
; determination only if the application date is not passed.
; APPDATE - The Enrollment Application Date. This date is used
; to determine the priority. If the application date
; is not passed then the enrollment date (ENRDATE) is used.
; DGENRYN (Optional) ENROLL Y/N question for registration 0=NO 1=YES
;
;Output -
; Function Value - returns the priority and subgroup computed by the
; function as a 2 piece string 'PRIORITY^SUBGROUP'
;
N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
N NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2,DGAICM,DGENRIEN,DGTERA
S SUBGRP=""
;DG*5.3*993 If parameter DGENRYN is blank (null) or does not exist, populate it using the
; PT APPLIED FOR ENROLLMENT? field (#.14) in the PATIENT ENROLLMENT file (#27.11)
; if a record exists in file #27.11 for this patient.
S DGENRYN=$G(DGENRYN) I DGENRYN="" S DGENRIEN=$$FINDCUR^DGENA(DFN) I DGENRIEN S DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I")
I DGENRYN=0,$$GET1^DIQ(2,DFN_",",.351)="" Q "" ;If ENROLL is NO, and patient is not deceased return null
;End of DG*5.3*993 mods
;
; use the Application Date when determining the priority, otherwise use
; the Enrollment Date (ESP DG*5,3*491)
S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
;
;get the name of the national eligibility code
S CODENAME=$$CODENAME^DGENELA(CODE)
;
;get the means test code
S MTSTA=""
I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
;
;get MT and GMT thresholds
S DGMTI=$P($$LST^DGMTU(DFN),"^")
S MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
S GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
S DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
S DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
D ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
S DGAICM=0
S:$G(DGINC("V")) DGAICM=+DGINC("V")
S (DGMEDEX,DGEDEX,DGASSTS)=0
S DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
I $D(^DGMT(408.21,DGAICM,2)) D
.S NODE2=^DGMT(408.21,DGAICM,2)
.S DGASSTS=DGASSTS+$P(NODE2,U,1)+$P(NODE2,U,2)+$P(NODE2,U,3)+$P(NODE2,U,4)-$P(NODE2,U,5)
.S DGASSTS=DGASSTS+$P(NODE2,U,6)+$P(NODE2,U,7)+$P(NODE2,U,8)+$P(NODE2,U,9)
S:$D(^DGMT(408.21,DGAICM,1)) DGMEDEX=$P(^DGMT(408.21,DGAICM,1),"^",12)
S:$D(^DGMT(408.21,DGAICM,1)) DGEDEX=$P(^DGMT(408.21,DGAICM,1),"^",3)
;
; get expiration dates for Special Treatment Authority
S STAEXP("AO")=$$STAEXP^DGENELA4("AO")
S STAEXP("EC")=$$STAEXP^DGENELA4("EC")
;
;get the Enrollment Group Threshold (EGT) setting
S DGEGT=""
I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
I '$G(DGELG("RADEXPM")) S DGELG("RADEXPM")=""
I '$G(DGELG("SHAD")) S DGELG("SHAD")=""
;
; DG*5.3*1103 - get the TERA indicator (TOXIC EXPOSURE RISK ACTIVITY #.32116) field of PATIENT (#2) file
S DGTERA=$$GET1^DIQ(2,DFN,.32116,"I")
;
D ;drops out when priority determined
.S PRIORITY=""
.I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
.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
.I (DGELG("MOH")="Y")&(DGPAT("VETERAN")="Y") S PRIORITY=1 Q ;Added for DG*5.3*841 added I DGELG("MOH")="Y" S PRIORITY=1 DG*5.3*972 HM
.I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
.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
.I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
.I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
.; DG*5.3*1103 - set PRIORITY group 6 for TERA indicator Veterans
.I DGTERA=1 S PRIORITY=6 Q
.; DG*5.3*1098 - add the additional WORLD WAR II eligibility for PRIORITY group 6
.I (CODENAME="WORLD WAR II")!(CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
.I DGELG("EC")="Y" I (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC")) S PRIORITY=6 Q
.;DG*5.3*1090 - add additional values for RADIATION EXPOSURE METHOD field (#27.11,76) for PRIORITY 6; 8 for ENEWETAK, 9 for EXPOS IN PALOMARES B52, 10 for THULE AFB B52
.;I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
.I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4)!(DGELG("RADEXPM")=8)!(DGELG("RADEXPM")=9)!(DGELG("RADEXPM")=10) S PRIORITY=6 Q
.; DG*5.3*1018 - Add "B" - Blue Water Navy Value
.; DG*5.3*1090 - Add additional Agent Orange Exposure Locations - 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 (DGELG("AO")="Y") D Q:(PRIORITY=6) ;DG*5.3*1090 begin
..I (DGELG("AOEXPLOC")'=""),("VBTLCJG"[DGELG("AOEXPLOC")) D ;Check for the initials of the exposure locations
...I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 ;DG*5.3*1090 end
.I DGELG("CLE")="Y" S PRIORITY=6 Q ; Added for DG*5.3*909 Camp Lejeune
.I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D Q
..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
.S MTTEST1=MTTHR
.I GMTTHR>MTTHR S MTTEST1=GMTTHR
.S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold
.I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
.I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
.I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
.I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
.I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
.I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
;
Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
;
SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
;
N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
Q:'$G(DFN)
S U="^"
S:$G(PRIORITY)="" PRIORITY=""
S:$G(SUBGRP)="" SUBGRP=""
D NOW^%DTC S TODAY=X
Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set
Q:TODAY<EGT("EFFDATE") SUBGRP ;EGT is not in effect
I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
S DGENRIEN=$$FINDCUR^DGENA(DFN)
I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
S DONE=0
F Q:DONE D
.I 'DGENRIEN S DONE=2 Q
.I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
.S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
.Q:DGENRC("STATUS")=6 ;deceased
.I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
.S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
.I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
.; HEC is the authoritative source on continuous enrollment
.I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
;
Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
;
SUBCNV(SUBGRP) ;return new subgrp
; DG*5.3*1109 - If there is a Combat End Date we do not flip the subgroups. Combat Vets do not get the reduced subgroup
I $G(DGELG("CVELEDT"))'="" Q SUBGRP
I SUBGRP=1 Q 5
I SUBGRP=3 Q 7
Q SUBGRP
;
STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
;Input -
; STATYP - STA Type (Only AO & EC (SWAC) currently supported)
;
;Output -
; Function Value - returns the requested expiration date from the
; MAS PARAMETERS file (#43), otherwise returns 0
;
I STATYP="AO" Q +$P($G(^DG(43,1,"ENR")),U,1) ;AO Exp Dt
I STATYP="EC" Q +$P($G(^DG(43,1,"ENR")),U,2) ;EC (SWAC) Exp Dt
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENELA4 12856 printed Dec 13, 2024@02:42:44 Page 2
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM,JLS,HM,RN,ARF,JAM - Patient Eligibility API ;5/10/11 12:03pm
+1 ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,803,754,841,909,972,952,993,1018,1090,1098,1103,1109**;Aug 13,1993;Build 13
+2 ;
+3 ;
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE,DGENRYN) ; DG*5.3*993 Added 6th parameter DGENRYN
+1 ; Description: Used to compute the priority group and subgroup for a
+2 ; patient, also returning the subset of the eligibility data on which
+3 ; the priority subgroup is based.
+4 ;
+5 ;Input:
+6 ; DFN - ien of patient
+7 ; DGELG - ELIGIBILITY object array (optional, pass by reference)
+8 ; ENRDATE - The Enrollment Date. This date is used in the priority
+9 ; determination only if the application date is not passed.
+10 ; APPDATE - The Enrollment Application Date. This date is used
+11 ; to determine the priority. If the application date
+12 ; is not passed then the enrollment date (ENRDATE) is used.
+13 ; DGENRYN - (Optinal) ENROLL Y/N question for registration 0=NO 1=YES DG*5.3*993
+14 ;
+15 ;Output:
+16 ; Function Value - returns the priority and subgroup computed by the
+17 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
+18 ; DGELGSUB - this local array will contain the eligibility data on
+19 ; which the priority determination was based, pass by reference
+20 ; if needed.
+21 ;
+22 NEW CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
+23 KILL DGELGSUB
SET DGELGSUB=""
+24 SET (HICODE,HIPRI,SUBGRP,HISUB)=""
+25 Begin DoDot:1
+26 ;cannot proceed with eligibility
IF '$DATA(DGELG)
IF '$$GET^DGENELA(DFN,.DGELG)
QUIT
+27 ; can't proceed without an Enrollment Date or Application Date
+28 IF '$GET(ENRDATE)
IF '$GET(APPDATE)
QUIT
+29 IF $$GET^DGENPTA(DFN,.DGPAT)
+30 ; determine priority/subgroup based on primary eligibility
+31 SET HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
+32 ; DG*5.3*993 Added 5th parameter DGENRYN
SET PRIORITY=$$PRI(HICODE,.DGELG,$GET(ENRDATE),$GET(APPDATE),$GET(DGENRYN))
+33 SET HIPRI=$PIECE(PRIORITY,"^")
SET HISUB=$PIECE(PRIORITY,"^",2)
+34 SET CODE=""
+35 ;
+36 ; determine if other eligibilities result in higher priority/subgroup
+37 FOR
SET CODE=$ORDER(DGELG("ELIG","CODE",CODE))
if ('CODE!(HIPRI=1))
QUIT
Begin DoDot:2
+38 ; DG*5.3*993 Added 5th parameter DGENRYN
SET PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$GET(ENRDATE),$GET(APPDATE),$GET(DGENRYN))
+39 SET PRI=$PIECE(PRIORITY,"^")
SET SUB=$PIECE(PRIORITY,"^",2)
+40 if ((PRI>0)&((PRI<HIPRI)!(HIPRI="")))
SET HIPRI=PRI
SET HICODE=$$NATCODE^DGENELA(CODE)
SET HISUB=SUB
+41 if ((PRI=HIPRI)&((SUB>0)&(SUB<HISUB)))
SET HIPRI=PRI
SET HICODE=$$NATCODE^DGENELA(CODE)
SET HISUB=SUB
End DoDot:2
+42 ;
+43 ;set the DGELGSUB() array with the eligibility information used in the
+44 ;priority determination
+45 SET DGELGSUB("CODE")=HICODE
SET DGELGSUB("SC")=DGELG("SC")
SET DGELGSUB("SCPER")=DGELG("SCPER")
SET DGELGSUB("POW")=DGELG("POW")
SET DGELGSUB("A&A")=DGELG("A&A")
SET DGELGSUB("HB")=DGELG("HB")
+46 SET DGELGSUB("VAPEN")=DGELG("VAPEN")
SET DGELGSUB("VACKAMT")=DGELG("VACKAMT")
SET DGELGSUB("DISRET")=DGELG("DISRET")
SET DGELGSUB("DISLOD")=DGELG("DISLOD")
+47 SET DGELGSUB("MEDICAID")=DGELG("MEDICAID")
SET DGELGSUB("AO")=DGELG("AO")
SET DGELGSUB("IR")=DGELG("IR")
SET DGELGSUB("EC")=DGELG("EC")
SET DGELGSUB("MTSTA")=DGELG("MTSTA")
+48 ;Purple Heart Added to DGELGSUB
+49 SET DGELGSUB("VCD")=DGELG("VCD")
SET DGELGSUB("PH")=DGELG("PH")
+50 ;Added for HVE Phase III (DG*5.3*564)
+51 SET DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY")
SET DGELGSUB("CVELEDT")=DGELG("CVELEDT")
SET DGELGSUB("SHAD")=DGELG("SHAD")
+52 ;added dg*5.3*659
+53 SET DGELGSUB("RADEXPM")=DGELG("RADEXPM")
+54 SET DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
+55 SET DGELGSUB("MOH")=DGELG("MOH")
+56 ;added with DG*5.3*972 HM
SET DGELGSUB("MOHAWRDDATE")=DGELG("MOHAWRDDATE")
+57 ;added with DG*5.3*972 HM
SET DGELGSUB("MOHSTATDATE")=DGELG("MOHSTATDATE")
+58 ;added with DG*5.3*972 HM
SET DGELGSUB("MOHEXEMPDATE")=DGELG("MOHEXEMPDATE")
+59 ;added with DG*5.3*909
SET DGELGSUB("CLE")=DGELG("CLE")
+60 ;added with DG*5.3*909
SET DGELGSUB("CLEDT")=DGELG("CLEDT")
+61 ;added with DG*5.3*909
SET DGELGSUB("CLEST")=DGELG("CLEST")
+62 ;added with DG*5.3*909
SET DGELGSUB("CLESOR")=DGELG("CLESOR")
+63 ; DG*5.3*952
SET DGELGSUB("OTHTYPE")=DGELG("OTHTYPE")
+64 IF $GET(DGPAT("INELDATE"))'=""
SET (HIPRI,HISUB)=""
End DoDot:1
+65 ;
+66 QUIT HIPRI_$SELECT(HIPRI:"^"_HISUB,1:"")
+67 ;
+68 ;
PRI(CODE,DGELG,ENRDATE,APPDATE,DGENRYN) ; DG*5.3*993 Added 5th parameter DGENRYN
+1 ; Description: Returns the priority group and subgroup based on a
+2 ; single eligibility code.
+3 ;Input -
+4 ; CODE - pointer to file #8.1, MAS Eligibility Code
+5 ; DGELG - local array obtained by calling $$GET, pass by reference
+6 ; ENRDATE - The Enrollment Date. This date is used in the priority
+7 ; determination only if the application date is not passed.
+8 ; APPDATE - The Enrollment Application Date. This date is used
+9 ; to determine the priority. If the application date
+10 ; is not passed then the enrollment date (ENRDATE) is used.
+11 ; DGENRYN (Optional) ENROLL Y/N question for registration 0=NO 1=YES
+12 ;
+13 ;Output -
+14 ; Function Value - returns the priority and subgroup computed by the
+15 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
+16 ;
+17 NEW CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
+18 NEW NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2,DGAICM,DGENRIEN,DGTERA
+19 SET SUBGRP=""
+20 ;DG*5.3*993 If parameter DGENRYN is blank (null) or does not exist, populate it using the
+21 ; PT APPLIED FOR ENROLLMENT? field (#.14) in the PATIENT ENROLLMENT file (#27.11)
+22 ; if a record exists in file #27.11 for this patient.
+23 SET DGENRYN=$GET(DGENRYN)
IF DGENRYN=""
SET DGENRIEN=$$FINDCUR^DGENA(DFN)
IF DGENRIEN
SET DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I")
+24 ;If ENROLL is NO, and patient is not deceased return null
IF DGENRYN=0
IF $$GET1^DIQ(2,DFN_",",.351)=""
QUIT ""
+25 ;End of DG*5.3*993 mods
+26 ;
+27 ; use the Application Date when determining the priority, otherwise use
+28 ; the Enrollment Date (ESP DG*5,3*491)
+29 SET ENRDATE=$SELECT($GET(APPDATE):APPDATE,1:$GET(ENRDATE))
+30 ;
+31 ;get the name of the national eligibility code
+32 SET CODENAME=$$CODENAME^DGENELA(CODE)
+33 ;
+34 ;get the means test code
+35 SET MTSTA=""
+36 IF DGELG("MTSTA")
SET MTSTA=$PIECE($GET(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
+37 ;
+38 ;get MT and GMT thresholds
+39 SET DGMTI=$PIECE($$LST^DGMTU(DFN),"^")
+40 SET MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
+41 SET GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
+42 SET DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
+43 SET DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
+44 DO ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
+45 SET DGAICM=0
+46 if $GET(DGINC("V"))
SET DGAICM=+DGINC("V")
+47 SET (DGMEDEX,DGEDEX,DGASSTS)=0
+48 SET DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
+49 IF $DATA(^DGMT(408.21,DGAICM,2))
Begin DoDot:1
+50 SET NODE2=^DGMT(408.21,DGAICM,2)
+51 SET DGASSTS=DGASSTS+$PIECE(NODE2,U,1)+$PIECE(NODE2,U,2)+$PIECE(NODE2,U,3)+$PIECE(NODE2,U,4)-$PIECE(NODE2,U,5)
+52 SET DGASSTS=DGASSTS+$PIECE(NODE2,U,6)+$PIECE(NODE2,U,7)+$PIECE(NODE2,U,8)+$PIECE(NODE2,U,9)
End DoDot:1
+53 if $DATA(^DGMT(408.21,DGAICM,1))
SET DGMEDEX=$PIECE(^DGMT(408.21,DGAICM,1),"^",12)
+54 if $DATA(^DGMT(408.21,DGAICM,1))
SET DGEDEX=$PIECE(^DGMT(408.21,DGAICM,1),"^",3)
+55 ;
+56 ; get expiration dates for Special Treatment Authority
+57 SET STAEXP("AO")=$$STAEXP^DGENELA4("AO")
+58 SET STAEXP("EC")=$$STAEXP^DGENELA4("EC")
+59 ;
+60 ;get the Enrollment Group Threshold (EGT) setting
+61 SET DGEGT=""
+62 IF $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
+63 IF '$GET(DGELG("RADEXPM"))
SET DGELG("RADEXPM")=""
+64 IF '$GET(DGELG("SHAD"))
SET DGELG("SHAD")=""
+65 ;
+66 ; DG*5.3*1103 - get the TERA indicator (TOXIC EXPOSURE RISK ACTIVITY #.32116) field of PATIENT (#2) file
+67 SET DGTERA=$$GET1^DIQ(2,DFN,.32116,"I")
+68 ;
+69 ;drops out when priority determined
Begin DoDot:1
+70 SET PRIORITY=""
+71 IF ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%")
SET PRIORITY=1
QUIT
+72 IF (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y")
SET PRIORITY=1
QUIT
+73 ;Added for DG*5.3*841 added I DGELG("MOH")="Y" S PRIORITY=1 DG*5.3*972 HM
IF (DGELG("MOH")="Y")&(DGPAT("VETERAN")="Y")
SET PRIORITY=1
QUIT
+74 IF ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%"))
SET PRIORITY=2
QUIT
+75 IF ((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")
SET PRIORITY=3
QUIT
+76 IF (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y")
SET PRIORITY=4
QUIT
+77 IF (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION")
SET PRIORITY=5
QUIT
+78 ; DG*5.3*1103 - set PRIORITY group 6 for TERA indicator Veterans
+79 IF DGTERA=1
SET PRIORITY=6
QUIT
+80 ; DG*5.3*1098 - add the additional WORLD WAR II eligibility for PRIORITY group 6
+81 IF (CODENAME="WORLD WAR II")!(CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1)
SET PRIORITY=6
QUIT
+82 IF DGELG("EC")="Y"
IF (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC"))
SET PRIORITY=6
QUIT
+83 ;DG*5.3*1090 - add additional values for RADIATION EXPOSURE METHOD field (#27.11,76) for PRIORITY 6; 8 for ENEWETAK, 9 for EXPOS IN PALOMARES B52, 10 for THULE AFB B52
+84 ;I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
+85 IF DGELG("IR")="Y"
IF (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4)!(DGELG("RADEXPM")=8)!(DGELG("RADEXPM")=9)!(DGELG("RADEXPM")=10)
SET PRIORITY=6
QUIT
+86 ; DG*5.3*1018 - Add "B" - Blue Water Navy Value
+87 ; DG*5.3*1090 - Add additional Agent Orange Exposure Locations - T=THAILAND(U.S. OR ROYAL THAI MIL BASE), L=LAOS,
+88 ; C=CAMBODIA(MIMOT OR KREK,KAMPONG CHAM), G=GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS and J=JOHNSTON ATOLL
+89 ;DG*5.3*1090 begin
IF (DGELG("AO")="Y")
Begin DoDot:2
+90 ;Check for the initials of the exposure locations
IF (DGELG("AOEXPLOC")'="")
IF ("VBTLCJG"[DGELG("AOEXPLOC"))
Begin DoDot:3
+91 ;DG*5.3*1090 end
IF (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO"))
SET PRIORITY=6
End DoDot:3
End DoDot:2
if (PRIORITY=6)
QUIT
+92 ; Added for DG*5.3*909 Camp Lejeune
IF DGELG("CLE")="Y"
SET PRIORITY=6
QUIT
+93 IF (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR))
SET PRIORITY=7
Begin DoDot:2
+94 IF ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%"))
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,1)
QUIT
+95 SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
End DoDot:2
QUIT
+96 SET MTTEST1=MTTHR
+97 IF GMTTHR>MTTHR
SET MTTEST1=GMTTHR
+98 ; Add 10% to the test threshold
SET MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01
+99 IF $$SC^DGMTR(DFN)
IF DGMTYR>2007
IF DGNCM>MTTEST1
IF MTTEST2>DGNCM
IF ENRDATE>3090614
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,2)
QUIT
+100 IF $$SC^DGMTR(DFN)
IF DGMTYR>2007
IF (DGNCM-DGMEDEX-DGEDEX)<MTTHR
IF DGNCM+DGNETW>79999.99
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,2)
QUIT
+101 IF DGELG("SC")="N"
IF DGMTYR>2007
IF DGNCM>MTTEST1
IF MTTEST2>DGNCM
IF ENRDATE>3090614
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,4)
QUIT
+102 IF DGELG("SC")="N"
IF DGMTYR>2007
IF (DGNCM-DGMEDEX-DGEDEX)<MTTHR
IF DGNCM+DGNETW>79999.99
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,4)
QUIT
+103 IF ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%"))
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,1)
QUIT
+104 IF ((MTSTA="C")!(MTSTA="P"))
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,PRIORITY,3)
QUIT
End DoDot:1
+105 ;
+106 QUIT PRIORITY_$SELECT(PRIORITY:"^"_SUBGRP,1:"")
+107 ;
SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
+1 ;
+2 NEW PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
+3 if '$GET(DFN)
QUIT
+4 SET U="^"
+5 if $GET(PRIORITY)=""
SET PRIORITY=""
+6 if $GET(SUBGRP)=""
SET SUBGRP=""
+7 DO NOW^%DTC
SET TODAY=X
+8 ;EGT isn't set
if '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT)
QUIT SUBGRP
+9 ;EGT is not in effect
if TODAY<EGT("EFFDATE")
QUIT SUBGRP
+10 IF "^1^3^"[(U_EGT("TYPE")_U)
QUIT SUBGRP
+11 IF EGT("TYPE")=2
IF (PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01))
QUIT SUBGRP
+12 IF EGT("TYPE")=4
if (PRIORITY<EGT("PRIORITY"))
QUIT SUBGRP
if (PRIORITY>EGT("PRIORITY"))
QUIT $$SUBCNV(SUBGRP)
+13 ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
+14 SET DGENRIEN=$$FINDCUR^DGENA(DFN)
+15 IF 'DGENRIEN
IF $GET(ENRDATE)
IF ENRDATE<EGT("EFFDATE")
QUIT SUBGRP
+16 SET DONE=0
+17 FOR
if DONE
QUIT
Begin DoDot:1
+18 IF 'DGENRIEN
SET DONE=2
QUIT
+19 IF '$$GET^DGENA(DGENRIEN,.DGENRC)
SET DONE=2
QUIT
+20 SET DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
+21 ;deceased
if DGENRC("STATUS")=6
QUIT
+22 IF $PIECE($GET(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N"
SET DONE=2
QUIT
+23 SET ENRDT=$GET(DGENRC("APP"))
if 'ENRDT
SET ENRDT=$GET(DGENRC("EFFDATE"))
+24 IF ENRDT
IF ENRDT<EGT("EFFDATE")
SET DONE=1
QUIT
+25 ; HEC is the authoritative source on continuous enrollment
+26 IF $$OVRRIDE^DGENEGT1(DFN,.EGT)
SET DONE=1
End DoDot:1
+27 ;
+28 QUIT $SELECT(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
+29 ;
SUBCNV(SUBGRP) ;return new subgrp
+1 ; DG*5.3*1109 - If there is a Combat End Date we do not flip the subgroups. Combat Vets do not get the reduced subgroup
+2 IF $GET(DGELG("CVELEDT"))'=""
QUIT SUBGRP
+3 IF SUBGRP=1
QUIT 5
+4 IF SUBGRP=3
QUIT 7
+5 QUIT SUBGRP
+6 ;
STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
+1 ;Input -
+2 ; STATYP - STA Type (Only AO & EC (SWAC) currently supported)
+3 ;
+4 ;Output -
+5 ; Function Value - returns the requested expiration date from the
+6 ; MAS PARAMETERS file (#43), otherwise returns 0
+7 ;
+8 ;AO Exp Dt
IF STATYP="AO"
QUIT +$PIECE($GET(^DG(43,1,"ENR")),U,1)
+9 ;EC (SWAC) Exp Dt
IF STATYP="EC"
QUIT +$PIECE($GET(^DG(43,1,"ENR")),U,2)
+10 QUIT 0
