DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM - Patient Eligibility API ; 11/10/09 10:48am
;;5.3;PIMS;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,1015,1016**;JUN 30, 2012;Build 20
;
;
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
; 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.
;
;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 ;can not 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))
.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))
..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")
.I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
;
Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
;
;
PRI(CODE,DGELG,ENRDATE,APPDATE) ;
; 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.
;
;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
S SUBGRP=""
;
; 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")=""
;
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("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
.I (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
.I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
.I (DGELG("AO")="Y"),(DGELG("AOEXPLOC"))="V" I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 Q
.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
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
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN,DLF,TDM - Patient Eligibility API ; 11/10/09 10:48am
+1 ;;5.3;PIMS;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653,688,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;
PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ;
+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 ;
+14 ;Output:
+15 ; Function Value - returns the priority and subgroup computed by the
+16 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
+17 ; DGELGSUB - this local array will contain the eligibility data on
+18 ; which the priority determination was based, pass by reference
+19 ; if needed.
+20 ;
+21 NEW CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
+22 KILL DGELGSUB
SET DGELGSUB=""
+23 SET (HICODE,HIPRI,SUBGRP,HISUB)=""
+24 Begin DoDot:1
+25 ;can not proceed with eligibility
IF '$DATA(DGELG)
IF '$$GET^DGENELA(DFN,.DGELG)
QUIT
+26 ; can't proceed without an Enrollment Date or Application Date
+27 IF '$GET(ENRDATE)
IF '$GET(APPDATE)
QUIT
+28 IF $$GET^DGENPTA(DFN,.DGPAT)
+29 ; determine priority/subgroup based on primary eligibility
+30 SET HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
+31 SET PRIORITY=$$PRI(HICODE,.DGELG,$GET(ENRDATE),$GET(APPDATE))
+32 SET HIPRI=$PIECE(PRIORITY,"^")
SET HISUB=$PIECE(PRIORITY,"^",2)
+33 SET CODE=""
+34 ;
+35 ; determine if other eligibilities result in higher priority/subgroup
+36 FOR
SET CODE=$ORDER(DGELG("ELIG","CODE",CODE))
IF ('CODE!(HIPRI=1))
QUIT
Begin DoDot:2
+37 SET PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$GET(ENRDATE),$GET(APPDATE))
+38 SET PRI=$PIECE(PRIORITY,"^")
SET SUB=$PIECE(PRIORITY,"^",2)
+39 IF ((PRI>0)&((PRI<HIPRI)!(HIPRI="")))
SET HIPRI=PRI
SET HICODE=$$NATCODE^DGENELA(CODE)
SET HISUB=SUB
+40 IF ((PRI=HIPRI)&((SUB>0)&(SUB<HISUB)))
SET HIPRI=PRI
SET HICODE=$$NATCODE^DGENELA(CODE)
SET HISUB=SUB
End DoDot:2
+41 ;
+42 ;set the DGELGSUB() array with the eligibility information used in the
+43 ;priority determination
+44 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")
+45 SET DGELGSUB("VAPEN")=DGELG("VAPEN")
SET DGELGSUB("VACKAMT")=DGELG("VACKAMT")
SET DGELGSUB("DISRET")=DGELG("DISRET")
SET DGELGSUB("DISLOD")=DGELG("DISLOD")
+46 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")
+47 ;Purple Heart Added to DGELGSUB
+48 SET DGELGSUB("VCD")=DGELG("VCD")
SET DGELGSUB("PH")=DGELG("PH")
+49 ;Added for HVE Phase III (DG*5.3*564)
+50 SET DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY")
SET DGELGSUB("CVELEDT")=DGELG("CVELEDT")
SET DGELGSUB("SHAD")=DGELG("SHAD")
+51 ;added dg*5.3*659
+52 SET DGELGSUB("RADEXPM")=DGELG("RADEXPM")
+53 SET DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
+54 IF $GET(DGPAT("INELDATE"))'=""
SET (HIPRI,HISUB)=""
End DoDot:1
+55 ;
+56 QUIT HIPRI_$SELECT(HIPRI:"^"_HISUB,1:"")
+57 ;
+58 ;
PRI(CODE,DGELG,ENRDATE,APPDATE) ;
+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 ;
+12 ;Output -
+13 ; Function Value - returns the priority and subgroup computed by the
+14 ; function as a 2 piece string 'PRIORITY^SUBGROUP'
+15 ;
+16 NEW CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
+17 NEW NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2
+18 SET SUBGRP=""
+19 ;
+20 ; use the Application Date when determining the priority, otherwise use
+21 ; the Enrollment Date (ESP DG*5,3*491)
+22 SET ENRDATE=$SELECT($GET(APPDATE):APPDATE,1:$GET(ENRDATE))
+23 ;
+24 ;get the name of the national eligibility code
+25 SET CODENAME=$$CODENAME^DGENELA(CODE)
+26 ;
+27 ;get the means test code
+28 SET MTSTA=""
+29 IF DGELG("MTSTA")
SET MTSTA=$PIECE($GET(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
+30 ;
+31 ;get MT and GMT thresholds
+32 SET DGMTI=$PIECE($$LST^DGMTU(DFN),"^")
+33 SET MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
+34 SET GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
+35 SET DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
+36 SET DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
+37 DO ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
+38 SET DGAICM=0
+39 IF $GET(DGINC("V"))
SET DGAICM=+DGINC("V")
+40 SET (DGMEDEX,DGEDEX,DGASSTS)=0
+41 SET DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
+42 IF $DATA(^DGMT(408.21,DGAICM,2))
Begin DoDot:1
+43 SET NODE2=^DGMT(408.21,DGAICM,2)
+44 SET DGASSTS=DGASSTS+$PIECE(NODE2,U,1)+$PIECE(NODE2,U,2)+$PIECE(NODE2,U,3)+$PIECE(NODE2,U,4)-$PIECE(NODE2,U,5)
+45 SET DGASSTS=DGASSTS+$PIECE(NODE2,U,6)+$PIECE(NODE2,U,7)+$PIECE(NODE2,U,8)+$PIECE(NODE2,U,9)
End DoDot:1
+46 IF $DATA(^DGMT(408.21,DGAICM,1))
SET DGMEDEX=$PIECE(^DGMT(408.21,DGAICM,1),"^",12)
+47 IF $DATA(^DGMT(408.21,DGAICM,1))
SET DGEDEX=$PIECE(^DGMT(408.21,DGAICM,1),"^",3)
+48 ;
+49 ; get expiration dates for Special Treatment Authority
+50 SET STAEXP("AO")=$$STAEXP^DGENELA4("AO")
+51 SET STAEXP("EC")=$$STAEXP^DGENELA4("EC")
+52 ;
+53 ;get the Enrollment Group Threshold (EGT) setting
+54 SET DGEGT=""
+55 IF $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
+56 IF '$GET(DGELG("RADEXPM"))
SET DGELG("RADEXPM")=""
+57 IF '$GET(DGELG("SHAD"))
SET DGELG("SHAD")=""
+58 ;
+59 ;drops out when priority determined
Begin DoDot:1
+60 SET PRIORITY=""
+61 IF ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%")
SET PRIORITY=1
QUIT
+62 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
+63 IF ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%"))
SET PRIORITY=2
QUIT
+64 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
+65 IF (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y")
SET PRIORITY=4
QUIT
+66 IF (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION")
SET PRIORITY=5
QUIT
+67 IF (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1)
SET PRIORITY=6
QUIT
+68 IF DGELG("EC")="Y"
IF (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC"))
SET PRIORITY=6
QUIT
+69 IF DGELG("IR")="Y"
IF (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4)
SET PRIORITY=6
QUIT
+70 IF (DGELG("AO")="Y")
IF (DGELG("AOEXPLOC"))="V"
IF (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO"))
SET PRIORITY=6
QUIT
+71 IF (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR))
SET PRIORITY=7
Begin DoDot:2
+72 IF ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%"))
SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,1)
QUIT
+73 SET SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
End DoDot:2
QUIT
+74 SET MTTEST1=MTTHR
+75 IF GMTTHR>MTTHR
SET MTTEST1=GMTTHR
+76 ; Add 10% to the test threshold
SET MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01
+77 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
+78 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
+79 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
+80 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
+81 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
+82 IF ((MTSTA="C")!(MTSTA="P"))
SET PRIORITY=8
SET SUBGRP=$$SUBPRI(DFN,PRIORITY,3)
QUIT
End DoDot:1
+83 ;
+84 QUIT PRIORITY_$SELECT(PRIORITY:"^"_SUBGRP,1:"")
+85 ;
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 IF SUBGRP=1
QUIT 5
+2 IF SUBGRP=3
QUIT 7
+3 QUIT SUBGRP
+4 ;
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
