- 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 Jan 18, 2025@03:43:21 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