DGCV ;ALB/DW,ERC,BRM,TMK,LBD,JAM - COMBAT VET ELIGIBILTY; 10/15/05 ; 6/16/09 10:40am
;;5.3;Registration;**528,576,564,673,778,792,797,1090**; Aug 13, 1993;Build 16
;
CVELIG(DFN) ;
;API will determine whether or not this veteran needs to have CV End
;Date set. If this determination cannot be done due to imprecise
;or missing dates, it returns which dates need editing.
;Input:
; DFN - Patient file IEN
;Output
; RESULT
; 0 - CV End Date should not be set
; 1 - CV End Date should be set
; If critical dates are imprecise return the following
; A - CV End Date should not be set, imprecise Service Sep date
; B - CV End Date should not be set, imprecise Combat To date
; C - CV End Date should not be set, imprecise Yugoslavia To date
; D - CV End Date should not be set, imprecise Somalia To date
; E - CV End Date should not be set, imprecise Pers Gulf To date
; If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
; OEF/OIF records on file, return the following so that it will
; appear on the Imprecise/Missing Date Report
; F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
; If critical dates are missing but the corresponding indicator fields
; are set to 'YES' return the following
; G - missing Combat To Date, but Combat Indicated? = 'Yes'
; H - missing PG To Date, but PG Indicated? = 'Yes'
; I - missing Somalia To Date, but Somalia Indicator = 'Yes'
; J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
;
N DG1,DG2,I,RESULT
N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
S (DG1,DG2,RESULT)=0
I $G(DFN)']"" Q RESULT
I '$D(^DPT(DFN)) Q RESULT
;DG*5.3*1090 - Quit if Source is ES
I $G(^TMP("DGCVE",$J,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES" Q RESULT
;
;get combat related data from top-level VistA fields
N DGARR,DGERR
D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
D PARSE
;
S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing
S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF)_"^"_$G(DGOEIF)
;
I $S(DG1="F":1,1:$P(DGDATE,U,5)>$G(DGSRV)) D
. ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
. ; than OIF/OEF/UNKNOWN OEF/OIF to dt
. N DGSRV,Z
. S DGSRV=$P(DGDATE,U,5),Z=$$CHKSSD(DFN)
. I Z=1 S DG1=Z
;
S DG2=$$CHKREST(DGDATE,$G(DGSRV)) ;check other "TO" dates for imprecise, missing or invalid
S RESULT=$$RES(DG1,$G(DG2))
Q RESULT
;
RES(DG1,DG2) ;determine the final RESULT code from DG1 & DG2
;if SSD evaluates to earlier than 11/11/98, can't set CV End Date
I DG1=0!($G(DG2)=0) Q 0
;if SSD is 1
I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1
I DG1=1,($G(DG2)=0) Q 0
I DG1=1 Q DG2
;if SSD is imprecise or missing
I DG1'=1,($G(DG2)=1) S DG2=""
Q DG1_DG2
;
CHKDATE(DGDATE,I,SSD) ;check to see if date is imprecise or missing
;if imprecise check to see if the imprecision prevents CV evaluation
;if not imprecise check to see if after 11/11/98
; Note that SSD doesn't appear to ever be used here (TMK)
N RES
S RES=0
I $G(DGDATE)']"",I'=5 D Q RES
. S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
I $E(DGDATE,6,7)="00" D
. I I=0 I DGDATE>2981111 S RES="A" Q
. I DGDATE=2980000!(DGDATE=2981100) D Q
.. ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
.. ; definition are after 11/11/98
. . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
Q:RES="A" RES
I DGDATE>2981111 S RES=1
Q RES
;
SETCV(DFN,DGSRV) ;calculate CV end date
; DGSRV is the most recent of the Service Separation Date
; or the OEF/OIF To Date, called from file #2 new style
; cross reference "ACVCOM"
N DGCVEDT,DGFDA
;DG*5.3*1090 - Quit if Source is ES
I $G(^TMP("DGCVE",$J,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES" Q
;
I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
S DGCVEDT=$$CALCCV(DFN,DGSRV)
Q:DGCVEDT=""
S DGFDA(2,DFN_",",.5295)=DGCVEDT
D FILE^DIE(,"DGFDA")
Q
;
CALCCV(DFN,DGSRV) ; Calculate CV end date given DFN and date to start
; calculation from
; Function returns null or CV end date calculated
N DGCVEDT,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
I $G(DFN)']""!($G(DGSRV)']"") Q ""
I '$D(^DPT(DFN)) Q ""
S DGNDAA=3080128
D CVRULES(DFN,DGSRV,DGNDAA,.DGYRS)
; DG*5.3*1090 - Combat Vet Eligibility End Date can additionally be 10 years from (last) Date of Service Separation
;Q:$G(DGYRS)'=3&($G(DGYRS)'=5) ""
Q:$G(DGYRS)'=3&($G(DGYRS)'=5)&($G(DGYRS)'=10) ""
;NDAA legislation, enacted 1/28/08, gives vets discharged
;on or after 1/28/03 (2 years previously) CV Eligibility
;for 5 years. Vets discharged before 1/28/03 get eligibility
;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
; DG*5.3*1090 - PACT Act legislation gives Vets with SSD after 9/30/2013 10 years of eligibility
S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
Q DGCVEDT
;
CVRULES(DFN,DGSRV,DGNDAA,DGYRS) ;apply rules for the CV End Date
;extension project - DG*5.3*778
;
;DGSRV - most recent of Service Sep Date or OEIUUF to date
; DGYRS = 3 years from NDAA or 1/27/2011
; = 5 years from SSD or Enrollment App Date
; = 10 years from SSD or Enrollment App Date if SSD after 9/30/2013 - DG*5.3*1090
;
;determine how many years extra CV eligibility to give
N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
;determine if veteran has an enrollment record prior
;to 1/28/2008 (the NDAA date) and no CV End Date for
;this enrollment
S DGYRS=5
I DGSRV>3130930 S DGYRS=10 ; DG*5.3*1090 - If SSD after 9/30/2013, the patient gets +10 years of eligibility
S (DGPRI,DGQT)=0
S DGCUTOFF=3030128
S DGCIEN=$$FINDCUR^DGENA(DFN)
I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
. S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
. I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
. I DGENRDT'<DGNDAA D
. . S DGPIEN=DGCIEN
. . F S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN D Q:DGQT
. . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
. . . Q:$G(DGENRDT)']""
. . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
;if DGPRI=1, then there is an enrollment prior to 1/28/08
I DGPRI=1 D Q
. I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
. I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
. . I DGSRV<DGCUTOFF S DGYRS=3
;
;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
;against cutoff date - 1/28/03
I DGSRV<DGCUTOFF S DGYRS=3
Q
;
CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible
;Supported DBIA #4156
;Input: DFN - Patient file IEN
; DGDT - Treatment date (optional),
; DT is default
;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
; Eligible on DGDT(1,0)^is patient eligible on input date?
; (piece 1) 1 - qualifies as a CV
; 0 - does not qualify as a CV
; -1 - bad DFN or date
; (piece 3) 1 - vet was eligible on date specified (or DT)
; 0 - vet was not eligible on date specified (or DT)
;
N RESULT
S RESULT=""
I $G(DFN)="" Q -1
I '$D(^DPT(DFN)) Q -1
;if time sent in, drop time
I $G(DGDT)']"" S DGDT=DT
I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7)
I DGDT'?7N Q -1
S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
I $G(RESULT)']"" Q 0
S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible
S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0)
Q RESULT
;
PARSE ;GETS^DIQ called in CVELIG - in this subroutine stuff results into array
;If there's MSE data in new MSE sub-file #2.3216 get last
;Service Separation Date (DG*5.3*797)
I $D(^DPT(DFN,.3216)) S DGSRV=$P($$LAST^DGMSEUTL(DFN),U,2)
E S DGSRV=$G(DGARR(2,DFN_",",.327,"I"))
S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date
S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date
S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date
S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date
S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date
; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
S DGOEIF=$P($$LAST^DGENOEIF(DFN),U)
Q
;
CHKSSD(DFN) ;check the Serv Sep Date [Last]
; DGSRV=last SSD
; Output - RESULT
; 1 - Date is present and after 11/11/1998
; 0 - Date is present but before 11/11/1998
; A - Date is imprecise & either is or potentially is after 11/11/98
; F - Date is missing
N DG1
I $G(DGSRV)']"" Q "F"
S DG1=$$CHKDATE(DGSRV,0)
I $G(DG1)']"" S DG1=0
Q DG1
;
CHKREST(DGDATE,SSD) ;
; SSD = optional, = to the last serv sep date
N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
S (DG3,DG4,DGR,DGRES)=""
S DGQ=0 ;loop terminator
S DGFLG=0 ;flag to indicate that one of the dates is missing (no
; need to check this for OIF/OEF/UNKNOWN OEF/OIF since
; by definition, these must always be post 11/11/98)
F DGX=1:1:5 D
. S DGDT=$P(DGDATE,U,DGX) D
. . I DGX'=5,$G(DGDT)']"" S DGFLG=1
. . S DG4=$$CHKDATE(DGDT,DGX,$G(SSD))
. . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4)
S DGLEN=$L(DG3)
S DGQ=0
F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D Q:DGQ=1
. I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q
. I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2
I DGQ=1 Q 1
I DGQ=2 Q $E(DGR)
I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3)
Q DGRES
;
MISS(DFN,DGLEN,DGRES) ;there is at least one missing date, and in order to
;return a RESULT of a missing date, need to check to see if the
;corresponding indicator field is set to 'YES'
N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
N DGCIND,DGPGIND,DGSIND,DGYIND
S (DGCHAR,DGQ,DGR)=0
D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated
S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated
S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated
S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated
F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D Q:DGQ=1
. I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q
. I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q
. I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q
. I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J"
Q DGR
DELCV(DFN) ;called by the Kill logic of the ACVCOM cross reference
;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted
;because this would indicate that fields have been changed and
;CV eligibility is no longer appropriate
;
N DGCV,DGFDA
K DGCVFLG
S DGCVFLG=0
I $G(DFN)']"" Q
I '$D(^DPT(DFN)) Q
S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
I $G(DGCV)']"" Q
S DGCVFLG=1
S DGFDA(2,DFN_",",.5295)="@"
D FILE^DIE(,"DGFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCV 10942 printed Apr 09, 2024@22:01:32 Page 2
DGCV ;ALB/DW,ERC,BRM,TMK,LBD,JAM - COMBAT VET ELIGIBILTY; 10/15/05 ; 6/16/09 10:40am
+1 ;;5.3;Registration;**528,576,564,673,778,792,797,1090**; Aug 13, 1993;Build 16
+2 ;
CVELIG(DFN) ;
+1 ;API will determine whether or not this veteran needs to have CV End
+2 ;Date set. If this determination cannot be done due to imprecise
+3 ;or missing dates, it returns which dates need editing.
+4 ;Input:
+5 ; DFN - Patient file IEN
+6 ;Output
+7 ; RESULT
+8 ; 0 - CV End Date should not be set
+9 ; 1 - CV End Date should be set
+10 ; If critical dates are imprecise return the following
+11 ; A - CV End Date should not be set, imprecise Service Sep date
+12 ; B - CV End Date should not be set, imprecise Combat To date
+13 ; C - CV End Date should not be set, imprecise Yugoslavia To date
+14 ; D - CV End Date should not be set, imprecise Somalia To date
+15 ; E - CV End Date should not be set, imprecise Pers Gulf To date
+16 ; If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
+17 ; OEF/OIF records on file, return the following so that it will
+18 ; appear on the Imprecise/Missing Date Report
+19 ; F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
+20 ; If critical dates are missing but the corresponding indicator fields
+21 ; are set to 'YES' return the following
+22 ; G - missing Combat To Date, but Combat Indicated? = 'Yes'
+23 ; H - missing PG To Date, but PG Indicated? = 'Yes'
+24 ; I - missing Somalia To Date, but Somalia Indicator = 'Yes'
+25 ; J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
+26 ;
+27 NEW DG1,DG2,I,RESULT
+28 NEW DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
+29 SET (DG1,DG2,RESULT)=0
+30 IF $GET(DFN)']""
QUIT RESULT
+31 IF '$DATA(^DPT(DFN))
QUIT RESULT
+32 ;DG*5.3*1090 - Quit if Source is ES
+33 IF $GET(^TMP("DGCVE",$JOB,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES"
QUIT RESULT
+34 ;
+35 ;get combat related data from top-level VistA fields
+36 NEW DGARR,DGERR
+37 DO GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
+38 DO PARSE
+39 ;
+40 ;check SSD for imprecise or missing
SET DG1=$$CHKSSD(DFN)
+41 SET DGDATE=$GET(DGCOM)_"^"_$GET(DGYUG)_"^"_$GET(DGSOM)_"^"_$GET(DGGULF)_"^"_$GET(DGOEIF)
+42 ;
+43 IF $SELECT(DG1="F":1,1:$PIECE(DGDATE,U,5)>$GET(DGSRV))
Begin DoDot:1
+44 ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
+45 ; than OIF/OEF/UNKNOWN OEF/OIF to dt
+46 NEW DGSRV,Z
+47 SET DGSRV=$PIECE(DGDATE,U,5)
SET Z=$$CHKSSD(DFN)
+48 IF Z=1
SET DG1=Z
End DoDot:1
+49 ;
+50 ;check other "TO" dates for imprecise, missing or invalid
SET DG2=$$CHKREST(DGDATE,$GET(DGSRV))
+51 SET RESULT=$$RES(DG1,$GET(DG2))
+52 QUIT RESULT
+53 ;
RES(DG1,DG2) ;determine the final RESULT code from DG1 & DG2
+1 ;if SSD evaluates to earlier than 11/11/98, can't set CV End Date
+2 IF DG1=0!($GET(DG2)=0)
QUIT 0
+3 ;if SSD is 1
+4 IF DG1=1
IF ($GET(DG2)=1!($GET(DG2)']""))
QUIT 1
+5 IF DG1=1
IF ($GET(DG2)=0)
QUIT 0
+6 IF DG1=1
QUIT DG2
+7 ;if SSD is imprecise or missing
+8 IF DG1'=1
IF ($GET(DG2)=1)
SET DG2=""
+9 QUIT DG1_DG2
+10 ;
CHKDATE(DGDATE,I,SSD) ;check to see if date is imprecise or missing
+1 ;if imprecise check to see if the imprecision prevents CV evaluation
+2 ;if not imprecise check to see if after 11/11/98
+3 ; Note that SSD doesn't appear to ever be used here (TMK)
+4 NEW RES
+5 SET RES=0
+6 IF $GET(DGDATE)']""
IF I'=5
Begin DoDot:1
+7 SET RES=$SELECT(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
End DoDot:1
QUIT RES
+8 IF $EXTRACT(DGDATE,6,7)="00"
Begin DoDot:1
+9 IF I=0
IF DGDATE>2981111
SET RES="A"
QUIT
+10 IF DGDATE=2980000!(DGDATE=2981100)
Begin DoDot:2
+11 ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
+12 ; definition are after 11/11/98
+13 SET RES=$SELECT(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
End DoDot:2
QUIT
End DoDot:1
+14 if RES="A"
QUIT RES
+15 IF DGDATE>2981111
SET RES=1
+16 QUIT RES
+17 ;
SETCV(DFN,DGSRV) ;calculate CV end date
+1 ; DGSRV is the most recent of the Service Separation Date
+2 ; or the OEF/OIF To Date, called from file #2 new style
+3 ; cross reference "ACVCOM"
+4 NEW DGCVEDT,DGFDA
+5 ;DG*5.3*1090 - Quit if Source is ES
+6 IF $GET(^TMP("DGCVE",$JOB,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES"
QUIT
+7 ;
+8 IF $$GET1^DIQ(2,DFN_",",.5295,"I")
QUIT
+9 SET DGCVEDT=$$CALCCV(DFN,DGSRV)
+10 if DGCVEDT=""
QUIT
+11 SET DGFDA(2,DFN_",",.5295)=DGCVEDT
+12 DO FILE^DIE(,"DGFDA")
+13 QUIT
+14 ;
CALCCV(DFN,DGSRV) ; Calculate CV end date given DFN and date to start
+1 ; calculation from
+2 ; Function returns null or CV end date calculated
+3 NEW DGCVEDT,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
+4 IF $GET(DFN)']""!($GET(DGSRV)']"")
QUIT ""
+5 IF '$DATA(^DPT(DFN))
QUIT ""
+6 SET DGNDAA=3080128
+7 DO CVRULES(DFN,DGSRV,DGNDAA,.DGYRS)
+8 ; DG*5.3*1090 - Combat Vet Eligibility End Date can additionally be 10 years from (last) Date of Service Separation
+9 ;Q:$G(DGYRS)'=3&($G(DGYRS)'=5) ""
+10 if $GET(DGYRS)'=3&($GET(DGYRS)'=5)&($GET(DGYRS)'=10)
QUIT ""
+11 ;NDAA legislation, enacted 1/28/08, gives vets discharged
+12 ;on or after 1/28/03 (2 years previously) CV Eligibility
+13 ;for 5 years. Vets discharged before 1/28/03 get eligibility
+14 ;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
+15 ; DG*5.3*1090 - PACT Act legislation gives Vets with SSD after 9/30/2013 10 years of eligibility
+16 SET DGTMPDT=$SELECT(DGYRS=3:DGNDAA,1:DGSRV)
+17 SET DGCVEDT=($EXTRACT(DGTMPDT,1,3)+DGYRS)_$EXTRACT(DGTMPDT,4,7)
+18 SET DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
+19 QUIT DGCVEDT
+20 ;
CVRULES(DFN,DGSRV,DGNDAA,DGYRS) ;apply rules for the CV End Date
+1 ;extension project - DG*5.3*778
+2 ;
+3 ;DGSRV - most recent of Service Sep Date or OEIUUF to date
+4 ; DGYRS = 3 years from NDAA or 1/27/2011
+5 ; = 5 years from SSD or Enrollment App Date
+6 ; = 10 years from SSD or Enrollment App Date if SSD after 9/30/2013 - DG*5.3*1090
+7 ;
+8 ;determine how many years extra CV eligibility to give
+9 NEW DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
+10 ;determine if veteran has an enrollment record prior
+11 ;to 1/28/2008 (the NDAA date) and no CV End Date for
+12 ;this enrollment
+13 SET DGYRS=5
+14 ; DG*5.3*1090 - If SSD after 9/30/2013, the patient gets +10 years of eligibility
IF DGSRV>3130930
SET DGYRS=10
+15 SET (DGPRI,DGQT)=0
+16 SET DGCUTOFF=3030128
+17 SET DGCIEN=$$FINDCUR^DGENA(DFN)
+18 IF $GET(DGCIEN)
IF ($DATA(^DGEN(27.11,DGCIEN,0)))]""
Begin DoDot:1
+19 SET DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I")
if $GET(DGENRDT)']""
QUIT
+20 IF $PIECE(DGENRDT,".",1)<DGNDAA
SET DGPRI=1
QUIT
+21 IF DGENRDT'<DGNDAA
Begin DoDot:2
+22 SET DGPIEN=DGCIEN
+23 FOR
SET DGPIEN=$$FINDPRI^DGENA(DGPIEN)
if 'DGPIEN
QUIT
Begin DoDot:3
+24 SET DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
+25 if $GET(DGENRDT)']""
QUIT
+26 IF $PIECE(DGENRDT,".",1)<DGNDAA
SET (DGPRI,DGQT)=1
End DoDot:3
if DGQT
QUIT
End DoDot:2
End DoDot:1
+27 ;if DGPRI=1, then there is an enrollment prior to 1/28/08
+28 IF DGPRI=1
Begin DoDot:1
+29 IF $GET(DGCIEN)]""
SET DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
+30 IF $GET(DGSTAT)["INITIAL APPLICATION BY VAMC"!($GET(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD")
Begin DoDot:2
+31 IF DGSRV<DGCUTOFF
SET DGYRS=3
End DoDot:2
End DoDot:1
QUIT
+32 ;
+33 ;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
+34 ;against cutoff date - 1/28/03
+35 IF DGSRV<DGCUTOFF
SET DGYRS=3
+36 QUIT
+37 ;
CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible
+1 ;Supported DBIA #4156
+2 ;Input: DFN - Patient file IEN
+3 ; DGDT - Treatment date (optional),
+4 ; DT is default
+5 ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
+6 ; Eligible on DGDT(1,0)^is patient eligible on input date?
+7 ; (piece 1) 1 - qualifies as a CV
+8 ; 0 - does not qualify as a CV
+9 ; -1 - bad DFN or date
+10 ; (piece 3) 1 - vet was eligible on date specified (or DT)
+11 ; 0 - vet was not eligible on date specified (or DT)
+12 ;
+13 NEW RESULT
+14 SET RESULT=""
+15 IF $GET(DFN)=""
QUIT -1
+16 IF '$DATA(^DPT(DFN))
QUIT -1
+17 ;if time sent in, drop time
+18 IF $GET(DGDT)']""
SET DGDT=DT
+19 IF DGDT?7N1"."1.6N
SET DGDT=$EXTRACT(DGDT,1,7)
+20 IF DGDT'?7N
QUIT -1
+21 SET RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
+22 IF $GET(RESULT)']""
QUIT 0
+23 ; if treatment date is earlier or equal to end date, veteran is eligible
SET RESULT=$SELECT(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0")
+24 SET RESULT=$SELECT($GET(RESULT):1_"^"_RESULT,1:0)
+25 QUIT RESULT
+26 ;
PARSE ;GETS^DIQ called in CVELIG - in this subroutine stuff results into array
+1 ;If there's MSE data in new MSE sub-file #2.3216 get last
+2 ;Service Separation Date (DG*5.3*797)
+3 IF $DATA(^DPT(DFN,.3216))
SET DGSRV=$PIECE($$LAST^DGMSEUTL(DFN),U,2)
+4 IF '$TEST
SET DGSRV=$GET(DGARR(2,DFN_",",.327,"I"))
+5 ;Combat To Date
SET DGCOM=$GET(DGARR(2,DFN_",",.5294,"I"))
+6 ;Persian Gulf To Date
SET DGGULF=$GET(DGARR(2,DFN_",",.322012,"I"))
+7 ;Somalia To Date
SET DGSOM=$GET(DGARR(2,DFN_",",.322018,"I"))
+8 ;Yugoslavia To Date
SET DGYUG=$GET(DGARR(2,DFN_",",.322021,"I"))
+9 ;CV End Date
SET DGCVDT=$GET(DGARR(2,DFN_",",.5295,"I"))
+10 ; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
+11 SET DGOEIF=$PIECE($$LAST^DGENOEIF(DFN),U)
+12 QUIT
+13 ;
CHKSSD(DFN) ;check the Serv Sep Date [Last]
+1 ; DGSRV=last SSD
+2 ; Output - RESULT
+3 ; 1 - Date is present and after 11/11/1998
+4 ; 0 - Date is present but before 11/11/1998
+5 ; A - Date is imprecise & either is or potentially is after 11/11/98
+6 ; F - Date is missing
+7 NEW DG1
+8 IF $GET(DGSRV)']""
QUIT "F"
+9 SET DG1=$$CHKDATE(DGSRV,0)
+10 IF $GET(DG1)']""
SET DG1=0
+11 QUIT DG1
+12 ;
CHKREST(DGDATE,SSD) ;
+1 ; SSD = optional, = to the last serv sep date
+2 NEW DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
+3 SET (DG3,DG4,DGR,DGRES)=""
+4 ;loop terminator
SET DGQ=0
+5 ;flag to indicate that one of the dates is missing (no
SET DGFLG=0
+6 ; need to check this for OIF/OEF/UNKNOWN OEF/OIF since
+7 ; by definition, these must always be post 11/11/98)
+8 FOR DGX=1:1:5
Begin DoDot:1
+9 SET DGDT=$PIECE(DGDATE,U,DGX)
Begin DoDot:2
+10 IF DGX'=5
IF $GET(DGDT)']""
SET DGFLG=1
+11 SET DG4=$$CHKDATE(DGDT,DGX,$GET(SSD))
+12 IF $GET(DG4)'=0
SET DG3=$GET(DG3)_$GET(DG4)
End DoDot:2
End DoDot:1
+13 SET DGLEN=$LENGTH(DG3)
+14 SET DGQ=0
+15 FOR DGX=1:1:DGLEN
SET DGCHAR=$EXTRACT(DG3,DGX)
Begin DoDot:1
+16 IF DGCHAR=1
SET DG3=DGCHAR
SET DGQ=1
QUIT
+17 IF "BCDE"[DGCHAR
SET DGR=DGR_DGCHAR
SET DGQ=2
End DoDot:1
if DGQ=1
QUIT
+18 IF DGQ=1
QUIT 1
+19 IF DGQ=2
QUIT $EXTRACT(DGR)
+20 IF DGFLG=1
SET DGRES=$$MISS(DFN,DGLEN,DG3)
+21 QUIT DGRES
+22 ;
MISS(DFN,DGLEN,DGRES) ;there is at least one missing date, and in order to
+1 ;return a RESULT of a missing date, need to check to see if the
+2 ;corresponding indicator field is set to 'YES'
+3 NEW DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
+4 NEW DGCIND,DGPGIND,DGSIND,DGYIND
+5 SET (DGCHAR,DGQ,DGR)=0
+6 DO GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
+7 ;Combat Service Indicated
SET DGCIND=$GET(DGARR(2,DFN_",",.5291,"I"))
+8 ;Yugo service indicated
SET DGYIND=$GET(DGARR(2,DFN_",",.322019,"I"))
+9 ;Somalia service indicated
SET DGSIND=$GET(DGARR(2,DFN_",",.322016,"I"))
+10 ;Pers Gulf service indicated
SET DGPGIND=$GET(DGARR(2,DFN_",",.32201,"I"))
+11 FOR DGX=1:1:DGLEN
SET DGCHAR=$EXTRACT(DGRES,DGX)
Begin DoDot:1
+12 IF DGCHAR="G"
IF ($GET(DGCIND)="Y")
SET DGR="G"
SET DGQ=1
QUIT
+13 IF DGCHAR="H"
IF ($GET(DGYIND)="Y")
SET DGR="H"
SET DGQ=1
QUIT
+14 IF DGCHAR="I"
IF ($GET(DGSIND)="Y")
SET DGR="I"
SET DGQ=1
QUIT
+15 IF DGCHAR="J"
IF ($GET(DGPGIND)="Y")
SET DGR="J"
End DoDot:1
if DGQ=1
QUIT
+16 QUIT DGR
DELCV(DFN) ;called by the Kill logic of the ACVCOM cross reference
+1 ;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted
+2 ;because this would indicate that fields have been changed and
+3 ;CV eligibility is no longer appropriate
+4 ;
+5 NEW DGCV,DGFDA
+6 KILL DGCVFLG
+7 SET DGCVFLG=0
+8 IF $GET(DFN)']""
QUIT
+9 IF '$DATA(^DPT(DFN))
QUIT
+10 SET DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
+11 IF $GET(DGCV)']""
QUIT
+12 SET DGCVFLG=1
+13 SET DGFDA(2,DFN_",",.5295)="@"
+14 DO FILE^DIE(,"DGFDA")
+15 QUIT
