DGENCLEA ;ALB/JLS - Camp Lejeune Eligibility API - Retrieve Eligibility ;11/28/14 4:25pm
;;5.3;Registration;**909**;Aug 13,1993;Build 32
;
; Business Rules to determine Camp Lejeune Eligibility:
;. Person is a Veteran AND
; . Either ("Rule 1")
; . Has one Military Service Episode (DGMSE) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 and
; . The identified DGMSE has a character of discharge other than
; . Dishonorable
; . Other Than Honorable
; . Undesirable
; . Bad Conduct
; . Dishonorable-VA
;AND
; . The identified DGMSE is at least 30 days in duration
; . OR ("Rule 2"; perform this check only if "Rule 1" was not met)
; . Has more than one Military Service Episodes (DGMSEs) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 AND
; . All of the identified DGMSEs have a character of discharge other than
; . Dishonorable
; . Other Than Honorable
; . Undesirable
; . Bad Conduct
; . Dishonorable-VA
;AND
; . The sum of two or more of the identified DGMSEs add up to at least 30 days in duration (meaning that it does not have to be consecutive days)
;
; Inputs: DFN
; Outputs: CLE returns 1 if patient is camp lejeune eligible, returns 0 if not camp lejeune eligible
; 0 - CLE "Not Eligible"
; 1 - CLE "Eligible"
;
CLE(DFN) ;
K DGMSE
; Is patient a veteran VET1 Is the patient an eligible veteran VET
I '$$VET^DGENPTA(DFN) Q 0
; If primary eligibility code exists it must be a Veteran Type Eligibility Code from File 8
N DGPRIEL
S DGPRIEL=$P($G(^DPT(DFN,.36)),U,1)
I DGPRIEL]"",$P($G(^DIC(8,DGPRIEL,0)),U,5)="N" Q 0
; Get DGMSE data from DGMSE sub-file #2.3216 first, if that does not exist get DGMSE data from .32 node
N DGMSE
I $D(^DPT(DFN,.3216)) D GETMSE^DGMSEUTL(DFN,.DGMSE)
I $G(DGMSE)="" S DGMSE=$G(^DPT(DFN,.32))
I '$D(DGMSE) Q 0
; Loop through DGMSE to find at least 1 qualifying DGMSE (CLE=1)
N DGENTDT,DGEXITDT,DGTYPE,DGLOOP,DGCLE,DGCLSRDT,X1,X2
S (DGCLE,DGCLSRDT)=0
S DGLOOP="" F S DGLOOP=$O(DGMSE(DGLOOP)) Q:(DGLOOP="")!(DGCLE=1) D
. S (DGENTDT,DGEXITDT,DGTYPE,X1,X2)=""
. S DGENTDT=$$FMTH^XLFDT($P(DGMSE(DGLOOP),"^",1),1),DGEXITDT=$$FMTH^XLFDT($P(DGMSE(DGLOOP),"^",2),1),DGTYPE=$P(DGMSE(DGLOOP),"^",6)
. ;automatically quit out of this DGMSE if Discharge is 2,4,5,6,8 or null
. ;File #25 (Dishonorable,Other Than Dishonorable,Undesirable,Bad Conduct,Dishonorable-VA
. Q:(DGTYPE=2)!(DGTYPE=4)!(DGTYPE=5)!(DGTYPE=6)!(DGTYPE=8)!(DGTYPE="")
. ;automatically quit out if DGMSE is NOT within date range
. ;08011953 and 12311987
. ;$H 41120(subtracted +1 to be 'inclusive') and 53690(added +1 to be 'inclusive')
. ;FM 2530801 and 2871231
. Q:(DGENTDT>53690)!(DGEXITDT<41120) ;if either date is out of CLE date range do not continue (ineligible)
. I DGENTDT<41120 S DGENTDT=41120 ;only include Entry Dates starting from CLE date range
. I DGEXITDT>53690 S DGEXITDT=53690 ;only include Exit Dates ending at CLE date range
. S X1=$$HTFM^XLFDT($G(DGEXITDT)),X2=$$HTFM^XLFDT($G(DGENTDT)) D ^%DTC S DGCLSRDT=DGCLSRDT+(X+1)
. ;automatically quit out if DGMSE is NOT greater than 30 days
. Q:DGCLSRDT<30
. S DGCLE=1
Q DGCLE
;
ADDEDTCL(DFN) ; DG*5.3*909 Enter/Edit Camp Lejeune Indicator
;
AECL2 N DGCLIND,DGCLOLD,DGSITE,X,Y
K DIR S DIR(0)="YO"
S DIR("A")="CAMP LEJEUNE WATER CONTAMINANT EXPOSURE INDICATED"
S DGCLOLD=$P($G(^DPT(DFN,.3217)),U,1)
S DIR("B")=$S(DGCLOLD="Y":"YES",DGCLOLD="N":"NO",1:"")
K:DIR("B")="" DIR("B")
S DIR("?",1)="Enter "_$C(34)_"Y"_$C(34)_" if veteran claims need "
S DIR("?",1)=DIR("?",1)_"for care of conditions related to exposure of"
S DIR("?",2)=$C(34)_"Water Contamination at Camp Lejeune"_$C(34)
S DIR("?",2)=DIR("?",2)_". Enter "_$C(34)_"N"_$C(34)_" if veteran "
S DIR("?",2)=DIR("?",2)_"was not assigned to"
S DIR("?",3)="Camp Lejeune between August 1, 1953 and December 31, "
S DIR("?",3)=DIR("?",3)_"1987 or does not claim need"
S DIR("?",4)="for care of conditions related to exposure of "_$C(34)
S DIR("?",4)=DIR("?",4)_"Water Contamination at Camp"
S DIR("?",5)="Lejeune"_$C(34)_"."
S DIR("?",6)="Choose from:",DIR("?",7)="Y YES",DIR("?",8)="N NO"
S DIR("?")="Null "_$C(34)_"Blank"_$C(34)
D ^DIR K DIR
I X="@" D G AECL2
. W !!,"Camp Lejeune indicator cannot be deleted if already "
. W "indicated.",!,"Enter '^' to exit.",!
S DGCLIND=$S(Y=1:"Y",Y=0:"N",1:Y)
Q:DGCLIND="^" Q:"^Y^N^"'[(U_DGCLIND_U)
S DGSITE=$P($$SITE^VASITE,U,3)
D SAVECL(DFN,DGCLIND,$P($$NOW^XLFDT,".",1),DGSITE,"VAMC")
Q
;
SAVECL(DFN,DGCLIND,DGCLDAT,DGSITE,DGSOURCE) ; DG*5.3*909 Save CL-V info
; Check if CL-V Indicator already No or Yes, then use old date.
N DGCLVREC S DGCLVREC=$G(^DPT(DFN,.3217))
I "^Y^N^"[(U_$P(DGCLVREC,U)_U),$P(DGCLVREC,U,2)]"" D
. S DGCLDAT=$P(DGCLVREC,U,2)
S ^DPT(DFN,.3217)=DGCLIND_U_DGCLDAT_U_DGSITE_U_DGSOURCE
Q
;
SETCLNO ; DG*5.3*909 Set Camp Lejeune to No when no longer CL Eligible
Q:$P($G(^DPT(DFN,.3217)),U,1)'="Y"
Q:$G(^DPT(DFN,.32171))=1 ; if Locked then don't chg YES to NO
N DGCLE S DGCLE=$$CLE(DFN) Q:DGCLE
D SAVECL(DFN,"N",$P($$NOW^XLFDT,".",1),$P($$SITE^VASITE,U,3),"VAMC")
D AUTOUPD^DGENA2(DFN)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENCLEA 5280 printed Oct 16, 2024@18:43:11 Page 2
DGENCLEA ;ALB/JLS - Camp Lejeune Eligibility API - Retrieve Eligibility ;11/28/14 4:25pm
+1 ;;5.3;Registration;**909**;Aug 13,1993;Build 32
+2 ;
+3 ; Business Rules to determine Camp Lejeune Eligibility:
+4 ;. Person is a Veteran AND
+5 ; . Either ("Rule 1")
+6 ; . Has one Military Service Episode (DGMSE) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 and
+7 ; . The identified DGMSE has a character of discharge other than
+8 ; . Dishonorable
+9 ; . Other Than Honorable
+10 ; . Undesirable
+11 ; . Bad Conduct
+12 ; . Dishonorable-VA
+13 ;AND
+14 ; . The identified DGMSE is at least 30 days in duration
+15 ; . OR ("Rule 2"; perform this check only if "Rule 1" was not met)
+16 ; . Has more than one Military Service Episodes (DGMSEs) between, and inclusive of, Aug 1, 1953 and Dec 31, 1987 AND
+17 ; . All of the identified DGMSEs have a character of discharge other than
+18 ; . Dishonorable
+19 ; . Other Than Honorable
+20 ; . Undesirable
+21 ; . Bad Conduct
+22 ; . Dishonorable-VA
+23 ;AND
+24 ; . The sum of two or more of the identified DGMSEs add up to at least 30 days in duration (meaning that it does not have to be consecutive days)
+25 ;
+26 ; Inputs: DFN
+27 ; Outputs: CLE returns 1 if patient is camp lejeune eligible, returns 0 if not camp lejeune eligible
+28 ; 0 - CLE "Not Eligible"
+29 ; 1 - CLE "Eligible"
+30 ;
CLE(DFN) ;
+1 KILL DGMSE
+2 ; Is patient a veteran VET1 Is the patient an eligible veteran VET
+3 IF '$$VET^DGENPTA(DFN)
QUIT 0
+4 ; If primary eligibility code exists it must be a Veteran Type Eligibility Code from File 8
+5 NEW DGPRIEL
+6 SET DGPRIEL=$PIECE($GET(^DPT(DFN,.36)),U,1)
+7 IF DGPRIEL]""
IF $PIECE($GET(^DIC(8,DGPRIEL,0)),U,5)="N"
QUIT 0
+8 ; Get DGMSE data from DGMSE sub-file #2.3216 first, if that does not exist get DGMSE data from .32 node
+9 NEW DGMSE
+10 IF $DATA(^DPT(DFN,.3216))
DO GETMSE^DGMSEUTL(DFN,.DGMSE)
+11 IF $GET(DGMSE)=""
SET DGMSE=$GET(^DPT(DFN,.32))
+12 IF '$DATA(DGMSE)
QUIT 0
+13 ; Loop through DGMSE to find at least 1 qualifying DGMSE (CLE=1)
+14 NEW DGENTDT,DGEXITDT,DGTYPE,DGLOOP,DGCLE,DGCLSRDT,X1,X2
+15 SET (DGCLE,DGCLSRDT)=0
+16 SET DGLOOP=""
FOR
SET DGLOOP=$ORDER(DGMSE(DGLOOP))
if (DGLOOP="")!(DGCLE=1)
QUIT
Begin DoDot:1
+17 SET (DGENTDT,DGEXITDT,DGTYPE,X1,X2)=""
+18 SET DGENTDT=$$FMTH^XLFDT($PIECE(DGMSE(DGLOOP),"^",1),1)
SET DGEXITDT=$$FMTH^XLFDT($PIECE(DGMSE(DGLOOP),"^",2),1)
SET DGTYPE=$PIECE(DGMSE(DGLOOP),"^",6)
+19 ;automatically quit out of this DGMSE if Discharge is 2,4,5,6,8 or null
+20 ;File #25 (Dishonorable,Other Than Dishonorable,Undesirable,Bad Conduct,Dishonorable-VA
+21 if (DGTYPE=2)!(DGTYPE=4)!(DGTYPE=5)!(DGTYPE=6)!(DGTYPE=8)!(DGTYPE="")
QUIT
+22 ;automatically quit out if DGMSE is NOT within date range
+23 ;08011953 and 12311987
+24 ;$H 41120(subtracted +1 to be 'inclusive') and 53690(added +1 to be 'inclusive')
+25 ;FM 2530801 and 2871231
+26 ;if either date is out of CLE date range do not continue (ineligible)
if (DGENTDT>53690)!(DGEXITDT<41120)
QUIT
+27 ;only include Entry Dates starting from CLE date range
IF DGENTDT<41120
SET DGENTDT=41120
+28 ;only include Exit Dates ending at CLE date range
IF DGEXITDT>53690
SET DGEXITDT=53690
+29 SET X1=$$HTFM^XLFDT($GET(DGEXITDT))
SET X2=$$HTFM^XLFDT($GET(DGENTDT))
DO ^%DTC
SET DGCLSRDT=DGCLSRDT+(X+1)
+30 ;automatically quit out if DGMSE is NOT greater than 30 days
+31 if DGCLSRDT<30
QUIT
+32 SET DGCLE=1
End DoDot:1
+33 QUIT DGCLE
+34 ;
ADDEDTCL(DFN) ; DG*5.3*909 Enter/Edit Camp Lejeune Indicator
+1 ;
AECL2 NEW DGCLIND,DGCLOLD,DGSITE,X,Y
+1 KILL DIR
SET DIR(0)="YO"
+2 SET DIR("A")="CAMP LEJEUNE WATER CONTAMINANT EXPOSURE INDICATED"
+3 SET DGCLOLD=$PIECE($GET(^DPT(DFN,.3217)),U,1)
+4 SET DIR("B")=$SELECT(DGCLOLD="Y":"YES",DGCLOLD="N":"NO",1:"")
+5 if DIR("B")=""
KILL DIR("B")
+6 SET DIR("?",1)="Enter "_$CHAR(34)_"Y"_$CHAR(34)_" if veteran claims need "
+7 SET DIR("?",1)=DIR("?",1)_"for care of conditions related to exposure of"
+8 SET DIR("?",2)=$CHAR(34)_"Water Contamination at Camp Lejeune"_$CHAR(34)
+9 SET DIR("?",2)=DIR("?",2)_". Enter "_$CHAR(34)_"N"_$CHAR(34)_" if veteran "
+10 SET DIR("?",2)=DIR("?",2)_"was not assigned to"
+11 SET DIR("?",3)="Camp Lejeune between August 1, 1953 and December 31, "
+12 SET DIR("?",3)=DIR("?",3)_"1987 or does not claim need"
+13 SET DIR("?",4)="for care of conditions related to exposure of "_$CHAR(34)
+14 SET DIR("?",4)=DIR("?",4)_"Water Contamination at Camp"
+15 SET DIR("?",5)="Lejeune"_$CHAR(34)_"."
+16 SET DIR("?",6)="Choose from:"
SET DIR("?",7)="Y YES"
SET DIR("?",8)="N NO"
+17 SET DIR("?")="Null "_$CHAR(34)_"Blank"_$CHAR(34)
+18 DO ^DIR
KILL DIR
+19 IF X="@"
Begin DoDot:1
+20 WRITE !!,"Camp Lejeune indicator cannot be deleted if already "
+21 WRITE "indicated.",!,"Enter '^' to exit.",!
End DoDot:1
GOTO AECL2
+22 SET DGCLIND=$SELECT(Y=1:"Y",Y=0:"N",1:Y)
+23 if DGCLIND="^"
QUIT
if "^Y^N^"'[(U_DGCLIND_U)
QUIT
+24 SET DGSITE=$PIECE($$SITE^VASITE,U,3)
+25 DO SAVECL(DFN,DGCLIND,$PIECE($$NOW^XLFDT,".",1),DGSITE,"VAMC")
+26 QUIT
+27 ;
SAVECL(DFN,DGCLIND,DGCLDAT,DGSITE,DGSOURCE) ; DG*5.3*909 Save CL-V info
+1 ; Check if CL-V Indicator already No or Yes, then use old date.
+2 NEW DGCLVREC
SET DGCLVREC=$GET(^DPT(DFN,.3217))
+3 IF "^Y^N^"[(U_$PIECE(DGCLVREC,U)_U)
IF $PIECE(DGCLVREC,U,2)]""
Begin DoDot:1
+4 SET DGCLDAT=$PIECE(DGCLVREC,U,2)
End DoDot:1
+5 SET ^DPT(DFN,.3217)=DGCLIND_U_DGCLDAT_U_DGSITE_U_DGSOURCE
+6 QUIT
+7 ;
SETCLNO ; DG*5.3*909 Set Camp Lejeune to No when no longer CL Eligible
+1 if $PIECE($GET(^DPT(DFN,.3217)),U,1)'="Y"
QUIT
+2 ; if Locked then don't chg YES to NO
if $GET(^DPT(DFN,.32171))=1
QUIT
+3 NEW DGCLE
SET DGCLE=$$CLE(DFN)
if DGCLE
QUIT
+4 DO SAVECL(DFN,"N",$PIECE($$NOW^XLFDT,".",1),$PIECE($$SITE^VASITE,U,3),"VAMC")
+5 DO AUTOUPD^DGENA2(DFN)
+6 QUIT
+7 ;
