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