DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC,TDM,JLS,HM,RN - Patient Eligibility API ;3/3/11 3:40pm
;;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
;
GET(DFN,DGELG) ;
;Description: Used to obtain the patient eligibility data.
; The data is placed in the local DGELG array.
;Input:
; DFN - internal entry number of a record in the PATIENT file
;Output:
; Function Value - returns 1 on success, 0 on failure
; 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)
;
;subscript field name
;"DFN" ien Patient record
;"ELIG","CODE" Primary Eligibility Code
;"ELIG","CODE",<ien> Patient Eligibilities
;"SC" Service Connected
;"SCPER" Service Connected Percentage
;"EFFDT" SC Combined Effective Date
;"POW" POW Status Indicated
;"A&A" Receiving A&A Benefits
;"HB" Receiving Housebound Benefits
;"VAPEN" Receiving a VA Pension
;"VACKAMT" Total Annual VA Check Amount
;"DISRET" Military Disability Retirement
;"DISLOD" Discharge Due to Disability (added with DG 672)
;"MEDICAID" Medicaid
;"MEDASKDT" Date Medicaid Last Asked
;"AO" Exposed to Agent Orange
;"IR" Radiation Exposure Indicated
;"RADEXPM" Radiation Exposure Method
;"EC" SW Asia Cond - change from Env Con, DG*5.3*688
;"MTSTA" Means Test Status
;P&T P&T
;P&TDT P&T EFFECTIVE DATE (added with DG 688)
;POS PERIOD OF SERVICE
;UNEMPLOY UNEMPLOYABLE
;SCAWDATE SC AWARD DATE
;RATEINC RATED INCOMPETENT
;CLAIMNUM CLAIM NUMBER
;CLAIMLOC CLAIM FOLDER LOCATION
;VADISAB RECEIVING VA DISABILITY?
;ELIGSTA ELIGIBILITY STATUS
;ELIGSTADATE ELIGIBILITY STATUS DATE
;ELIGVERIF ELIGIBILITY VERIF. METHOD
;ELIGVSITE ELIGIBILITY VERIFICATION SITE
;ELIGENTBY ELIGIBILITY STATUS ENTERED BY
;RATEDIS
; <COUNT>,"RD" RATED DISABILITY
; <COUNT>,"PER" DISABILITY %
; <COUNT>,"RDSC" SERVICE CONNECTED
; <COUNT>,"RDEXT" EXTREMITY
; <COUNT>,"RDORIG" ORIGINAL RD EFFECTIVE DATE
; <COUNT>."RDCURR" CURRENT RD EFFECTIVE DATE
;"VCD" Veteran Catastrophically Disabled? (#.39)
;"PH" PURPLE HEART INDICATED
;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION
;"CVELEDT" COMBAT VETERAN END DATE
;"SHAD" SHAD EXPOSURE
;"MOH" MEDAL OF HONOR
;"MOHAWRDDATE" MEDAL OF HONOR AWARD DATE
;"MOHSTATDATE" MEDAL OF HONOR CHANGE DATE
;"MOHEXEMPDATE" MEDAL OF HONOR COPAYMENT EXEMPTION DATE
;"CLE" CAMP LEJEUNE INDICATED?
;"CLEDT" CAMP LEJEUNE DATE
;"CLEST" CAMP LEJEUNE CHANGE SITE
;"CLESOR" CAMP LEJEUNE SOURCE
;"OTHTYPE" EXPANDED MH CARE TYPE (OTH)
;
K DGELG
S DGELG=""
Q:'$D(^DPT(DFN)) 0
N NODE,SUBREC,COUNT,CODE,IEN
;
S DGELG("DFN")=DFN
S DGELG("VCD")=$$VCD^DGENA5(DFN)
;
;
S NODE=$G(^DPT(DFN,.29))
S DGELG("RATEINC")=$P(NODE,"^",12)
;
S NODE=$G(^DPT(DFN,.3))
S DGELG("SC")=$P(NODE,"^")
S DGELG("SCPER")=$P(NODE,"^",2)
S DGELG("P&T")=$P(NODE,"^",4)
S DGELG("P&TDT")=$P(NODE,"^",13)
S DGELG("UNEMPLOY")=$P(NODE,"^",5)
S DGELG("SCAWDATE")=$P(NODE,"^",12)
S DGELG("VADISAB")=$P(NODE,"^",11)
S DGELG("EFFDT")=$P(NODE,"^",14)
;
S NODE=$G(^DPT(DFN,.31))
S DGELG("CLAIMNUM")=$P(NODE,"^",3)
S DGELG("CLAIMLOC")=$P(NODE,"^",4)
;
S NODE=$G(^DPT(DFN,.32))
S DGELG("POS")=$P(NODE,"^",3)
;
S NODE=$G(^DPT(DFN,.36))
S DGELG("ELIG","CODE")=$P(NODE,"^") ;primary eligibility
S DGELG("DISRET")=$P(NODE,"^",12)
S DGELG("DISLOD")=$P(NODE,"^",13)
;
S NODE=$G(^DPT(DFN,.38))
S DGELG("MEDICAID")=$P(NODE,"^")
S DGELG("MEDASKDT")=$P(NODE,"^",2) ;Date Medicaid Last Asked
;
S NODE=$G(^DPT(DFN,.361))
S DGELG("ELIGSTA")=$P(NODE,"^")
S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
S DGELG("ELIGVERIF")=$P(NODE,"^",5)
S DGELG("ELIGENTBY")=$P(NODE,"^",6)
;
S NODE=$G(^DPT(DFN,.362))
S DGELG("VACKAMT")=$P(NODE,"^",20)
S DGELG("VAPEN")=$P(NODE,"^",14)
S DGELG("A&A")=$P(NODE,"^",12)
S DGELG("HB")=$P(NODE,"^",13)
;
;
S NODE=$G(^DPT(DFN,.321))
S DGELG("AO")=$P(NODE,"^",2)
S DGELG("IR")=$P(NODE,"^",3)
S DGELG("RADEXPM")=$P(NODE,"^",12)
S DGELG("AOEXPLOC")=$P(NODE,"^",13)
S DGELG("SHAD")=$P(NODE,"^",15) ;added with DG*5.3*653
;
S NODE=$G(^DPT(DFN,.322))
S DGELG("EC")=$P(NODE,"^",13)
;
S NODE=$G(^DPT(DFN,.52))
S DGELG("POW")=$P(NODE,"^",5)
S DGELG("CVELEDT")=$P(NODE,"^",15)
;
; Purple Heart Indicator
S NODE=$G(^DPT(DFN,.53))
S DGELG("PH")=$P(NODE,"^")
;
; Medal of Honor Indicator
S NODE=$G(^DPT(DFN,.54))
S DGELG("MOH")=$P(NODE,"^",1)
S DGELG("MOHAWRDDATE")=$P(NODE,"^",2) ;MH AWARD DATE DG*5.3*972 HM
S DGELG("MOHSTATDATE")=$P(NODE,"^",3) ;MH STATUS DATE DG*5.3*972 HM
S DGELG("MOHEXEMPDATE")=$P(NODE,"^",4) ;MH COPAYMENT EXEMPTION DATE DG*5.3*972 HM
;
; Camp Lejeune Eligibility Indicator DG*5.3*909
S NODE=$G(^DPT(DFN,.3217))
S DGELG("CLE")=$P(NODE,"^",1)
S DGELG("CLEDT")=$P(NODE,"^",2)
S DGELG("CLEST")=$P(NODE,"^",3)
S DGELG("CLESOR")=$P(NODE,"^",4)
;
; Expanded MH care type for OTH patients DG*5.3*952
S NODE=$G(^DPT(DFN,.55))
S DGELG("OTHTYPE")=$P(NODE,U)
;
;means test category
S DGELG("MTSTA")=""
S IEN=$P($$LST^DGMTU(DFN),"^")
I IEN S DGELG("MTSTA")=$P($G(^DGMT(408.31,IEN,0)),"^",3)
;
;get the other eligibilities multiple
S SUBREC=0
F S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC D
.S CODE=+$G(^DPT(DFN,"E",SUBREC,0))
.;
.;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
.I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC
;
;rated disability multiple
S SUBREC=0,COUNT=0
F S SUBREC=$O(^DPT(DFN,.372,SUBREC)) Q:'SUBREC D
.S NODE=$G(^DPT(DFN,.372,SUBREC,0))
.Q:'$P(NODE,"^")
.S COUNT=COUNT+1
.S DGELG("RATEDIS",COUNT,"RD")=$P(NODE,"^")
.S DGELG("RATEDIS",COUNT,"PER")=$P(NODE,"^",2)
.S DGELG("RATEDIS",COUNT,"RDSC")=$P(NODE,"^",3)
.S DGELG("RATEDIS",COUNT,"RDEXT")=$P(NODE,"^",4)
.S DGELG("RATEDIS",COUNT,"RDORIG")=$P(NODE,"^",5)
.S DGELG("RATEDIS",COUNT,"RDCURR")=$P(NODE,"^",6)
;
Q 1
;
NATNAME(CODE) ;
;Description: Given an entry in file #8, Eligibility Code file,
; finds the corresponding entry in file 8.1, MAS Eligibility Code file,
; and returns the name
;Input:
; CODE - pointer to file #8
;Output:
; Function Value - name of corresponding code in file #8.1
;
Q:'$G(CODE) ""
Q $$CODENAME($P($G(^DIC(8,CODE,0)),"^",9))
;
NATCODE(CODE) ;
;Description: Given an entry in file #8, Eligibility Code file,
; finds the corresponding entry in file 8.1, MAS Eligibility Code file
;Input:
; CODE - pointer to file #8
;Output:
; Function Value - pointer to file #8.1
;
Q:'$G(CODE) ""
Q $P($G(^DIC(8,CODE,0)),"^",9)
;
CODENAME(CODE) ;
;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
; it returns the name of the code
;Input:
; CODE - pointer to file #8.1
;Output:
; Function Value - name of the code pointed to
;
Q:'$G(CODE) ""
Q $P($G(^DIC(8.1,CODE,0)),"^")
;
ELIGSTAT(DFN,DGELG) ;
;Description: Used to get the ELIGIBILITY STATUS and the
;ELIGIBILITY STATUS DATE of the patient.
;
;Input:
; DFN - ien of patient record
;
;Output:
; Function Value - 1 on success, 0 on failure
; DGELG array (pass by reference)
; "ELIGSTA" - ELIGIBILITY STATUS
; "ELIGSTADATE" - ELIGIBILITY STATUS DATE
;
N NODE,SUCCESS
D
.S SUCCESS=1
.I '$G(DFN) S SUCCESS=0 Q
.S NODE=$G(^DPT(DFN,.361))
.S DGELG("ELIGSTA")=$P(NODE,"^")
.S DGELG("ELIGSTADATE")=$P(NODE,"^",2)
Q SUCCESS
;
;
CAI(DFN) ;DG*5.3*1061 - COMPACT Act Indicator
;Description: Used to check if the patient is COMPACT ACT eligible.
;
;Input:
; DFN - ien of patient record
;
;Output:
; Function Value - 1 for ELIGIBLE, (The patient is enrolled or has eligibility COMPACT ACT ELIGIBLE)
; 0 for Not Eligible
;
I '+$G(DFN) Q 0
N DGENCAT,DGSTATUS,DGVLE,DGELIGSTAT
S DGELIGSTAT=0
S DGSTATUS=$$STATUS^DGENA($G(DFN))
S DGENCAT=$$CATEGORY^DGENA4(DFN,$G(DGSTATUS)) ;enrollment category
S DGVLE=$$HASELIG(DFN,"COMPACT ACT ELIGIBLE")
I (DGVLE)!(DGENCAT="E") S DGELIGSTAT=1
Q DGELIGSTAT
;
HASELIG(DFN,DGELIG) ;DG*5.3*1061
;Description: Checks if patient has a specific MAS eligibility in their record
;ICR 10061 NAME: ELIG^VADPT
;
;Inputs:
; DFN - ien of patient record
; DGELIG - MAS Name of the eligibility (from file MAS ELIGIBILITY CODE file #8.1)
;
; Return value:
; - 0 if DGELIG not in the record
; - 1 if DGELIG is the Primary eligibility in the patient record
; - 2 if DGELIG is a Secondary eligibility in the patient record
;
N VAEL,DGX,DGRET,DGPE,DGSE
; get array VAEL which contains patient's eligibilities
D ELIG^VADPT
S DGRET=0
; get the Primary eligibility number
S DGPE=$P($G(VAEL(1)),"^",1)
; Get the national name of that eligibility and if it matches, return 1
I $$NATNAME(DGPE)=DGELIG S DGRET=1
; If not primary, loop over the array looking for DGELIG in list of secondary eligibilities
I 'DGRET S DGX="" F S DGX=$O(VAEL(1,DGX)) Q:'DGX D Q:DGRET
. S DGSE=$P(VAEL(1,DGX),"^",1)
. ; Get the national name of that eligibility and if it matches, return 2
. I $$NATNAME(DGSE)=DGELIG S DGRET=2
Q DGRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENELA 10054 printed Oct 16, 2024@18:43:19 Page 2
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
+2 ;
GET(DFN,DGELG) ;
+1 ;Description: Used to obtain the patient eligibility data.
+2 ; The data is placed in the local DGELG array.
+3 ;Input:
+4 ; DFN - internal entry number of a record in the PATIENT file
+5 ;Output:
+6 ; Function Value - returns 1 on success, 0 on failure
+7 ; 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)
+8 ;
+9 ;subscript field name
+10 ;"DFN" ien Patient record
+11 ;"ELIG","CODE" Primary Eligibility Code
+12 ;"ELIG","CODE",<ien> Patient Eligibilities
+13 ;"SC" Service Connected
+14 ;"SCPER" Service Connected Percentage
+15 ;"EFFDT" SC Combined Effective Date
+16 ;"POW" POW Status Indicated
+17 ;"A&A" Receiving A&A Benefits
+18 ;"HB" Receiving Housebound Benefits
+19 ;"VAPEN" Receiving a VA Pension
+20 ;"VACKAMT" Total Annual VA Check Amount
+21 ;"DISRET" Military Disability Retirement
+22 ;"DISLOD" Discharge Due to Disability (added with DG 672)
+23 ;"MEDICAID" Medicaid
+24 ;"MEDASKDT" Date Medicaid Last Asked
+25 ;"AO" Exposed to Agent Orange
+26 ;"IR" Radiation Exposure Indicated
+27 ;"RADEXPM" Radiation Exposure Method
+28 ;"EC" SW Asia Cond - change from Env Con, DG*5.3*688
+29 ;"MTSTA" Means Test Status
+30 ;P&T P&T
+31 ;P&TDT P&T EFFECTIVE DATE (added with DG 688)
+32 ;POS PERIOD OF SERVICE
+33 ;UNEMPLOY UNEMPLOYABLE
+34 ;SCAWDATE SC AWARD DATE
+35 ;RATEINC RATED INCOMPETENT
+36 ;CLAIMNUM CLAIM NUMBER
+37 ;CLAIMLOC CLAIM FOLDER LOCATION
+38 ;VADISAB RECEIVING VA DISABILITY?
+39 ;ELIGSTA ELIGIBILITY STATUS
+40 ;ELIGSTADATE ELIGIBILITY STATUS DATE
+41 ;ELIGVERIF ELIGIBILITY VERIF. METHOD
+42 ;ELIGVSITE ELIGIBILITY VERIFICATION SITE
+43 ;ELIGENTBY ELIGIBILITY STATUS ENTERED BY
+44 ;RATEDIS
+45 ; <COUNT>,"RD" RATED DISABILITY
+46 ; <COUNT>,"PER" DISABILITY %
+47 ; <COUNT>,"RDSC" SERVICE CONNECTED
+48 ; <COUNT>,"RDEXT" EXTREMITY
+49 ; <COUNT>,"RDORIG" ORIGINAL RD EFFECTIVE DATE
+50 ; <COUNT>."RDCURR" CURRENT RD EFFECTIVE DATE
+51 ;"VCD" Veteran Catastrophically Disabled? (#.39)
+52 ;"PH" PURPLE HEART INDICATED
+53 ;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION
+54 ;"CVELEDT" COMBAT VETERAN END DATE
+55 ;"SHAD" SHAD EXPOSURE
+56 ;"MOH" MEDAL OF HONOR
+57 ;"MOHAWRDDATE" MEDAL OF HONOR AWARD DATE
+58 ;"MOHSTATDATE" MEDAL OF HONOR CHANGE DATE
+59 ;"MOHEXEMPDATE" MEDAL OF HONOR COPAYMENT EXEMPTION DATE
+60 ;"CLE" CAMP LEJEUNE INDICATED?
+61 ;"CLEDT" CAMP LEJEUNE DATE
+62 ;"CLEST" CAMP LEJEUNE CHANGE SITE
+63 ;"CLESOR" CAMP LEJEUNE SOURCE
+64 ;"OTHTYPE" EXPANDED MH CARE TYPE (OTH)
+65 ;
+66 KILL DGELG
+67 SET DGELG=""
+68 if '$DATA(^DPT(DFN))
QUIT 0
+69 NEW NODE,SUBREC,COUNT,CODE,IEN
+70 ;
+71 SET DGELG("DFN")=DFN
+72 SET DGELG("VCD")=$$VCD^DGENA5(DFN)
+73 ;
+74 ;
+75 SET NODE=$GET(^DPT(DFN,.29))
+76 SET DGELG("RATEINC")=$PIECE(NODE,"^",12)
+77 ;
+78 SET NODE=$GET(^DPT(DFN,.3))
+79 SET DGELG("SC")=$PIECE(NODE,"^")
+80 SET DGELG("SCPER")=$PIECE(NODE,"^",2)
+81 SET DGELG("P&T")=$PIECE(NODE,"^",4)
+82 SET DGELG("P&TDT")=$PIECE(NODE,"^",13)
+83 SET DGELG("UNEMPLOY")=$PIECE(NODE,"^",5)
+84 SET DGELG("SCAWDATE")=$PIECE(NODE,"^",12)
+85 SET DGELG("VADISAB")=$PIECE(NODE,"^",11)
+86 SET DGELG("EFFDT")=$PIECE(NODE,"^",14)
+87 ;
+88 SET NODE=$GET(^DPT(DFN,.31))
+89 SET DGELG("CLAIMNUM")=$PIECE(NODE,"^",3)
+90 SET DGELG("CLAIMLOC")=$PIECE(NODE,"^",4)
+91 ;
+92 SET NODE=$GET(^DPT(DFN,.32))
+93 SET DGELG("POS")=$PIECE(NODE,"^",3)
+94 ;
+95 SET NODE=$GET(^DPT(DFN,.36))
+96 ;primary eligibility
SET DGELG("ELIG","CODE")=$PIECE(NODE,"^")
+97 SET DGELG("DISRET")=$PIECE(NODE,"^",12)
+98 SET DGELG("DISLOD")=$PIECE(NODE,"^",13)
+99 ;
+100 SET NODE=$GET(^DPT(DFN,.38))
+101 SET DGELG("MEDICAID")=$PIECE(NODE,"^")
+102 ;Date Medicaid Last Asked
SET DGELG("MEDASKDT")=$PIECE(NODE,"^",2)
+103 ;
+104 SET NODE=$GET(^DPT(DFN,.361))
+105 SET DGELG("ELIGSTA")=$PIECE(NODE,"^")
+106 SET DGELG("ELIGSTADATE")=$PIECE(NODE,"^",2)
+107 SET DGELG("ELIGVERIF")=$PIECE(NODE,"^",5)
+108 SET DGELG("ELIGENTBY")=$PIECE(NODE,"^",6)
+109 ;
+110 SET NODE=$GET(^DPT(DFN,.362))
+111 SET DGELG("VACKAMT")=$PIECE(NODE,"^",20)
+112 SET DGELG("VAPEN")=$PIECE(NODE,"^",14)
+113 SET DGELG("A&A")=$PIECE(NODE,"^",12)
+114 SET DGELG("HB")=$PIECE(NODE,"^",13)
+115 ;
+116 ;
+117 SET NODE=$GET(^DPT(DFN,.321))
+118 SET DGELG("AO")=$PIECE(NODE,"^",2)
+119 SET DGELG("IR")=$PIECE(NODE,"^",3)
+120 SET DGELG("RADEXPM")=$PIECE(NODE,"^",12)
+121 SET DGELG("AOEXPLOC")=$PIECE(NODE,"^",13)
+122 ;added with DG*5.3*653
SET DGELG("SHAD")=$PIECE(NODE,"^",15)
+123 ;
+124 SET NODE=$GET(^DPT(DFN,.322))
+125 SET DGELG("EC")=$PIECE(NODE,"^",13)
+126 ;
+127 SET NODE=$GET(^DPT(DFN,.52))
+128 SET DGELG("POW")=$PIECE(NODE,"^",5)
+129 SET DGELG("CVELEDT")=$PIECE(NODE,"^",15)
+130 ;
+131 ; Purple Heart Indicator
+132 SET NODE=$GET(^DPT(DFN,.53))
+133 SET DGELG("PH")=$PIECE(NODE,"^")
+134 ;
+135 ; Medal of Honor Indicator
+136 SET NODE=$GET(^DPT(DFN,.54))
+137 SET DGELG("MOH")=$PIECE(NODE,"^",1)
+138 ;MH AWARD DATE DG*5.3*972 HM
SET DGELG("MOHAWRDDATE")=$PIECE(NODE,"^",2)
+139 ;MH STATUS DATE DG*5.3*972 HM
SET DGELG("MOHSTATDATE")=$PIECE(NODE,"^",3)
+140 ;MH COPAYMENT EXEMPTION DATE DG*5.3*972 HM
SET DGELG("MOHEXEMPDATE")=$PIECE(NODE,"^",4)
+141 ;
+142 ; Camp Lejeune Eligibility Indicator DG*5.3*909
+143 SET NODE=$GET(^DPT(DFN,.3217))
+144 SET DGELG("CLE")=$PIECE(NODE,"^",1)
+145 SET DGELG("CLEDT")=$PIECE(NODE,"^",2)
+146 SET DGELG("CLEST")=$PIECE(NODE,"^",3)
+147 SET DGELG("CLESOR")=$PIECE(NODE,"^",4)
+148 ;
+149 ; Expanded MH care type for OTH patients DG*5.3*952
+150 SET NODE=$GET(^DPT(DFN,.55))
+151 SET DGELG("OTHTYPE")=$PIECE(NODE,U)
+152 ;
+153 ;means test category
+154 SET DGELG("MTSTA")=""
+155 SET IEN=$PIECE($$LST^DGMTU(DFN),"^")
+156 IF IEN
SET DGELG("MTSTA")=$PIECE($GET(^DGMT(408.31,IEN,0)),"^",3)
+157 ;
+158 ;get the other eligibilities multiple
+159 SET SUBREC=0
+160 FOR
SET SUBREC=$ORDER(^DPT(DFN,"E",SUBREC))
if 'SUBREC
QUIT
Begin DoDot:1
+161 SET CODE=+$GET(^DPT(DFN,"E",SUBREC,0))
+162 ;
+163 ;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
+164 IF CODE
IF $DATA(^DPT(DFN,"E","B",CODE))
SET DGELG("ELIG","CODE",CODE)=SUBREC
End DoDot:1
+165 ;
+166 ;rated disability multiple
+167 SET SUBREC=0
SET COUNT=0
+168 FOR
SET SUBREC=$ORDER(^DPT(DFN,.372,SUBREC))
if 'SUBREC
QUIT
Begin DoDot:1
+169 SET NODE=$GET(^DPT(DFN,.372,SUBREC,0))
+170 if '$PIECE(NODE,"^")
QUIT
+171 SET COUNT=COUNT+1
+172 SET DGELG("RATEDIS",COUNT,"RD")=$PIECE(NODE,"^")
+173 SET DGELG("RATEDIS",COUNT,"PER")=$PIECE(NODE,"^",2)
+174 SET DGELG("RATEDIS",COUNT,"RDSC")=$PIECE(NODE,"^",3)
+175 SET DGELG("RATEDIS",COUNT,"RDEXT")=$PIECE(NODE,"^",4)
+176 SET DGELG("RATEDIS",COUNT,"RDORIG")=$PIECE(NODE,"^",5)
+177 SET DGELG("RATEDIS",COUNT,"RDCURR")=$PIECE(NODE,"^",6)
End DoDot:1
+178 ;
+179 QUIT 1
+180 ;
NATNAME(CODE) ;
+1 ;Description: Given an entry in file #8, Eligibility Code file,
+2 ; finds the corresponding entry in file 8.1, MAS Eligibility Code file,
+3 ; and returns the name
+4 ;Input:
+5 ; CODE - pointer to file #8
+6 ;Output:
+7 ; Function Value - name of corresponding code in file #8.1
+8 ;
+9 if '$GET(CODE)
QUIT ""
+10 QUIT $$CODENAME($PIECE($GET(^DIC(8,CODE,0)),"^",9))
+11 ;
NATCODE(CODE) ;
+1 ;Description: Given an entry in file #8, Eligibility Code file,
+2 ; finds the corresponding entry in file 8.1, MAS Eligibility Code file
+3 ;Input:
+4 ; CODE - pointer to file #8
+5 ;Output:
+6 ; Function Value - pointer to file #8.1
+7 ;
+8 if '$GET(CODE)
QUIT ""
+9 QUIT $PIECE($GET(^DIC(8,CODE,0)),"^",9)
+10 ;
CODENAME(CODE) ;
+1 ;Description: Given a pointer to file #8.1, MAS Eligibility Code file,
+2 ; it returns the name of the code
+3 ;Input:
+4 ; CODE - pointer to file #8.1
+5 ;Output:
+6 ; Function Value - name of the code pointed to
+7 ;
+8 if '$GET(CODE)
QUIT ""
+9 QUIT $PIECE($GET(^DIC(8.1,CODE,0)),"^")
+10 ;
ELIGSTAT(DFN,DGELG) ;
+1 ;Description: Used to get the ELIGIBILITY STATUS and the
+2 ;ELIGIBILITY STATUS DATE of the patient.
+3 ;
+4 ;Input:
+5 ; DFN - ien of patient record
+6 ;
+7 ;Output:
+8 ; Function Value - 1 on success, 0 on failure
+9 ; DGELG array (pass by reference)
+10 ; "ELIGSTA" - ELIGIBILITY STATUS
+11 ; "ELIGSTADATE" - ELIGIBILITY STATUS DATE
+12 ;
+13 NEW NODE,SUCCESS
+14 Begin DoDot:1
+15 SET SUCCESS=1
+16 IF '$GET(DFN)
SET SUCCESS=0
QUIT
+17 SET NODE=$GET(^DPT(DFN,.361))
+18 SET DGELG("ELIGSTA")=$PIECE(NODE,"^")
+19 SET DGELG("ELIGSTADATE")=$PIECE(NODE,"^",2)
End DoDot:1
+20 QUIT SUCCESS
+21 ;
+22 ;
CAI(DFN) ;DG*5.3*1061 - COMPACT Act Indicator
+1 ;Description: Used to check if the patient is COMPACT ACT eligible.
+2 ;
+3 ;Input:
+4 ; DFN - ien of patient record
+5 ;
+6 ;Output:
+7 ; Function Value - 1 for ELIGIBLE, (The patient is enrolled or has eligibility COMPACT ACT ELIGIBLE)
+8 ; 0 for Not Eligible
+9 ;
+10 IF '+$GET(DFN)
QUIT 0
+11 NEW DGENCAT,DGSTATUS,DGVLE,DGELIGSTAT
+12 SET DGELIGSTAT=0
+13 SET DGSTATUS=$$STATUS^DGENA($GET(DFN))
+14 ;enrollment category
SET DGENCAT=$$CATEGORY^DGENA4(DFN,$GET(DGSTATUS))
+15 SET DGVLE=$$HASELIG(DFN,"COMPACT ACT ELIGIBLE")
+16 IF (DGVLE)!(DGENCAT="E")
SET DGELIGSTAT=1
+17 QUIT DGELIGSTAT
+18 ;
HASELIG(DFN,DGELIG) ;DG*5.3*1061
+1 ;Description: Checks if patient has a specific MAS eligibility in their record
+2 ;ICR 10061 NAME: ELIG^VADPT
+3 ;
+4 ;Inputs:
+5 ; DFN - ien of patient record
+6 ; DGELIG - MAS Name of the eligibility (from file MAS ELIGIBILITY CODE file #8.1)
+7 ;
+8 ; Return value:
+9 ; - 0 if DGELIG not in the record
+10 ; - 1 if DGELIG is the Primary eligibility in the patient record
+11 ; - 2 if DGELIG is a Secondary eligibility in the patient record
+12 ;
+13 NEW VAEL,DGX,DGRET,DGPE,DGSE
+14 ; get array VAEL which contains patient's eligibilities
+15 DO ELIG^VADPT
+16 SET DGRET=0
+17 ; get the Primary eligibility number
+18 SET DGPE=$PIECE($GET(VAEL(1)),"^",1)
+19 ; Get the national name of that eligibility and if it matches, return 1
+20 IF $$NATNAME(DGPE)=DGELIG
SET DGRET=1
+21 ; If not primary, loop over the array looking for DGELIG in list of secondary eligibilities
+22 IF 'DGRET
SET DGX=""
FOR
SET DGX=$ORDER(VAEL(1,DGX))
if 'DGX
QUIT
Begin DoDot:1
+23 SET DGSE=$PIECE(VAEL(1,DGX),"^",1)
+24 ; Get the national name of that eligibility and if it matches, return 2
+25 IF $$NATNAME(DGSE)=DGELIG
SET DGRET=2
End DoDot:1
if DGRET
QUIT
+26 QUIT DGRET
