- 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 Jan 18, 2025@03:42:27 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