DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC,HM - Patient Eligibility API ;20 Jan 2015 3:27 PM
;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653,688,841,909,972,952**;Aug 13,1993;Build 160
;
CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ;
;Does validation checks on the eligibility contained in the DGELG array.
;
;Input:
; DGELG - array containing eligibility data (pass by reference)
; DGPAT - array containing patient data (pass by reference)
; DGCDIS - array containing catastrophic disability determination (pass by reference)
;
;Output:
; Function Value - returns 1 if all validation checks passed, 0 otherwise
; ERRMSG - returns a message if validations fail (pass by reference)
;
N SUCCESS,NATCODE,BAD,SUB,CODE,DGONV,DGTEXT,INELDATE
S SUCCESS=0
S ERRMSG=""
;
D ;drops out of block on failure
.;
.;get optional arrays if not there
.I '$D(DGPAT),'$$GET^DGENPTA(DGELG("DFN"),.DGPAT) S ERRMSG="PATIENT NOT FOUND" Q
.I '$D(DGCDIS),'$$GET^DGENCDA(DGELG("DFN"),.DGCDIS) S ERRMSG="PATIENT NOT FOUND" Q
.;
.;do field level checks
.S SUB="" F S SUB=$O(DGELG(SUB)) Q:(SUB="") I SUB'="ELIG",SUB'="RATEDIS",'$$CHKFIELD(SUB,DGELG(SUB)) S ERRMSG="BAD VALUE, FIELD = "_$$GET1^DID(2,$$FIELD(SUB),"","LABEL") Q
.;
.Q:(SUB'="") ;didn't finish the loop
.;
.;also check SC % field of Rated Disabilities
.S SUB="" F S SUB=$O(DGELG("RATEDIS",SUB)) Q:(SUB="") I '$$CHKFIELD("PER",DGELG("RATEDIS",SUB,"PER")) S ERRMSG="BAD VALUE, FIELD = DISABILITY % OF THE RATED DISABILITIES MULTIPLE" Q
.Q:(SUB'="") ;didn't finish the loop
.;
.I DGELG("SC")="Y",DGELG("SCPER")="" S ERRMSG="SC% UNSPECIFIED FOR SC VET" Q
.;
.;!! put this check back when POS is added to the Z11 message
.;I DGPAT("VETERAN")="Y",'DGELG("POS") S ERRMSG="POS UNSPECIFIED" Q
.;
.I 'DGELG("ELIG","CODE") S ERRMSG="PRIMARY ELIGIBILITY IS UNSPECIFIED" Q
.;
.I (DGELG("VACKAMT")>0),(DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y") S ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'" Q
.;
.;
.;
.I (DGELG("SC")="N"),(DGELG("VADISAB")="Y") S ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS" Q
.;
.S BAD=1 D Q:BAD ;check primary eligibility
..S NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
..Q:'NATCODE
..;
..I NATCODE=21 S ERRMSG="CATASTROPHICALLY DISABLED NOT ALLOWED AS PRIMARY ELIGIBILITY" Q
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")<50),(NATCODE'=3) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(DGELG("SCPER")>49),(NATCODE'=1) S ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE" Q
..;
..S DGONV=$O(^DIC(21,"B","OTHER NON-VETERANS","")),INELDATE=$P($G(^DPT(DFN,.15)),"^",2)
..I INELDATE'="",DGPAT("INELDATE")'>0,DGELG("POS"),DGELG("POS")=DGONV,'$D(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE"))) D
...S DGTEXT="Patient was previously determined to be ineligible for VA health care. Upon review, the individual is determined to be eligible for "
...S DGTEXT=DGTEXT_"VA care. Please update period of service and other eligibility data as needed.."
...D ADDMSG^DGENUPL3(.MSGS,DGTEXT,0)
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(NATCODE=1)!(NATCODE=3) S BAD=0 Q ;primary eligibility OK
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE'=18 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PRISONER OF WAR" Q
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("POW")="Y"),NATCODE=18 S BAD=0 Q
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE'=22 S ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PURPLE HEART RECIPIENT" Q
..;
..I (DGPAT("VETERAN")="Y"),(DGELG("PH")="Y"),NATCODE=22 S BAD=0 Q
..;
..; disabled DG*5.3*367, for Inel
..;I (DGPAT("VETERAN")'=$P($G(^DIC(8.1,NATCODE,0)),"^",5)) S ERRMSG="PRIMARY ELIGIBILTY NOT CONSISTENT WITH VETERAN STATUS" Q
..;
..I DGELG("A&A")'="Y",NATCODE=2 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH A&A INDICATOR" Q
..;
..I DGELG("HB")'="Y",NATCODE=15 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH HOUSEBOUND INDICATOR" Q
..;
..I DGELG("VAPEN")'="Y",NATCODE=4 S ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH VA PENSION INDICATOR" Q
..;
..I DGELG("SC")="Y",((NATCODE=4)!(NATCODE=5)) S ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR" Q
..;
..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q
..;
..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q
..;
..;primary eligibility is good
..S BAD=0
.;
.S SUCCESS=1
.;check eligibilities multiple
.S CODE=0 F S CODE=$O(DGELG("ELIG","CODE",CODE)) Q:'CODE D Q:('SUCCESS)
..S NATCODE=$$NATCODE^DGENELA(CODE)
..Q:'NATCODE
..I NATCODE=21,'DGCDIS("DATE") S SUCCESS=0,ERRMSG="CATASTROPHICALLY DISABLED ELIGIBILITY REQUIRES CATASTROPHICALLY DISABLED DETERMINATION DATE" Q
.;
Q SUCCESS
;
STORE(DGELG,DGPAT,DGCDIS,ERROR,SKIPCHK) ;
;Stores an eligibility record for a patient. The patient record must
;already exist. A lock on the Patient record is required, and is
;released upon completion.
;
;Input:
; DGELG - eligibility array (pass by reference)
; DGPAT - patient array (optional, pass by reference)
; DGCDIS - array containing the catastrophic disability determination (optional, pass by reference)
; SKIPCHK - flag, set to 1 means that the consistency checks
; were already done & should be skipped
;
;Output:
; Function Value - returns 1 if successful, otherwise 0
; ERROR - in event of failure returns an error message (pass by reference, optional)
;
N SUCCESS,DATA,FIELD,DA,DFN,COUNT,OTHSTAT,Z
S DFN=$G(DGELG("DFN"))
S SUCCESS=0
S ERROR=""
;
D ;drops out of block on failure
.I '$$LOCK^DGENPTA1(DFN) S ERROR="UNABLE TO LOCK PATIENT RECORD" Q
.I $G(SKIPCHK)'=1,'$$CHECK(.DGELG,.DGPAT,.DGCDIS,.ERROR) Q
.S SUB="" F S SUB=$O(DGELG(SUB)) Q:SUB="" D
..I SUB'="ELIG",SUB'="RATEDIS",SUB'="DFN" S FIELD=$$FIELD(SUB) I FIELD S DATA(FIELD)=DGELG(SUB)
.;lock Camp Lejeune when it comes over from HEC in Z11 - DG*5.3*909
.I "^Y^N^"[("^"_$G(DATA(.321701))_"^") S DATA(.32171)=1
.;
.;don't add the Primary Eligibility unless different, so as to not
.;fire off x-refs unless necessary
.I $P($G(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE") S DATA(.361)=DGELG("ELIG","CODE")
.;
.; Only update User Enrollee fields if the incoming UE status is
.; greater than the USER ENROLLEE VALID THROUGH on file.
.I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DATA(.3617),DATA(.3618)
.; update field 2/.5501 and entry in file 33
.I +$O(^DGOTH(33,"B",DFN,""))>0 S DATA(.5501)="" ; DG*5.3*952
.S OTHSTAT=$G(DGELG("OTH")) ; DG*5.3*952
.I "^0^1^"[(U_OTHSTAT_U) D ; ; DG*5.3*952
..S Z=$$FILSTAT^DGOTHUT1(DFN,OTHSTAT) I '+Z S ERROR="FILEMAN FAILED TO UPDATE FILE 33: "_$P(Z,U,2) Q ; DG*5.3*952
..I OTHSTAT=1 S DATA(.5501)=DGELG("OTHTYPE") ; DG*5.3*952
..Q ; DG*5.3*952
.;
.;update Patient file record with data from Z11
.D UPDZ11^DGENELA2
.;
.;delete eligibilities that do not belong
.D DELELIG^DGENELA2(DFN,.DGELG)
.;
.;overlay Rated Disabilities
.Q:'$$OVERLAY()
.;
.;Add the new Patient Eligibilities
.;Don't add the an eligibility unless different - so as to not
.;fire off the x-refs unless necessary.
.;Also, try to assign ien = the code (see input transform of the field).
.K DA,DATA
.S DA(1)=DFN
.S DATA(.01)=0
.F S DATA(.01)=$O(DGELG("ELIG","CODE",DATA(.01))) Q:'DATA(.01) I '$D(^DPT(DFN,"E","B",DATA(.01))) I '$$ADD^DGENDBS(2.0361,.DA,.DATA,,$S($D(^DPT(DFN,"E",DATA(.01))):0,1:DATA(.01))) S ERROR="FILEMAN FAILED TO ADD PATIENT ELIGIBILITY" Q
.;
.S SUCCESS=1
;
D UNLOCK^DGENPTA1(DFN)
Q SUCCESS
;
FIELD(SUB) ;
;given a subscript from the ELIGIBILITY array, returns the field number
;
Q:SUB="CODE" .361
Q:SUB="SC" .301
Q:SUB="SCPER" .302
Q:SUB="EFFDT" .3014
Q:SUB="POW" .525
Q:SUB="PH" .531
Q:SUB="A&A" .36205
Q:SUB="HB" .36215
Q:SUB="VAPEN" .36235
Q:SUB="VACKAMT" .36295
Q:SUB="DISRET" .3602
Q:SUB="DISLOD" .3603
Q:SUB="MEDICAID" .381
Q:SUB="MEDASKDT" .382 ;EVC - DG*5.3*653
Q:SUB="AO" .32102
Q:SUB="IR" .32103
Q:SUB="EC" .322013 ;name change from Env Con, DG*5.3*688
Q:SUB="MTSTA" "" ;don't map Means Test Category
Q:SUB="P&T" .304
Q:SUB="P&TDT" .3013 ;field added with DG*5.3*688
Q:SUB="POS" .323
Q:SUB="UNEMPLOY" .305
Q:SUB="SCAWDATE" .3012
Q:SUB="RATEINC" .293
Q:SUB="CLAIMNUM" .313
Q:SUB="CLAIMLOC" .314
Q:SUB="VADISAB" .3025
Q:SUB="ELIGSTA" .3611
Q:SUB="ELIGSTADATE" .3612
Q:SUB="ELIGVERIF" .3615
Q:SUB="ELIGENTBY" .3616
Q:SUB="RD" .01
Q:SUB="PER" 2
Q:SUB="RDSC" 3
Q:SUB="RDEXT" 4
Q:SUB="RDORIG" 5
Q:SUB="RDCURR" 6
Q:SUB="UEYEAR" .3617
Q:SUB="UESITE" .3618
Q:SUB="AOEXPLOC" .3213
Q:SUB="CVELEDT" .5295
Q:SUB="SHAD" .32115
Q:SUB="MOH" .541
Q:SUB="MOHAWRDDATE" .542 ;MOH AWARD DATE DG*5.3*972 HM
Q:SUB="MOHSTATDATE" .543 ;MOH STATUS DATE DG*5.3*972 HM
Q:SUB="MOHEXEMPDATE" .544 ;MOH COPAYMENT EXEMPTION DATE DG*5.3*972 HM
Q:SUB="CLE" .321701 ; Added for Camp Lejeune - DG*5.3*909
Q:SUB="CLEDT" .321702 ; Added for Camp Lejeune - DG*5.3*909
Q:SUB="CLEST" .321703 ; Added for Camp Lejeune - DG*5.3*909
Q:SUB="CLESOR" .321704 ; Added for Camp Lejeune - DG*5.3*909
;
Q ""
;
CHKFIELD(SUB,VAL) ;
;Description: Does field level validation of the value. Returns 1
;if the value is good, 0 otherwise.
;
Q:($G(VAL)="") 1 ;for now, all NULL values assumed okay
;
N BAD S BAD=0
I (SUB="SCPER")!(SUB="PER"),(+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N) S BAD=1
I SUB="VACKAMT",+VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0) S BAD=1
I SUB="DISRET",VAL'=0,VAL'=1 S BAD=1
I SUB="DISLOD",VAL'=0,VAL'=1 S BAD=1
I SUB="MEDICAID",VAL'=0,VAL'=1 S BAD=1
I SUB="RATEINC",VAL'=0,VAL'=1 S BAD=1
I SUB="ELIGSTA",VAL'="P",VAL'="R",VAL'="V" S BAD=1
I SUB="POW",VAL'="Y",VAL'="N",VAL'="U" S BAD=1
Q 'BAD
;
;
OVERLAY() ;
;Description: Overlay the local Rated Disabilities with whatever HEC
;sent.
;
N SUCCESS S SUCCESS=1
;
;delete the rated disabilities multiple
D DELRDIS^DGENELA2(DFN)
;
;add the rated disabilities
K DATA,DA
S DA(1)=DFN
S COUNT=0
F S COUNT=$O(DGELG("RATEDIS",COUNT)) Q:'COUNT D
.S DATA(.01)=DGELG("RATEDIS",COUNT,"RD")
.I DATA(.01) D
..S DATA(2)=DGELG("RATEDIS",COUNT,"PER")
..S DATA(3)=DGELG("RATEDIS",COUNT,"RDSC")
..S DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT")
..S DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG")
..S DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR")
..I '$$ADD^DGENDBS(2.04,.DA,.DATA) S ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES",SUCCESS=0
Q SUCCESS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENELA1 10872 printed Sep 23, 2025@20:18:32 Page 2
DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC,HM - Patient Eligibility API ;20 Jan 2015 3:27 PM
+1 ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653,688,841,909,972,952**;Aug 13,1993;Build 160
+2 ;
CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ;
+1 ;Does validation checks on the eligibility contained in the DGELG array.
+2 ;
+3 ;Input:
+4 ; DGELG - array containing eligibility data (pass by reference)
+5 ; DGPAT - array containing patient data (pass by reference)
+6 ; DGCDIS - array containing catastrophic disability determination (pass by reference)
+7 ;
+8 ;Output:
+9 ; Function Value - returns 1 if all validation checks passed, 0 otherwise
+10 ; ERRMSG - returns a message if validations fail (pass by reference)
+11 ;
+12 NEW SUCCESS,NATCODE,BAD,SUB,CODE,DGONV,DGTEXT,INELDATE
+13 SET SUCCESS=0
+14 SET ERRMSG=""
+15 ;
+16 ;drops out of block on failure
Begin DoDot:1
+17 ;
+18 ;get optional arrays if not there
+19 IF '$DATA(DGPAT)
IF '$$GET^DGENPTA(DGELG("DFN"),.DGPAT)
SET ERRMSG="PATIENT NOT FOUND"
QUIT
+20 IF '$DATA(DGCDIS)
IF '$$GET^DGENCDA(DGELG("DFN"),.DGCDIS)
SET ERRMSG="PATIENT NOT FOUND"
QUIT
+21 ;
+22 ;do field level checks
+23 SET SUB=""
FOR
SET SUB=$ORDER(DGELG(SUB))
if (SUB="")
QUIT
IF SUB'="ELIG"
IF SUB'="RATEDIS"
IF '$$CHKFIELD(SUB,DGELG(SUB))
SET ERRMSG="BAD VALUE, FIELD = "_$$GET1^DID(2,$$FIELD(SUB),"","LABEL")
QUIT
+24 ;
+25 ;didn't finish the loop
if (SUB'="")
QUIT
+26 ;
+27 ;also check SC % field of Rated Disabilities
+28 SET SUB=""
FOR
SET SUB=$ORDER(DGELG("RATEDIS",SUB))
if (SUB="")
QUIT
IF '$$CHKFIELD("PER",DGELG("RATEDIS",SUB,"PER"))
SET ERRMSG="BAD VALUE, FIELD = DISABILITY % OF THE RATED DISABILITIES MULTIPLE"
QUIT
+29 ;didn't finish the loop
if (SUB'="")
QUIT
+30 ;
+31 IF DGELG("SC")="Y"
IF DGELG("SCPER")=""
SET ERRMSG="SC% UNSPECIFIED FOR SC VET"
QUIT
+32 ;
+33 ;!! put this check back when POS is added to the Z11 message
+34 ;I DGPAT("VETERAN")="Y",'DGELG("POS") S ERRMSG="POS UNSPECIFIED" Q
+35 ;
+36 IF 'DGELG("ELIG","CODE")
SET ERRMSG="PRIMARY ELIGIBILITY IS UNSPECIFIED"
QUIT
+37 ;
+38 IF (DGELG("VACKAMT")>0)
IF (DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y")
SET ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'"
QUIT
+39 ;
+40 ;
+41 ;
+42 IF (DGELG("SC")="N")
IF (DGELG("VADISAB")="Y")
SET ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS"
QUIT
+43 ;
+44 ;check primary eligibility
SET BAD=1
Begin DoDot:2
+45 SET NATCODE=$$NATCODE^DGENELA(DGELG("ELIG","CODE"))
+46 if 'NATCODE
QUIT
+47 ;
+48 IF NATCODE=21
SET ERRMSG="CATASTROPHICALLY DISABLED NOT ALLOWED AS PRIMARY ELIGIBILITY"
QUIT
+49 ;
+50 IF (DGPAT("VETERAN")="Y")
IF (DGELG("SC")="Y")
IF (DGELG("SCPER")<50)
IF (NATCODE'=3)
SET ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE"
QUIT
+51 ;
+52 IF (DGPAT("VETERAN")="Y")
IF (DGELG("SC")="Y")
IF (DGELG("SCPER")>49)
IF (NATCODE'=1)
SET ERRMSG="PRIMARY ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTED PERCENTAGE"
QUIT
+53 ;
+54 SET DGONV=$ORDER(^DIC(21,"B","OTHER NON-VETERANS",""))
SET INELDATE=$PIECE($GET(^DPT(DFN,.15)),"^",2)
+55 IF INELDATE'=""
IF DGPAT("INELDATE")'>0
IF DGELG("POS")
IF DGELG("POS")=DGONV
IF '$DATA(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE")))
Begin DoDot:3
+56 SET DGTEXT="Patient was previously determined to be ineligible for VA health care. Upon review, the individual is determined to be eligible for "
+57 SET DGTEXT=DGTEXT_"VA care. Please update period of service and other eligibility data as needed.."
+58 DO ADDMSG^DGENUPL3(.MSGS,DGTEXT,0)
End DoDot:3
+59 ;
+60 ;primary eligibility OK
IF (DGPAT("VETERAN")="Y")
IF (DGELG("SC")="Y")
IF (NATCODE=1)!(NATCODE=3)
SET BAD=0
QUIT
+61 ;
+62 IF (DGPAT("VETERAN")="Y")
IF (DGELG("POW")="Y")
IF NATCODE'=18
SET ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PRISONER OF WAR"
QUIT
+63 ;
+64 IF (DGPAT("VETERAN")="Y")
IF (DGELG("POW")="Y")
IF NATCODE=18
SET BAD=0
QUIT
+65 ;
+66 IF (DGPAT("VETERAN")="Y")
IF (DGELG("PH")="Y")
IF NATCODE'=22
SET ERRMSG="PRIMARY ELIGIBILITY SHOULD BE PURPLE HEART RECIPIENT"
QUIT
+67 ;
+68 IF (DGPAT("VETERAN")="Y")
IF (DGELG("PH")="Y")
IF NATCODE=22
SET BAD=0
QUIT
+69 ;
+70 ; disabled DG*5.3*367, for Inel
+71 ;I (DGPAT("VETERAN")'=$P($G(^DIC(8.1,NATCODE,0)),"^",5)) S ERRMSG="PRIMARY ELIGIBILTY NOT CONSISTENT WITH VETERAN STATUS" Q
+72 ;
+73 IF DGELG("A&A")'="Y"
IF NATCODE=2
SET ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH A&A INDICATOR"
QUIT
+74 ;
+75 IF DGELG("HB")'="Y"
IF NATCODE=15
SET ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH HOUSEBOUND INDICATOR"
QUIT
+76 ;
+77 IF DGELG("VAPEN")'="Y"
IF NATCODE=4
SET ERRMSG="PRIMARY ELIGIBILITY INCONSISTENT WITH VA PENSION INDICATOR"
QUIT
+78 ;
+79 IF DGELG("SC")="Y"
IF ((NATCODE=4)!(NATCODE=5))
SET ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR"
QUIT
+80 ;
+81 IF (DGPAT("DOB")>2061231)
IF (NATCODE=16)
SET ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR"
QUIT
+82 ;
+83 IF (DGPAT("DOB")>2071231)
IF (NATCODE=17)
SET ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I"
QUIT
+84 ;
+85 ;primary eligibility is good
+86 SET BAD=0
End DoDot:2
if BAD
QUIT
+87 ;
+88 SET SUCCESS=1
+89 ;check eligibilities multiple
+90 SET CODE=0
FOR
SET CODE=$ORDER(DGELG("ELIG","CODE",CODE))
if 'CODE
QUIT
Begin DoDot:2
+91 SET NATCODE=$$NATCODE^DGENELA(CODE)
+92 if 'NATCODE
QUIT
+93 IF NATCODE=21
IF 'DGCDIS("DATE")
SET SUCCESS=0
SET ERRMSG="CATASTROPHICALLY DISABLED ELIGIBILITY REQUIRES CATASTROPHICALLY DISABLED DETERMINATION DATE"
QUIT
End DoDot:2
if ('SUCCESS)
QUIT
+94 ;
End DoDot:1
+95 QUIT SUCCESS
+96 ;
STORE(DGELG,DGPAT,DGCDIS,ERROR,SKIPCHK) ;
+1 ;Stores an eligibility record for a patient. The patient record must
+2 ;already exist. A lock on the Patient record is required, and is
+3 ;released upon completion.
+4 ;
+5 ;Input:
+6 ; DGELG - eligibility array (pass by reference)
+7 ; DGPAT - patient array (optional, pass by reference)
+8 ; DGCDIS - array containing the catastrophic disability determination (optional, pass by reference)
+9 ; SKIPCHK - flag, set to 1 means that the consistency checks
+10 ; were already done & should be skipped
+11 ;
+12 ;Output:
+13 ; Function Value - returns 1 if successful, otherwise 0
+14 ; ERROR - in event of failure returns an error message (pass by reference, optional)
+15 ;
+16 NEW SUCCESS,DATA,FIELD,DA,DFN,COUNT,OTHSTAT,Z
+17 SET DFN=$GET(DGELG("DFN"))
+18 SET SUCCESS=0
+19 SET ERROR=""
+20 ;
+21 ;drops out of block on failure
Begin DoDot:1
+22 IF '$$LOCK^DGENPTA1(DFN)
SET ERROR="UNABLE TO LOCK PATIENT RECORD"
QUIT
+23 IF $GET(SKIPCHK)'=1
IF '$$CHECK(.DGELG,.DGPAT,.DGCDIS,.ERROR)
QUIT
+24 SET SUB=""
FOR
SET SUB=$ORDER(DGELG(SUB))
if SUB=""
QUIT
Begin DoDot:2
+25 IF SUB'="ELIG"
IF SUB'="RATEDIS"
IF SUB'="DFN"
SET FIELD=$$FIELD(SUB)
IF FIELD
SET DATA(FIELD)=DGELG(SUB)
End DoDot:2
+26 ;lock Camp Lejeune when it comes over from HEC in Z11 - DG*5.3*909
+27 IF "^Y^N^"[("^"_$GET(DATA(.321701))_"^")
SET DATA(.32171)=1
+28 ;
+29 ;don't add the Primary Eligibility unless different, so as to not
+30 ;fire off x-refs unless necessary
+31 IF $PIECE($GET(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE")
SET DATA(.361)=DGELG("ELIG","CODE")
+32 ;
+33 ; Only update User Enrollee fields if the incoming UE status is
+34 ; greater than the USER ENROLLEE VALID THROUGH on file.
+35 IF $GET(DATA(.3617))<$PIECE($GET(^DPT(DFN,.361)),"^",7)
KILL DATA(.3617),DATA(.3618)
+36 ; update field 2/.5501 and entry in file 33
+37 ; DG*5.3*952
IF +$ORDER(^DGOTH(33,"B",DFN,""))>0
SET DATA(.5501)=""
+38 ; DG*5.3*952
SET OTHSTAT=$GET(DGELG("OTH"))
+39 ; ; DG*5.3*952
IF "^0^1^"[(U_OTHSTAT_U)
Begin DoDot:2
+40 ; DG*5.3*952
SET Z=$$FILSTAT^DGOTHUT1(DFN,OTHSTAT)
IF '+Z
SET ERROR="FILEMAN FAILED TO UPDATE FILE 33: "_$PIECE(Z,U,2)
QUIT
+41 ; DG*5.3*952
IF OTHSTAT=1
SET DATA(.5501)=DGELG("OTHTYPE")
+42 ; DG*5.3*952
QUIT
End DoDot:2
+43 ;
+44 ;update Patient file record with data from Z11
+45 DO UPDZ11^DGENELA2
+46 ;
+47 ;delete eligibilities that do not belong
+48 DO DELELIG^DGENELA2(DFN,.DGELG)
+49 ;
+50 ;overlay Rated Disabilities
+51 if '$$OVERLAY()
QUIT
+52 ;
+53 ;Add the new Patient Eligibilities
+54 ;Don't add the an eligibility unless different - so as to not
+55 ;fire off the x-refs unless necessary.
+56 ;Also, try to assign ien = the code (see input transform of the field).
+57 KILL DA,DATA
+58 SET DA(1)=DFN
+59 SET DATA(.01)=0
+60 FOR
SET DATA(.01)=$ORDER(DGELG("ELIG","CODE",DATA(.01)))
if 'DATA(.01)
QUIT
IF '$DATA(^DPT(DFN,"E","B",DATA(.01)))
IF '$$ADD^DGENDBS(2.0361,.DA,.DATA,,$SELECT($DATA(^DPT(DFN,"E",DATA(.01))):0,1:DATA(.01)))
SET ERROR="FILEMAN FAILED TO ADD PATIENT ELIGIBILITY"
QUIT
+61 ;
+62 SET SUCCESS=1
End DoDot:1
+63 ;
+64 DO UNLOCK^DGENPTA1(DFN)
+65 QUIT SUCCESS
+66 ;
FIELD(SUB) ;
+1 ;given a subscript from the ELIGIBILITY array, returns the field number
+2 ;
+3 if SUB="CODE"
QUIT .361
+4 if SUB="SC"
QUIT .301
+5 if SUB="SCPER"
QUIT .302
+6 if SUB="EFFDT"
QUIT .3014
+7 if SUB="POW"
QUIT .525
+8 if SUB="PH"
QUIT .531
+9 if SUB="A&A"
QUIT .36205
+10 if SUB="HB"
QUIT .36215
+11 if SUB="VAPEN"
QUIT .36235
+12 if SUB="VACKAMT"
QUIT .36295
+13 if SUB="DISRET"
QUIT .3602
+14 if SUB="DISLOD"
QUIT .3603
+15 if SUB="MEDICAID"
QUIT .381
+16 ;EVC - DG*5.3*653
if SUB="MEDASKDT"
QUIT .382
+17 if SUB="AO"
QUIT .32102
+18 if SUB="IR"
QUIT .32103
+19 ;name change from Env Con, DG*5.3*688
if SUB="EC"
QUIT .322013
+20 ;don't map Means Test Category
if SUB="MTSTA"
QUIT ""
+21 if SUB="P&T"
QUIT .304
+22 ;field added with DG*5.3*688
if SUB="P&TDT"
QUIT .3013
+23 if SUB="POS"
QUIT .323
+24 if SUB="UNEMPLOY"
QUIT .305
+25 if SUB="SCAWDATE"
QUIT .3012
+26 if SUB="RATEINC"
QUIT .293
+27 if SUB="CLAIMNUM"
QUIT .313
+28 if SUB="CLAIMLOC"
QUIT .314
+29 if SUB="VADISAB"
QUIT .3025
+30 if SUB="ELIGSTA"
QUIT .3611
+31 if SUB="ELIGSTADATE"
QUIT .3612
+32 if SUB="ELIGVERIF"
QUIT .3615
+33 if SUB="ELIGENTBY"
QUIT .3616
+34 if SUB="RD"
QUIT .01
+35 if SUB="PER"
QUIT 2
+36 if SUB="RDSC"
QUIT 3
+37 if SUB="RDEXT"
QUIT 4
+38 if SUB="RDORIG"
QUIT 5
+39 if SUB="RDCURR"
QUIT 6
+40 if SUB="UEYEAR"
QUIT .3617
+41 if SUB="UESITE"
QUIT .3618
+42 if SUB="AOEXPLOC"
QUIT .3213
+43 if SUB="CVELEDT"
QUIT .5295
+44 if SUB="SHAD"
QUIT .32115
+45 if SUB="MOH"
QUIT .541
+46 ;MOH AWARD DATE DG*5.3*972 HM
if SUB="MOHAWRDDATE"
QUIT .542
+47 ;MOH STATUS DATE DG*5.3*972 HM
if SUB="MOHSTATDATE"
QUIT .543
+48 ;MOH COPAYMENT EXEMPTION DATE DG*5.3*972 HM
if SUB="MOHEXEMPDATE"
QUIT .544
+49 ; Added for Camp Lejeune - DG*5.3*909
if SUB="CLE"
QUIT .321701
+50 ; Added for Camp Lejeune - DG*5.3*909
if SUB="CLEDT"
QUIT .321702
+51 ; Added for Camp Lejeune - DG*5.3*909
if SUB="CLEST"
QUIT .321703
+52 ; Added for Camp Lejeune - DG*5.3*909
if SUB="CLESOR"
QUIT .321704
+53 ;
+54 QUIT ""
+55 ;
CHKFIELD(SUB,VAL) ;
+1 ;Description: Does field level validation of the value. Returns 1
+2 ;if the value is good, 0 otherwise.
+3 ;
+4 ;for now, all NULL values assumed okay
if ($GET(VAL)="")
QUIT 1
+5 ;
+6 NEW BAD
SET BAD=0
+7 IF (SUB="SCPER")!(SUB="PER")
IF (+VAL'=VAL)!(VAL>100)!(VAL<0)!(VAL?.E1"."1N.N)
SET BAD=1
+8 IF SUB="VACKAMT"
IF +VAL'=VAL&(VAL'?.N1"."2N)!(VAL>99999)!(VAL<0)
SET BAD=1
+9 IF SUB="DISRET"
IF VAL'=0
IF VAL'=1
SET BAD=1
+10 IF SUB="DISLOD"
IF VAL'=0
IF VAL'=1
SET BAD=1
+11 IF SUB="MEDICAID"
IF VAL'=0
IF VAL'=1
SET BAD=1
+12 IF SUB="RATEINC"
IF VAL'=0
IF VAL'=1
SET BAD=1
+13 IF SUB="ELIGSTA"
IF VAL'="P"
IF VAL'="R"
IF VAL'="V"
SET BAD=1
+14 IF SUB="POW"
IF VAL'="Y"
IF VAL'="N"
IF VAL'="U"
SET BAD=1
+15 QUIT 'BAD
+16 ;
+17 ;
OVERLAY() ;
+1 ;Description: Overlay the local Rated Disabilities with whatever HEC
+2 ;sent.
+3 ;
+4 NEW SUCCESS
SET SUCCESS=1
+5 ;
+6 ;delete the rated disabilities multiple
+7 DO DELRDIS^DGENELA2(DFN)
+8 ;
+9 ;add the rated disabilities
+10 KILL DATA,DA
+11 SET DA(1)=DFN
+12 SET COUNT=0
+13 FOR
SET COUNT=$ORDER(DGELG("RATEDIS",COUNT))
if 'COUNT
QUIT
Begin DoDot:1
+14 SET DATA(.01)=DGELG("RATEDIS",COUNT,"RD")
+15 IF DATA(.01)
Begin DoDot:2
+16 SET DATA(2)=DGELG("RATEDIS",COUNT,"PER")
+17 SET DATA(3)=DGELG("RATEDIS",COUNT,"RDSC")
+18 SET DATA(4)=DGELG("RATEDIS",COUNT,"RDEXT")
+19 SET DATA(5)=DGELG("RATEDIS",COUNT,"RDORIG")
+20 SET DATA(6)=DGELG("RATEDIS",COUNT,"RDCURR")
+21 IF '$$ADD^DGENDBS(2.04,.DA,.DATA)
SET ERROR="FILEMAN FAILED TO ADD RATED DISABILTIES"
SET SUCCESS=0
End DoDot:2
End DoDot:1
+22 QUIT SUCCESS
