Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGCV

DGCV.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. CVELIG(DFN) ;
  1. ;API will determine whether or not this veteran needs to have CV End
  1. ;Date set. If this determination cannot be done due to imprecise
  1. ;or missing dates, it returns which dates need editing.
  1. ;Input:
  1. ; DFN - Patient file IEN
  1. ;Output
  1. ; RESULT
  1. ; 0 - CV End Date should not be set
  1. ; 1 - CV End Date should be set
  1. ; If critical dates are imprecise return the following
  1. ; A - CV End Date should not be set, imprecise Service Sep date
  1. ; B - CV End Date should not be set, imprecise Combat To date
  1. ; C - CV End Date should not be set, imprecise Yugoslavia To date
  1. ; D - CV End Date should not be set, imprecise Somalia To date
  1. ; E - CV End Date should not be set, imprecise Pers Gulf To date
  1. ; If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
  1. ; OEF/OIF records on file, return the following so that it will
  1. ; appear on the Imprecise/Missing Date Report
  1. ; F - missing Service Sep Date & no OEF OIF or OEF/OIF Unknown dates
  1. ; If critical dates are missing but the corresponding indicator fields
  1. ; are set to 'YES' return the following
  1. ; G - missing Combat To Date, but Combat Indicated? = 'Yes'
  1. ; H - missing PG To Date, but PG Indicated? = 'Yes'
  1. ; I - missing Somalia To Date, but Somalia Indicator = 'Yes'
  1. ; J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes'
  1. ;
  1. N DG1,DG2,I,RESULT
  1. N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG,DGOEIF
  1. S (DG1,DG2,RESULT)=0
  1. I $G(DFN)']"" Q RESULT
  1. I '$D(^DPT(DFN)) Q RESULT
  1. ;DG*5.3*1090 - Quit if Source is ES
  1. I $G(^TMP("DGCVE",$J,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES" Q RESULT
  1. ;
  1. ;get combat related data from top-level VistA fields
  1. N DGARR,DGERR
  1. D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR")
  1. D PARSE
  1. ;
  1. S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing
  1. S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF)_"^"_$G(DGOEIF)
  1. ;
  1. I $S(DG1="F":1,1:$P(DGDATE,U,5)>$G(DGSRV)) D
  1. . ; Use OIF/OEF/UNKNOWN OEF/OIF to dt only when SSD missing or SSD less
  1. . ; than OIF/OEF/UNKNOWN OEF/OIF to dt
  1. . N DGSRV,Z
  1. . S DGSRV=$P(DGDATE,U,5),Z=$$CHKSSD(DFN)
  1. . I Z=1 S DG1=Z
  1. ;
  1. S DG2=$$CHKREST(DGDATE,$G(DGSRV)) ;check other "TO" dates for imprecise, missing or invalid
  1. S RESULT=$$RES(DG1,$G(DG2))
  1. Q RESULT
  1. ;
  1. 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
  1. I DG1=0!($G(DG2)=0) Q 0
  1. ;if SSD is 1
  1. I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1
  1. I DG1=1,($G(DG2)=0) Q 0
  1. I DG1=1 Q DG2
  1. ;if SSD is imprecise or missing
  1. I DG1'=1,($G(DG2)=1) S DG2=""
  1. Q DG1_DG2
  1. ;
  1. 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
  1. ;if not imprecise check to see if after 11/11/98
  1. ; Note that SSD doesn't appear to ever be used here (TMK)
  1. N RES
  1. S RES=0
  1. I $G(DGDATE)']"",I'=5 D Q RES
  1. . S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"")
  1. I $E(DGDATE,6,7)="00" D
  1. . I I=0 I DGDATE>2981111 S RES="A" Q
  1. . I DGDATE=2980000!(DGDATE=2981100) D Q
  1. .. ; Note OIF/OEF/UNKNOWN OEF/OIF will not get here as these dates by
  1. .. ; definition are after 11/11/98
  1. . . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"")
  1. Q:RES="A" RES
  1. I DGDATE>2981111 S RES=1
  1. Q RES
  1. ;
  1. SETCV(DFN,DGSRV) ;calculate CV end date
  1. ; DGSRV is the most recent of the Service Separation Date
  1. ; or the OEF/OIF To Date, called from file #2 new style
  1. ; cross reference "ACVCOM"
  1. N DGCVEDT,DGFDA
  1. ;DG*5.3*1090 - Quit if Source is ES
  1. I $G(^TMP("DGCVE",$J,"COMBAT VET ELIG END DATE SOURCE",DFN))="ES" Q
  1. ;
  1. I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
  1. S DGCVEDT=$$CALCCV(DFN,DGSRV)
  1. Q:DGCVEDT=""
  1. S DGFDA(2,DFN_",",.5295)=DGCVEDT
  1. D FILE^DIE(,"DGFDA")
  1. Q
  1. ;
  1. CALCCV(DFN,DGSRV) ; Calculate CV end date given DFN and date to start
  1. ; calculation from
  1. ; Function returns null or CV end date calculated
  1. N DGCVEDT,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
  1. I $G(DFN)']""!($G(DGSRV)']"") Q ""
  1. I '$D(^DPT(DFN)) Q ""
  1. S DGNDAA=3080128
  1. D CVRULES(DFN,DGSRV,DGNDAA,.DGYRS)
  1. ; DG*5.3*1090 - Combat Vet Eligibility End Date can additionally be 10 years from (last) Date of Service Separation
  1. ;Q:$G(DGYRS)'=3&($G(DGYRS)'=5) ""
  1. Q:$G(DGYRS)'=3&($G(DGYRS)'=5)&($G(DGYRS)'=10) ""
  1. ;NDAA legislation, enacted 1/28/08, gives vets discharged
  1. ;on or after 1/28/03 (2 years previously) CV Eligibility
  1. ;for 5 years. Vets discharged before 1/28/03 get eligibility
  1. ;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
  1. ; DG*5.3*1090 - PACT Act legislation gives Vets with SSD after 9/30/2013 10 years of eligibility
  1. S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
  1. S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
  1. S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
  1. Q DGCVEDT
  1. ;
  1. CVRULES(DFN,DGSRV,DGNDAA,DGYRS) ;apply rules for the CV End Date
  1. ;extension project - DG*5.3*778
  1. ;
  1. ;DGSRV - most recent of Service Sep Date or OEIUUF to date
  1. ; DGYRS = 3 years from NDAA or 1/27/2011
  1. ; = 5 years from SSD or Enrollment App Date
  1. ; = 10 years from SSD or Enrollment App Date if SSD after 9/30/2013 - DG*5.3*1090
  1. ;
  1. ;determine how many years extra CV eligibility to give
  1. N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
  1. ;determine if veteran has an enrollment record prior
  1. ;to 1/28/2008 (the NDAA date) and no CV End Date for
  1. ;this enrollment
  1. S DGYRS=5
  1. I DGSRV>3130930 S DGYRS=10 ; DG*5.3*1090 - If SSD after 9/30/2013, the patient gets +10 years of eligibility
  1. S (DGPRI,DGQT)=0
  1. S DGCUTOFF=3030128
  1. S DGCIEN=$$FINDCUR^DGENA(DFN)
  1. I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
  1. . S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
  1. . I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
  1. . I DGENRDT'<DGNDAA D
  1. . . S DGPIEN=DGCIEN
  1. . . F S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN D Q:DGQT
  1. . . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
  1. . . . Q:$G(DGENRDT)']""
  1. . . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
  1. ;if DGPRI=1, then there is an enrollment prior to 1/28/08
  1. I DGPRI=1 D Q
  1. . I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
  1. . I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
  1. . . I DGSRV<DGCUTOFF S DGYRS=3
  1. ;
  1. ;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
  1. ;against cutoff date - 1/28/03
  1. I DGSRV<DGCUTOFF S DGYRS=3
  1. Q
  1. ;
  1. CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible
  1. ;Supported DBIA #4156
  1. ;Input: DFN - Patient file IEN
  1. ; DGDT - Treatment date (optional),
  1. ; DT is default
  1. ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
  1. ; Eligible on DGDT(1,0)^is patient eligible on input date?
  1. ; (piece 1) 1 - qualifies as a CV
  1. ; 0 - does not qualify as a CV
  1. ; -1 - bad DFN or date
  1. ; (piece 3) 1 - vet was eligible on date specified (or DT)
  1. ; 0 - vet was not eligible on date specified (or DT)
  1. ;
  1. N RESULT
  1. S RESULT=""
  1. I $G(DFN)="" Q -1
  1. I '$D(^DPT(DFN)) Q -1
  1. ;if time sent in, drop time
  1. I $G(DGDT)']"" S DGDT=DT
  1. I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7)
  1. I DGDT'?7N Q -1
  1. S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
  1. I $G(RESULT)']"" Q 0
  1. S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible
  1. S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0)
  1. Q RESULT
  1. ;
  1. 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
  1. ;Service Separation Date (DG*5.3*797)
  1. I $D(^DPT(DFN,.3216)) S DGSRV=$P($$LAST^DGMSEUTL(DFN),U,2)
  1. E S DGSRV=$G(DGARR(2,DFN_",",.327,"I"))
  1. S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date
  1. S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date
  1. S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date
  1. S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date
  1. S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date
  1. ; get last OIF/OEF/UNKNOWN OEF/OIF episode from multiple
  1. S DGOEIF=$P($$LAST^DGENOEIF(DFN),U)
  1. Q
  1. ;
  1. CHKSSD(DFN) ;check the Serv Sep Date [Last]
  1. ; DGSRV=last SSD
  1. ; Output - RESULT
  1. ; 1 - Date is present and after 11/11/1998
  1. ; 0 - Date is present but before 11/11/1998
  1. ; A - Date is imprecise & either is or potentially is after 11/11/98
  1. ; F - Date is missing
  1. N DG1
  1. I $G(DGSRV)']"" Q "F"
  1. S DG1=$$CHKDATE(DGSRV,0)
  1. I $G(DG1)']"" S DG1=0
  1. Q DG1
  1. ;
  1. CHKREST(DGDATE,SSD) ;
  1. ; SSD = optional, = to the last serv sep date
  1. N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX
  1. S (DG3,DG4,DGR,DGRES)=""
  1. S DGQ=0 ;loop terminator
  1. S DGFLG=0 ;flag to indicate that one of the dates is missing (no
  1. ; need to check this for OIF/OEF/UNKNOWN OEF/OIF since
  1. ; by definition, these must always be post 11/11/98)
  1. F DGX=1:1:5 D
  1. . S DGDT=$P(DGDATE,U,DGX) D
  1. . . I DGX'=5,$G(DGDT)']"" S DGFLG=1
  1. . . S DG4=$$CHKDATE(DGDT,DGX,$G(SSD))
  1. . . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4)
  1. S DGLEN=$L(DG3)
  1. S DGQ=0
  1. F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D Q:DGQ=1
  1. . I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q
  1. . I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2
  1. I DGQ=1 Q 1
  1. I DGQ=2 Q $E(DGR)
  1. I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3)
  1. Q DGRES
  1. ;
  1. 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
  1. ;corresponding indicator field is set to 'YES'
  1. N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX
  1. N DGCIND,DGPGIND,DGSIND,DGYIND
  1. S (DGCHAR,DGQ,DGR)=0
  1. D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR")
  1. S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated
  1. S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated
  1. S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated
  1. S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated
  1. F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D Q:DGQ=1
  1. . I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q
  1. . I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q
  1. . I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q
  1. . I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J"
  1. Q DGR
  1. 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
  1. ;because this would indicate that fields have been changed and
  1. ;CV eligibility is no longer appropriate
  1. ;
  1. N DGCV,DGFDA
  1. K DGCVFLG
  1. S DGCVFLG=0
  1. I $G(DFN)']"" Q
  1. I '$D(^DPT(DFN)) Q
  1. S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I")
  1. I $G(DGCV)']"" Q
  1. S DGCVFLG=1
  1. S DGFDA(2,DFN_",",.5295)="@"
  1. D FILE^DIE(,"DGFDA")
  1. Q