DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 9/19/06 9:27am
;;5.3;PIMS;**121,147,232,314,451,564,631,672,659,583,653,688,1015,1016**;JUN 30, 2012;Build 20
;
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
;
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,"^")
;
;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 Eligbility 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 Eligbility 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
;
;Ouput:
; 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
DGENELA ;ALB/CJM,KCL,Zoltan/PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 9/19/06 9:27am
+1 ;;5.3;PIMS;**121,147,232,314,451,564,631,672,659,583,653,688,1015,1016**;JUN 30, 2012;Build 20
+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 ;
+57 KILL DGELG
+58 SET DGELG=""
+59 IF '$DATA(^DPT(DFN))
QUIT 0
+60 NEW NODE,SUBREC,COUNT,CODE,IEN
+61 ;
+62 SET DGELG("DFN")=DFN
+63 SET DGELG("VCD")=$$VCD^DGENA5(DFN)
+64 ;
+65 ;
+66 SET NODE=$GET(^DPT(DFN,.29))
+67 SET DGELG("RATEINC")=$PIECE(NODE,"^",12)
+68 ;
+69 SET NODE=$GET(^DPT(DFN,.3))
+70 SET DGELG("SC")=$PIECE(NODE,"^")
+71 SET DGELG("SCPER")=$PIECE(NODE,"^",2)
+72 SET DGELG("P&T")=$PIECE(NODE,"^",4)
+73 SET DGELG("P&TDT")=$PIECE(NODE,"^",13)
+74 SET DGELG("UNEMPLOY")=$PIECE(NODE,"^",5)
+75 SET DGELG("SCAWDATE")=$PIECE(NODE,"^",12)
+76 SET DGELG("VADISAB")=$PIECE(NODE,"^",11)
+77 SET DGELG("EFFDT")=$PIECE(NODE,"^",14)
+78 ;
+79 SET NODE=$GET(^DPT(DFN,.31))
+80 SET DGELG("CLAIMNUM")=$PIECE(NODE,"^",3)
+81 SET DGELG("CLAIMLOC")=$PIECE(NODE,"^",4)
+82 ;
+83 SET NODE=$GET(^DPT(DFN,.32))
+84 SET DGELG("POS")=$PIECE(NODE,"^",3)
+85 ;
+86 SET NODE=$GET(^DPT(DFN,.36))
+87 ;primary eligibility
SET DGELG("ELIG","CODE")=$PIECE(NODE,"^")
+88 SET DGELG("DISRET")=$PIECE(NODE,"^",12)
+89 SET DGELG("DISLOD")=$PIECE(NODE,"^",13)
+90 ;
+91 SET NODE=$GET(^DPT(DFN,.38))
+92 SET DGELG("MEDICAID")=$PIECE(NODE,"^")
+93 ;Date Medicaid Last Asked
SET DGELG("MEDASKDT")=$PIECE(NODE,"^",2)
+94 ;
+95 SET NODE=$GET(^DPT(DFN,.361))
+96 SET DGELG("ELIGSTA")=$PIECE(NODE,"^")
+97 SET DGELG("ELIGSTADATE")=$PIECE(NODE,"^",2)
+98 SET DGELG("ELIGVERIF")=$PIECE(NODE,"^",5)
+99 SET DGELG("ELIGENTBY")=$PIECE(NODE,"^",6)
+100 ;
+101 SET NODE=$GET(^DPT(DFN,.362))
+102 SET DGELG("VACKAMT")=$PIECE(NODE,"^",20)
+103 SET DGELG("VAPEN")=$PIECE(NODE,"^",14)
+104 SET DGELG("A&A")=$PIECE(NODE,"^",12)
+105 SET DGELG("HB")=$PIECE(NODE,"^",13)
+106 ;
+107 ;
+108 SET NODE=$GET(^DPT(DFN,.321))
+109 SET DGELG("AO")=$PIECE(NODE,"^",2)
+110 SET DGELG("IR")=$PIECE(NODE,"^",3)
+111 SET DGELG("RADEXPM")=$PIECE(NODE,"^",12)
+112 SET DGELG("AOEXPLOC")=$PIECE(NODE,"^",13)
+113 ;added with DG*5.3*653
SET DGELG("SHAD")=$PIECE(NODE,"^",15)
+114 ;
+115 SET NODE=$GET(^DPT(DFN,.322))
+116 SET DGELG("EC")=$PIECE(NODE,"^",13)
+117 ;
+118 SET NODE=$GET(^DPT(DFN,.52))
+119 SET DGELG("POW")=$PIECE(NODE,"^",5)
+120 SET DGELG("CVELEDT")=$PIECE(NODE,"^",15)
+121 ;
+122 ; Purple Heart Indicator
+123 SET NODE=$GET(^DPT(DFN,.53))
+124 SET DGELG("PH")=$PIECE(NODE,"^")
+125 ;
+126 ;means test category
+127 SET DGELG("MTSTA")=""
+128 SET IEN=$PIECE($$LST^DGMTU(DFN),"^")
+129 IF IEN
SET DGELG("MTSTA")=$PIECE($GET(^DGMT(408.31,IEN,0)),"^",3)
+130 ;
+131 ;get the other eligibilities multiple
+132 SET SUBREC=0
+133 FOR
SET SUBREC=$ORDER(^DPT(DFN,"E",SUBREC))
IF 'SUBREC
QUIT
Begin DoDot:1
+134 SET CODE=+$GET(^DPT(DFN,"E",SUBREC,0))
+135 ;
+136 ;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
+137 IF CODE
IF $DATA(^DPT(DFN,"E","B",CODE))
SET DGELG("ELIG","CODE",CODE)=SUBREC
End DoDot:1
+138 ;
+139 ;rated disability multiple
+140 SET SUBREC=0
SET COUNT=0
+141 FOR
SET SUBREC=$ORDER(^DPT(DFN,.372,SUBREC))
IF 'SUBREC
QUIT
Begin DoDot:1
+142 SET NODE=$GET(^DPT(DFN,.372,SUBREC,0))
+143 IF '$PIECE(NODE,"^")
QUIT
+144 SET COUNT=COUNT+1
+145 SET DGELG("RATEDIS",COUNT,"RD")=$PIECE(NODE,"^")
+146 SET DGELG("RATEDIS",COUNT,"PER")=$PIECE(NODE,"^",2)
+147 SET DGELG("RATEDIS",COUNT,"RDSC")=$PIECE(NODE,"^",3)
+148 SET DGELG("RATEDIS",COUNT,"RDEXT")=$PIECE(NODE,"^",4)
+149 SET DGELG("RATEDIS",COUNT,"RDORIG")=$PIECE(NODE,"^",5)
+150 SET DGELG("RATEDIS",COUNT,"RDCURR")=$PIECE(NODE,"^",6)
End DoDot:1
+151 ;
+152 QUIT 1
+153 ;
NATNAME(CODE) ;
+1 ;Description: Given an entry in file #8, Eligibility Code file,
+2 ; finds the corresponding entry in file 8.1, MAS Eligbility 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 Eligbility 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 ;Ouput:
+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
