- 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 Feb 19, 2025@00:08:35 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 ;