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

DGENELA.m

Go to the documentation of this file.
  1. DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC,TDM,JLS,HM,RN - Patient Eligibility API ;3/3/11 3:40pm
  1. ;;5.3;Registration;**121,147,232,314,451,564,631,672,659,583,653,688,841,909,972,952,1061**;Aug 13,1993;Build 22
  1. ;
  1. GET(DFN,DGELG) ;
  1. ;Description: Used to obtain the patient eligibility data.
  1. ; The data is placed in the local DGELG array.
  1. ;Input:
  1. ; DFN - internal entry number of a record in the PATIENT file
  1. ;Output:
  1. ; Function Value - returns 1 on success, 0 on failure
  1. ; DGELG - this is a local array that will be used to return patient eligibility data. The array subscripts and the fields mapped to are defined below. (pass by reference)
  1. ;
  1. ;subscript field name
  1. ;"DFN" ien Patient record
  1. ;"ELIG","CODE" Primary Eligibility Code
  1. ;"ELIG","CODE",<ien> Patient Eligibilities
  1. ;"SC" Service Connected
  1. ;"SCPER" Service Connected Percentage
  1. ;"EFFDT" SC Combined Effective Date
  1. ;"POW" POW Status Indicated
  1. ;"A&A" Receiving A&A Benefits
  1. ;"HB" Receiving Housebound Benefits
  1. ;"VAPEN" Receiving a VA Pension
  1. ;"VACKAMT" Total Annual VA Check Amount
  1. ;"DISRET" Military Disability Retirement
  1. ;"DISLOD" Discharge Due to Disability (added with DG 672)
  1. ;"MEDICAID" Medicaid
  1. ;"MEDASKDT" Date Medicaid Last Asked
  1. ;"AO" Exposed to Agent Orange
  1. ;"IR" Radiation Exposure Indicated
  1. ;"RADEXPM" Radiation Exposure Method
  1. ;"EC" SW Asia Cond - change from Env Con, DG*5.3*688
  1. ;"MTSTA" Means Test Status
  1. ;P&T P&T
  1. ;P&TDT P&T EFFECTIVE DATE (added with DG 688)
  1. ;POS PERIOD OF SERVICE
  1. ;UNEMPLOY UNEMPLOYABLE
  1. ;SCAWDATE SC AWARD DATE
  1. ;RATEINC RATED INCOMPETENT
  1. ;CLAIMNUM CLAIM NUMBER
  1. ;CLAIMLOC CLAIM FOLDER LOCATION
  1. ;VADISAB RECEIVING VA DISABILITY?
  1. ;ELIGSTA ELIGIBILITY STATUS
  1. ;ELIGSTADATE ELIGIBILITY STATUS DATE
  1. ;ELIGVERIF ELIGIBILITY VERIF. METHOD
  1. ;ELIGVSITE ELIGIBILITY VERIFICATION SITE
  1. ;ELIGENTBY ELIGIBILITY STATUS ENTERED BY
  1. ;RATEDIS
  1. ; <COUNT>,"RD" RATED DISABILITY
  1. ; <COUNT>,"PER" DISABILITY %
  1. ; <COUNT>,"RDSC" SERVICE CONNECTED
  1. ; <COUNT>,"RDEXT" EXTREMITY
  1. ; <COUNT>,"RDORIG" ORIGINAL RD EFFECTIVE DATE
  1. ; <COUNT>."RDCURR" CURRENT RD EFFECTIVE DATE
  1. ;"VCD" Veteran Catastrophically Disabled? (#.39)
  1. ;"PH" PURPLE HEART INDICATED
  1. ;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION
  1. ;"CVELEDT" COMBAT VETERAN END DATE
  1. ;"SHAD" SHAD EXPOSURE
  1. ;"MOH" MEDAL OF HONOR
  1. ;"MOHAWRDDATE" MEDAL OF HONOR AWARD DATE
  1. ;"MOHSTATDATE" MEDAL OF HONOR CHANGE DATE
  1. ;"MOHEXEMPDATE" MEDAL OF HONOR COPAYMENT EXEMPTION DATE
  1. ;"CLE" CAMP LEJEUNE INDICATED?
  1. ;"CLEDT" CAMP LEJEUNE DATE
  1. ;"CLEST" CAMP LEJEUNE CHANGE SITE
  1. ;"CLESOR" CAMP LEJEUNE SOURCE
  1. ;"OTHTYPE" EXPANDED MH CARE TYPE (OTH)
  1. ;
  1. K DGELG
  1. S DGELG=""
  1. Q:'$D(^DPT(DFN)) 0
  1. N NODE,SUBREC,COUNT,CODE,IEN
  1. ;
  1. S DGELG("DFN")=DFN
  1. S DGELG("VCD")=$$VCD^DGENA5(DFN)
  1. ;
  1. ;
  1. S NODE=$G(^DPT(DFN,.29))
  1. S DGELG("RATEINC")=$P(NODE,"^",12)
  1. ;
  1. S NODE=$G(^DPT(DFN,.3))
  1. S DGELG("SC")=$P(NODE,"^")
  1. S DGELG("SCPER")=$P(NODE,"^",2)
  1. S DGELG("P&T")=$P(NODE,"^",4)
  1. S DGELG("P&TDT")=$P(NODE,"^",13)
  1. S DGELG("UNEMPLOY")=$P(NODE,"^",5)
  1. S DGELG("SCAWDATE")=$P(NODE,"^",12)
  1. S DGELG("VADISAB")=$P(NODE,"^",11)
  1. S DGELG("EFFDT")=$P(NODE,"^",14)
  1. ;
  1. S NODE=$G(^DPT(DFN,.31))
  1. S DGELG("CLAIMNUM")=$P(NODE,"^",3)
  1. S DGELG("CLAIMLOC")=$P(NODE,"^",4)
  1. ;
  1. S NODE=$G(^DPT(DFN,.32))
  1. S DGELG("POS")=$P(NODE,"^",3)
  1. ;
  1. S NODE=$G(^DPT(DFN,.36))
  1. S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility
  1. S DGELG("DISRET")=$P(NODE,"^",12)
  1. S DGELG("DISLOD")=$P(NODE,"^",13)
  1. ;
  1. S NODE=$G(^DPT(DFN,.38))
  1. S DGELG("MEDICAID")=$P(NODE,"^")
  1. S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked
  1. ;
  1. S NODE=$G(^DPT(DFN,.361))
  1. S DGELG("ELIGSTA")=$P(NODE,"^")
  1. S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
  1. S DGELG("ELIGVERIF")=$P(NODE,"^",5)
  1. S DGELG("ELIGENTBY")=$P(NODE,"^",6)
  1. ;
  1. S NODE=$G(^DPT(DFN,.362))
  1. S DGELG("VACKAMT")=$P(NODE,"^",20)
  1. S DGELG("VAPEN")=$P(NODE,"^",14)
  1. S DGELG("A&A")=$P(NODE,"^",12)
  1. S DGELG("HB")=$P(NODE,"^",13)
  1. ;
  1. ;
  1. S NODE=$G(^DPT(DFN,.321))
  1. S DGELG("AO")=$P(NODE,"^",2)
  1. S DGELG("IR")=$P(NODE,"^",3)
  1. S DGELG("RADEXPM")=$P(NODE,"^",12)
  1. S DGELG("AOEXPLOC")=$P(NODE,"^",13)
  1. S DGELG("SHAD")=$P(NODE,"^",15) ;added with DG*5.3*653
  1. ;
  1. S NODE=$G(^DPT(DFN,.322))
  1. S DGELG("EC")=$P(NODE,"^",13)
  1. ;
  1. S NODE=$G(^DPT(DFN,.52))
  1. S DGELG("POW")=$P(NODE,"^",5)
  1. S DGELG("CVELEDT")=$P(NODE,"^",15)
  1. ;
  1. ; Purple Heart Indicator
  1. S NODE=$G(^DPT(DFN,.53))
  1. S DGELG("PH")=$P(NODE,"^")
  1. ;
  1. ; Medal of Honor Indicator
  1. S NODE=$G(^DPT(DFN,.54))
  1. S DGELG("MOH")=$P(NODE,"^",1)
  1. S DGELG("MOHAWRDDATE")=$P(NODE,"^",2) ;MH AWARD DATE DG*5.3*972 HM
  1. S DGELG("MOHSTATDATE")=$P(NODE,"^",3) ;MH STATUS DATE DG*5.3*972 HM
  1. S DGELG("MOHEXEMPDATE")=$P(NODE,"^",4) ;MH COPAYMENT EXEMPTION DATE DG*5.3*972 HM
  1. ;
  1. ; Camp Lejeune Eligibility Indicator DG*5.3*909
  1. S NODE=$G(^DPT(DFN,.3217))
  1. S DGELG("CLE")=$P(NODE,"^",1)
  1. S DGELG("CLEDT")=$P(NODE,"^",2)
  1. S DGELG("CLEST")=$P(NODE,"^",3)
  1. S DGELG("CLESOR")=$P(NODE,"^",4)
  1. ;
  1. ; Expanded MH care type for OTH patients DG*5.3*952
  1. S NODE=$G(^DPT(DFN,.55))
  1. S DGELG("OTHTYPE")=$P(NODE,U)
  1. ;
  1. ;means test category
  1. S DGELG("MTSTA")=""
  1. S IEN=$P($$LST^DGMTU(DFN),"^")
  1. I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3)
  1. ;
  1. ;get the other eligibilities multiple
  1. S SUBREC=0
  1. F S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC D
  1. .S CODE=+$G(^DPT(DFN,"E",SUBREC,0))
  1. .;
  1. .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actually removed - but the "B" x-ref has been deleted at this point
  1. .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC
  1. ;
  1. ;rated disability multiple
  1. S SUBREC=0,COUNT=0
  1. F S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC D
  1. .S NODE=$G(^DPT(DFN,.372,SUBREC,0))
  1. .Q:'$P(NODE,"^")
  1. .S COUNT=COUNT+1
  1. .S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^")
  1. .S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2)
  1. .S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3)
  1. .S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4)
  1. .S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5)
  1. .S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6)
  1. ;
  1. Q 1
  1. ;
  1. NATNAME(CODE) ;
  1. ;Description: Given an entry in file #8, Eligibility Code file,
  1. ; finds the corresponding entry in file 8.1, MAS Eligibility Code file,
  1. ; and returns the name
  1. ;Input:
  1. ; CODE - pointer to file #8
  1. ;Output:
  1. ; Function Value - name of corresponding code in file #8.1
  1. ;
  1. Q:'$G(CODE) ""
  1. Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9))
  1. ;
  1. NATCODE(CODE) ;
  1. ;Description: Given an entry in file #8, Eligibility Code file,
  1. ; finds the corresponding entry in file 8.1, MAS Eligibility Code file
  1. ;Input:
  1. ; CODE - pointer to file #8
  1. ;Output:
  1. ; Function Value - pointer to file #8.1
  1. ;
  1. Q:'$G(CODE) ""
  1. Q $P($G(^DIC(8,CODE,0)),"^",9)
  1. ;
  1. CODENAME(CODE) ;
  1. ;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
  1. ; it returns the name of the code
  1. ;Input:
  1. ; CODE - pointer to file #8.1
  1. ;Output:
  1. ; Function Value - name of the code pointed to
  1. ;
  1. Q:'$G(CODE) ""
  1. Q $P($G(^DIC(8.1,CODE,0)),"^")
  1. ;
  1. ELIGSTAT(DFN,DGELG) ;
  1. ;Description: Used to get the ELIGIBILITY STATUS and the
  1. ;ELIGIBILITY STATUS DATE of the patient.
  1. ;
  1. ;Input:
  1. ; DFN - ien of patient record
  1. ;
  1. ;Output:
  1. ; Function Value - 1 on success, 0 on failure
  1. ; DGELG array (pass by reference)
  1. ; "ELIGSTA" - ELIGIBILITY STATUS
  1. ; "ELIGSTADATE" - ELIGIBILITY STATUS DATE
  1. ;
  1. N NODE,SUCCESS
  1. D
  1. .S SUCCESS=1
  1. .I '$G(DFN) S SUCCESS=0 Q
  1. .S NODE=$G(^DPT(DFN,.361))
  1. .S DGELG("ELIGSTA")=$P(NODE,"^")
  1. .S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
  1. Q SUCCESS
  1. ;
  1. ;
  1. CAI(DFN) ;DG*5.3*1061 - COMPACT Act Indicator
  1. ;Description: Used to check if the patient is COMPACT ACT eligible.
  1. ;
  1. ;Input:
  1. ; DFN - ien of patient record
  1. ;
  1. ;Output:
  1. ; Function Value - 1 for ELIGIBLE, (The patient is enrolled or has eligibility COMPACT ACT ELIGIBLE)
  1. ; 0 for Not Eligible
  1. ;
  1. I '+$G(DFN) Q 0
  1. N DGENCAT,DGSTATUS,DGVLE,DGELIGSTAT
  1. S DGELIGSTAT=0
  1. S DGSTATUS=$$STATUS^DGENA($G(DFN))
  1. S DGENCAT=$$CATEGORY^DGENA4(DFN,$G(DGSTATUS)) ;enrollment category
  1. S DGVLE=$$HASELIG(DFN,"COMPACT ACT ELIGIBLE")
  1. I (DGVLE)!(DGENCAT="E") S DGELIGSTAT=1
  1. Q DGELIGSTAT
  1. ;
  1. HASELIG(DFN,DGELIG) ;DG*5.3*1061
  1. ;Description: Checks if patient has a specific MAS eligibility in their record
  1. ;ICR 10061 NAME: ELIG^VADPT
  1. ;
  1. ;Inputs:
  1. ; DFN - ien of patient record
  1. ; DGELIG - MAS Name of the eligibility (from file MAS ELIGIBILITY CODE file #8.1)
  1. ;
  1. ; Return value:
  1. ; - 0 if DGELIG not in the record
  1. ; - 1 if DGELIG is the Primary eligibility in the patient record
  1. ; - 2 if DGELIG is a Secondary eligibility in the patient record
  1. ;
  1. N VAEL,DGX,DGRET,DGPE,DGSE
  1. ; get array VAEL which contains patient's eligibilities
  1. D ELIG^VADPT
  1. S DGRET=0
  1. ; get the Primary eligibility number
  1. S DGPE=$P($G(VAEL(1)),"^",1)
  1. ; Get the national name of that eligibility and if it matches, return 1
  1. I $$NATNAME(DGPE)=DGELIG S DGRET=1
  1. ; If not primary, loop over the array looking for DGELIG in list of secondary eligibilities
  1. I 'DGRET S DGX="" F S DGX=$O(VAEL(1,DGX)) Q:'DGX D Q:DGRET
  1. . S DGSE=$P(VAEL(1,DGX),"^",1)
  1. . ; Get the national name of that eligibility and if it matches, return 2
  1. . I $$NATNAME(DGSE)=DGELIG S DGRET=2
  1. Q DGRET