154 lines
7.4 KiB
Mathematica
154 lines
7.4 KiB
Mathematica
DGENELA4 ;ALB/CJM,KCL,RTK,LBD,EG,CKN - Patient Eligibility API ; 04/24/2006 9:09 AM
|
|
;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564,672,659,653**;Aug 13,1993;Build 2
|
|
;
|
|
;
|
|
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")
|
|
.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
|
|
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=$P($G(^DGMT(408.31,+DGMTI,0)),"^",12)
|
|
S GMTTHR=$P($G(^DGMT(408.31,+DGMTI,0)),"^",27)
|
|
;
|
|
;get the Enrollment Group Threshold (EGT) setting
|
|
S DGEGT=""
|
|
I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT)
|
|
;
|
|
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("AO")="Y")!(DGELG("EC")="Y")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'<DT))!(DGELG("SHAD")=1) S PRIORITY=6 Q
|
|
.I DGELG("IR")="Y" I (DGELG("RADEXPM")=2)!(DGELG("RADEXPM")=3)!(DGELG("RADEXPM")=4) 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)
|
|
.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
|