source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENELA1.m@ 648

DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD,EG,TMK,CKN,ERC - Patient Eligibility API ; 9/18/06 12:05pm
 ;;5.3;Registration;**147,327,314,367,497,451,564,631,672,659,583,746,653**;Aug 13,1993;Build 2
 ;
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
 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)
 .;
 .;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)
 .;
 .I '$$UPD^DGENDBS(2,DFN,.DATA) S ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD" Q
 .;
 .;
 .;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 tranform 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
 Q:SUB="MTSTA" ""  ;don't map Means Test Category
 Q:SUB="P&T" .304
 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 ""
 ;
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 disabilties 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