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

DGENELA4.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. 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
  1. ; patient, also returning the subset of the eligibility data on which
  1. ; the priority subgroup is based.
  1. ;
  1. ;Input:
  1. ; DFN - ien of patient
  1. ; DGELG - ELIGIBILITY object array (optional, pass by reference)
  1. ; ENRDATE - The Enrollment Date. This date is used in the priority
  1. ; determination only if the application date is not passed.
  1. ; APPDATE - The Enrollment Application Date. This date is used
  1. ; to determine the priority. If the application date
  1. ; is not passed then the enrollment date (ENRDATE) is used.
  1. ; DGENRYN - (Optinal) ENROLL Y/N question for registration 0=NO 1=YES DG*5.3*993
  1. ;
  1. ;Output:
  1. ; Function Value - returns the priority and subgroup computed by the
  1. ; function as a 2 piece string 'PRIORITY^SUBGROUP'
  1. ; DGELGSUB - this local array will contain the eligibility data on
  1. ; which the priority determination was based, pass by reference
  1. ; if needed.
  1. ;
  1. N CODE,HICODE,PRI,HIPRI,PRIORITY,SUBGRP,HISUB,SUB,DGPAT
  1. K DGELGSUB S DGELGSUB=""
  1. S (HICODE,HIPRI,SUBGRP,HISUB)=""
  1. D
  1. .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;cannot proceed with eligibility
  1. .; can't proceed without an Enrollment Date or Application Date
  1. .I '$G(ENRDATE),'$G(APPDATE) Q
  1. .I $$GET^DGENPTA(DFN,.DGPAT)
  1. .; determine priority/subgroup based on primary eligibility
  1. .S HICODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
  1. .S PRIORITY=$$PRI(HICODE,.DGELG,$G(ENRDATE),$G(APPDATE),$G(DGENRYN)) ; DG*5.3*993 Added 5th parameter DGENRYN
  1. .S HIPRI=$P(PRIORITY,"^"),HISUB=$P(PRIORITY,"^",2)
  1. .S CODE=""
  1. .;
  1. .; determine if other eligibilities result in higher priority/subgroup
  1. .F S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:('CODE!(HIPRI=1)) D
  1. ..S PRIORITY=$$PRI($$NATCODE^DGENELA(CODE),.DGELG,$G(ENRDATE),$G(APPDATE),$G(DGENRYN)) ; DG*5.3*993 Added 5th parameter DGENRYN
  1. ..S PRI=$P(PRIORITY,"^"),SUB=$P(PRIORITY,"^",2)
  1. ..S:((PRI>0)&((PRI<HIPRI)!(HIPRI=""))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
  1. ..S:((PRI=HIPRI)&((SUB>0)&(SUB<HISUB))) HIPRI=PRI,HICODE=$$NATCODE^DGENELA(CODE),HISUB=SUB
  1. .;
  1. .;set the DGELGSUB() array with the eligibility information used in the
  1. .;priority determination
  1. .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")
  1. .S DGELGSUB("VAPEN")=DGELG("VAPEN"),DGELGSUB("VACKAMT")=DGELG("VACKAMT"),DGELGSUB("DISRET")=DGELG("DISRET"),DGELGSUB("DISLOD")=DGELG("DISLOD")
  1. .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA")
  1. .;Purple Heart Added to DGELGSUB
  1. .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH")
  1. .;Added for HVE Phase III (DG*5.3*564)
  1. .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT"),DGELGSUB("SHAD")=DGELG("SHAD")
  1. .;added dg*5.3*659
  1. .S DGELGSUB("RADEXPM")=DGELG("RADEXPM")
  1. .S DGELGSUB("AOEXPLOC")=DGELG("AOEXPLOC")
  1. .S DGELGSUB("MOH")=DGELG("MOH")
  1. .S DGELGSUB("MOHAWRDDATE")=DGELG("MOHAWRDDATE") ;added with DG*5.3*972 HM
  1. .S DGELGSUB("MOHSTATDATE")=DGELG("MOHSTATDATE") ;added with DG*5.3*972 HM
  1. .S DGELGSUB("MOHEXEMPDATE")=DGELG("MOHEXEMPDATE") ;added with DG*5.3*972 HM
  1. .S DGELGSUB("CLE")=DGELG("CLE") ;added with DG*5.3*909
  1. .S DGELGSUB("CLEDT")=DGELG("CLEDT") ;added with DG*5.3*909
  1. .S DGELGSUB("CLEST")=DGELG("CLEST") ;added with DG*5.3*909
  1. .S DGELGSUB("CLESOR")=DGELG("CLESOR") ;added with DG*5.3*909
  1. .S DGELGSUB("OTHTYPE")=DGELG("OTHTYPE") ; DG*5.3*952
  1. .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)=""
  1. ;
  1. Q HIPRI_$S(HIPRI:"^"_HISUB,1:"")
  1. ;
  1. ;
  1. 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
  1. ; single eligibility code.
  1. ;Input -
  1. ; CODE - pointer to file #8.1, MAS Eligibility Code
  1. ; DGELG - local array obtained by calling $$GET, pass by reference
  1. ; ENRDATE - The Enrollment Date. This date is used in the priority
  1. ; determination only if the application date is not passed.
  1. ; APPDATE - The Enrollment Application Date. This date is used
  1. ; to determine the priority. If the application date
  1. ; is not passed then the enrollment date (ENRDATE) is used.
  1. ; DGENRYN (Optional) ENROLL Y/N question for registration 0=NO 1=YES
  1. ;
  1. ;Output -
  1. ; Function Value - returns the priority and subgroup computed by the
  1. ; function as a 2 piece string 'PRIORITY^SUBGROUP'
  1. ;
  1. N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR,STAEXP
  1. N NODE2,DGNCM,DGNETW,DGMEDEX,DGEDEX,DGASSTS,DGMTYR,MTTEST1,MTTEST2,DGAICM,DGENRIEN,DGTERA
  1. S SUBGRP=""
  1. ;DG*5.3*993 If parameter DGENRYN is blank (null) or does not exist, populate it using the
  1. ; PT APPLIED FOR ENROLLMENT? field (#.14) in the PATIENT ENROLLMENT file (#27.11)
  1. ; if a record exists in file #27.11 for this patient.
  1. S DGENRYN=$G(DGENRYN) I DGENRYN="" S DGENRIEN=$$FINDCUR^DGENA(DFN) I DGENRIEN S DGENRYN=$$GET1^DIQ(27.11,DGENRIEN_",",.14,"I")
  1. I DGENRYN=0,$$GET1^DIQ(2,DFN_",",.351)="" Q "" ;If ENROLL is NO, and patient is not deceased return null
  1. ;End of DG*5.3*993 mods
  1. ;
  1. ; use the Application Date when determining the priority, otherwise use
  1. ; the Enrollment Date (ESP DG*5,3*491)
  1. S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE))
  1. ;
  1. ;get the name of the national eligibility code
  1. S CODENAME=$$CODENAME^DGENELA(CODE)
  1. ;
  1. ;get the means test code
  1. S MTSTA=""
  1. I DGELG("MTSTA") S MTSTA=$P($G(^DG(408.32,DGELG("MTSTA"),0)),"^",2)
  1. ;
  1. ;get MT and GMT thresholds
  1. S DGMTI=$P($$LST^DGMTU(DFN),"^")
  1. S MTTHR=$$GET1^DIQ(408.31,+DGMTI,.12,"I")
  1. S GMTTHR=$$GET1^DIQ(408.31,+DGMTI,.27,"I")
  1. S DGNCM=$$GET1^DIQ(408.31,+DGMTI,.04,"I")
  1. S DGNETW=$$GET1^DIQ(408.31,+DGMTI,.05,"I")
  1. D ALL^DGMTU21(DFN,"V",DT,"I",+DGMTI)
  1. S DGAICM=0
  1. S:$G(DGINC("V")) DGAICM=+DGINC("V")
  1. S (DGMEDEX,DGEDEX,DGASSTS)=0
  1. S DGMTYR=$$GET1^DIQ(408.21,+DGAICM,.01,"E")
  1. I $D(^DGMT(408.21,DGAICM,2)) D
  1. .S NODE2=^DGMT(408.21,DGAICM,2)
  1. .S DGASSTS=DGASSTS+$P(NODE2,U,1)+$P(NODE2,U,2)+$P(NODE2,U,3)+$P(NODE2,U,4)-$P(NODE2,U,5)
  1. .S DGASSTS=DGASSTS+$P(NODE2,U,6)+$P(NODE2,U,7)+$P(NODE2,U,8)+$P(NODE2,U,9)
  1. S:$D(^DGMT(408.21,DGAICM,1)) DGMEDEX=$P(^DGMT(408.21,DGAICM,1),"^",12)
  1. S:$D(^DGMT(408.21,DGAICM,1)) DGEDEX=$P(^DGMT(408.21,DGAICM,1),"^",3)
  1. ;
  1. ; get expiration dates for Special Treatment Authority
  1. S STAEXP("AO")=$$STAEXP^DGENELA4("AO")
  1. S STAEXP("EC")=$$STAEXP^DGENELA4("EC")
  1. ;
  1. ;get the Enrollment Group Threshold (EGT) setting
  1. S DGEGT=""
  1. I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
  1. I '$G(DGELG("RADEXPM")) S DGELG("RADEXPM")=""
  1. I '$G(DGELG("SHAD")) S DGELG("SHAD")=""
  1. ;
  1. ; DG*5.3*1103 - get the TERA indicator (TOXIC EXPOSURE RISK ACTIVITY #.32116) field of PATIENT (#2) file
  1. S DGTERA=$$GET1^DIQ(2,DFN,.32116,"I")
  1. ;
  1. D ;drops out when priority determined
  1. .S PRIORITY=""
  1. .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q
  1. .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
  1. .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
  1. .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q
  1. .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
  1. .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q
  1. .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q
  1. .; DG*5.3*1103 - set PRIORITY group 6 for TERA indicator Veterans
  1. .I DGTERA=1 S PRIORITY=6 Q
  1. .; DG*5.3*1098 - add the additional WORLD WAR II eligibility for PRIORITY group 6
  1. .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
  1. .I DGELG("EC")="Y" I (STAEXP("EC")<1)!($$DT^XLFDT<STAEXP("EC")) S PRIORITY=6 Q
  1. .;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
  1. .;I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) S PRIORITY=6 Q
  1. .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
  1. .; DG*5.3*1018 - Add "B" - Blue Water Navy Value
  1. .; DG*5.3*1090 - Add additional Agent Orange Exposure Locations - T=THAILAND(U.S. OR ROYAL THAI MIL BASE), L=LAOS,
  1. .; C=CAMBODIA(MIMOT OR KREK,KAMPONG CHAM), G=GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS and J=JOHNSTON ATOLL
  1. .I (DGELG("AO")="Y") D Q:(PRIORITY=6) ;DG*5.3*1090 begin
  1. ..I (DGELG("AOEXPLOC")'=""),("VBTLCJG"[DGELG("AOEXPLOC")) D ;Check for the initials of the exposure locations
  1. ...I (STAEXP("AO")<1)!($$DT^XLFDT<STAEXP("AO")) S PRIORITY=6 ;DG*5.3*1090 end
  1. .I DGELG("CLE")="Y" S PRIORITY=6 Q ; Added for DG*5.3*909 Camp Lejeune
  1. .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D Q
  1. ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
  1. ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3)
  1. .S MTTEST1=MTTHR
  1. .I GMTTHR>MTTHR S MTTEST1=GMTTHR
  1. .S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold
  1. .I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
  1. .I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q
  1. .I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
  1. .I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)<MTTHR,DGNCM+DGNETW>79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q
  1. .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q
  1. .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q
  1. ;
  1. Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"")
  1. ;
  1. SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT
  1. ;
  1. N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X
  1. Q:'$G(DFN)
  1. S U="^"
  1. S:$G(PRIORITY)="" PRIORITY=""
  1. S:$G(SUBGRP)="" SUBGRP=""
  1. D NOW^%DTC S TODAY=X
  1. Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set
  1. Q:TODAY<EGT("EFFDATE") SUBGRP ;EGT is not in effect
  1. I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP
  1. I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORITY")+(EGT("SUBGRP")*.01)) Q SUBGRP
  1. I EGT("TYPE")=4 Q:(PRIORITY<EGT("PRIORITY")) SUBGRP Q:(PRIORITY>EGT("PRIORITY")) $$SUBCNV(SUBGRP)
  1. ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP
  1. S DGENRIEN=$$FINDCUR^DGENA(DFN)
  1. I 'DGENRIEN,$G(ENRDATE),ENRDATE<EGT("EFFDATE") Q SUBGRP
  1. S DONE=0
  1. F Q:DONE D
  1. .I 'DGENRIEN S DONE=2 Q
  1. .I '$$GET^DGENA(DGENRIEN,.DGENRC) S DONE=2 Q
  1. .S DGENRIEN=$$FINDPRI^DGENA(DGENRIEN)
  1. .Q:DGENRC("STATUS")=6 ;deceased
  1. .I $P($G(^DGEN(27.15,+DGENRC("STATUS"),0)),"^",2)="N" S DONE=2 Q
  1. .S ENRDT=$G(DGENRC("APP")) S:'ENRDT ENRDT=$G(DGENRC("EFFDATE"))
  1. .I ENRDT,ENRDT<EGT("EFFDATE") S DONE=1 Q
  1. .; HEC is the authoritative source on continuous enrollment
  1. .I $$OVRRIDE^DGENEGT1(DFN,.EGT) S DONE=1
  1. ;
  1. Q $S(DONE=2:$$SUBCNV(SUBGRP),1:SUBGRP)
  1. ;
  1. 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
  1. I $G(DGELG("CVELEDT"))'="" Q SUBGRP
  1. I SUBGRP=1 Q 5
  1. I SUBGRP=3 Q 7
  1. Q SUBGRP
  1. ;
  1. STAEXP(STATYP) ;return expiration date for Special Treatment Authority (STA)
  1. ;Input -
  1. ; STATYP - STA Type (Only AO & EC (SWAC) currently supported)
  1. ;
  1. ;Output -
  1. ; Function Value - returns the requested expiration date from the
  1. ; MAS PARAMETERS file (#43), otherwise returns 0
  1. ;
  1. I STATYP="AO" Q +$P($G(^DG(43,1,"ENR")),U,1) ;AO Exp Dt
  1. I STATYP="EC" Q +$P($G(^DG(43,1,"ENR")),U,2) ;EC (SWAC) Exp Dt
  1. Q 0