VAFMON ;ALB/CAW/GN - Returns income/dependents ; 2/19/03 3:35pm
;;5.3;Registration;**45,67,499**;Aug 13, 1993
;
INCOME(DFN,VADT,VASOURCE) ;
; Returns Income (veterans+spouse+dependents)
; First from the means test
; (Income+Net Worth-Deductible Expenses)
; If no means test then co-pay test
; (Income-Deductible Expenses)
; If no co-pay test then income screening
; (Income)
; If none of the above then total VA check amount
;
; INPUT: DFN = Patient IEN
; VADT = Date income calculated for
; VASOURCE = [optional] income type requested
; 1 = returns income (veteran,spouse,children)
; minus deductibe expenses - this excludes net worth
; OUTPUT: VAINCM = Income^source flag
; (2nd piece is only used when VASOURCE is used and is equal to 1)
;
N I,VAINCM,VAMT,DGREL,DGINR,DGINC,DGDEP,VAX,X
I '$D(VADT) S VAINCM="" G INCQ
S VAINCM="",VADT=$P(VADT,".")
S VAMT=$$LST^DGMTCOU1(DFN,VADT,3)
I VAMT,$P(VAMT,U,4)'="N",$P(VAMT,U,4)'="L" S X=$G(^DGMT(408.31,+VAMT,0)) S:$L($P(X,U,4))!$L($P(X,U,15)) VAINCM=$P(X,U,4)-$P(X,U,15) D
.I $G(VASOURCE)'=1,$L($P(X,U,5)) S VAINCM=VAINCM+$P(X,U,5) Q ; includes net worth
.I VAINCM]"" S VAINCM=VAINCM_$S($P(VAMT,U,5)=1:"^M",1:"^C") ;bt source flag
I VAINCM']"" D
.N VADX S VADX=$S($G(VASOURCE)=1:"C",1:"D")
.; DG*5.3*499 pass ien of Means/Co-pay test via 5th parameter
.D ALL^DGMTU21(DFN,"VS"_VADX,VADT,"I",+VAMT)
.S VAX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I VAX]"" F I=8:1:17 S:$L($P(VAX,"^",I)) VAINCM=VAINCM+$P(VAX,"^",I)
.S VAX=$G(^DGMT(408.21,+$G(DGINC("S")),0)) I VAX]"" F I=8:1:17 S:$L($P(VAX,"^",I)) VAINCM=VAINCM+$P(VAX,"^",I)
.S VACNT=0 F S VACNT=$O(DGINC(VADX,VACNT)) Q:'VACNT S VAX=$G(^DGMT(408.21,+$G(DGINC(VADX,VACNT)),0)) I VAX]"" F I=8:1:17 S:$L($P(VAX,"^",I)) VAINCM=VAINCM+$P(VAX,"^",I)
.I $G(VASOURCE)=1,VAINCM]"" S VAINCM=VAINCM_"^I"
I VAINCM']"" S VAINCM=$P($G(^DPT(DFN,.362)),U,20) I $G(VASOURCE)=1,VAINCM]"" S VAINCM=VAINCM_"^V"
;
INCQ Q VAINCM
;
DEP(DFN,VADT) ;Total dependents for a patient
;Input: DFN = Internal Entry Number of Patient file
; VADT = Date (Optional - default today)
;Output Number of dependents
N VAMT,VAMTDEP,VAVIR0,VAVIRI,DGDEP,DGINR,DGREL,VADEP
I 'VADT S VADT=DT
S VADEP=""
S VAMT=$$LST^DGMTCOU1(DFN,VADT,3)
I VAMT,$P(VAMT,U,4)'="N",$P(VAMT,U,4)'="L",$D(^DGMT(408.31,+VAMT,0)) S VADEP=$P(^(0),U,18)
I VADEP']"" D I VADEP]"" G DEPQ
.D ALL^DGMTU21(DFN,"DSV",VADT) I '$D(DGREL) Q
.S VAVIRI=+$G(DGINR("V")),VAVIR0=$G(^DGMT(408.22,VAVIRI,0)),VADEP=$P(VAVIR0,U,13)
.I 'VADEP&($P(VAVIR0,U,8)) S:VADEP=0 VAMTDEP="" Q
.; Questions: piece 5=married last calender year
.; piece 6=lived with patient
.; piece 7=amount contributed to spouse
.;
.; If no spouse, and questions not answered, set dep=null
.;
.I '$D(DGREL("S"))&($P(VAVIR0,U,5,7)']"") S VADEP="" Q
.;
.; If no spouse, but questions answered, set dep=$S
.;
.I '$D(DGREL("S")),$P(VAVIR0,U,5,7)]"" S VADEP=VADEP+$S('$P(VAVIR0,U,5):0,$P(VAVIR0,U,6)'=0:1,$P(VAVIR0,U,7)>49:1,1:0) Q
.;
.; If spouse and no questions answered, set dep+1
.;
.I $D(DGREL("S")),$P(VAVIR0,U,5,7)']"" S VADEP=VADEP+1 Q
.;
.; If spouse and questions answered, set dep=$S
.;
.I $D(DGREL("S")) S VADEP=VADEP+$S($P(VAVIR0,U,6):1,$P(VAVIR0,U,7)>49:1,$P(VAVIR0,U,5)&($P(VAVIR0,U,6)=""):1,1:0)
;
DEPQ Q VADEP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFMON 3530 printed Sep 23, 2025@20:39:47 Page 2
VAFMON ;ALB/CAW/GN - Returns income/dependents ; 2/19/03 3:35pm
+1 ;;5.3;Registration;**45,67,499**;Aug 13, 1993
+2 ;
INCOME(DFN,VADT,VASOURCE) ;
+1 ; Returns Income (veterans+spouse+dependents)
+2 ; First from the means test
+3 ; (Income+Net Worth-Deductible Expenses)
+4 ; If no means test then co-pay test
+5 ; (Income-Deductible Expenses)
+6 ; If no co-pay test then income screening
+7 ; (Income)
+8 ; If none of the above then total VA check amount
+9 ;
+10 ; INPUT: DFN = Patient IEN
+11 ; VADT = Date income calculated for
+12 ; VASOURCE = [optional] income type requested
+13 ; 1 = returns income (veteran,spouse,children)
+14 ; minus deductibe expenses - this excludes net worth
+15 ; OUTPUT: VAINCM = Income^source flag
+16 ; (2nd piece is only used when VASOURCE is used and is equal to 1)
+17 ;
+18 NEW I,VAINCM,VAMT,DGREL,DGINR,DGINC,DGDEP,VAX,X
+19 IF '$DATA(VADT)
SET VAINCM=""
GOTO INCQ
+20 SET VAINCM=""
SET VADT=$PIECE(VADT,".")
+21 SET VAMT=$$LST^DGMTCOU1(DFN,VADT,3)
+22 IF VAMT
IF $PIECE(VAMT,U,4)'="N"
IF $PIECE(VAMT,U,4)'="L"
SET X=$GET(^DGMT(408.31,+VAMT,0))
if $LENGTH($PIECE(X,U,4))!$LENGTH($PIECE(X,U,15))
SET VAINCM=$PIECE(X,U,4)-$PIECE(X,U,15)
Begin DoDot:1
+23 ; includes net worth
IF $GET(VASOURCE)'=1
IF $LENGTH($PIECE(X,U,5))
SET VAINCM=VAINCM+$PIECE(X,U,5)
QUIT
+24 ;bt source flag
IF VAINCM]""
SET VAINCM=VAINCM_$SELECT($PIECE(VAMT,U,5)=1:"^M",1:"^C")
End DoDot:1
+25 IF VAINCM']""
Begin DoDot:1
+26 NEW VADX
SET VADX=$SELECT($GET(VASOURCE)=1:"C",1:"D")
+27 ; DG*5.3*499 pass ien of Means/Co-pay test via 5th parameter
+28 DO ALL^DGMTU21(DFN,"VS"_VADX,VADT,"I",+VAMT)
+29 SET VAX=$GET(^DGMT(408.21,+$GET(DGINC("V")),0))
IF VAX]""
FOR I=8:1:17
if $LENGTH($PIECE(VAX,"^",I))
SET VAINCM=VAINCM+$PIECE(VAX,"^",I)
+30 SET VAX=$GET(^DGMT(408.21,+$GET(DGINC("S")),0))
IF VAX]""
FOR I=8:1:17
if $LENGTH($PIECE(VAX,"^",I))
SET VAINCM=VAINCM+$PIECE(VAX,"^",I)
+31 SET VACNT=0
FOR
SET VACNT=$ORDER(DGINC(VADX,VACNT))
if 'VACNT
QUIT
SET VAX=$GET(^DGMT(408.21,+$GET(DGINC(VADX,VACNT)),0))
IF VAX]""
FOR I=8:1:17
if $LENGTH($PIECE(VAX,"^",I))
SET VAINCM=VAINCM+$PIECE(VAX,"^",I)
+32 IF $GET(VASOURCE)=1
IF VAINCM]""
SET VAINCM=VAINCM_"^I"
End DoDot:1
+33 IF VAINCM']""
SET VAINCM=$PIECE($GET(^DPT(DFN,.362)),U,20)
IF $GET(VASOURCE)=1
IF VAINCM]""
SET VAINCM=VAINCM_"^V"
+34 ;
INCQ QUIT VAINCM
+1 ;
DEP(DFN,VADT) ;Total dependents for a patient
+1 ;Input: DFN = Internal Entry Number of Patient file
+2 ; VADT = Date (Optional - default today)
+3 ;Output Number of dependents
+4 NEW VAMT,VAMTDEP,VAVIR0,VAVIRI,DGDEP,DGINR,DGREL,VADEP
+5 IF 'VADT
SET VADT=DT
+6 SET VADEP=""
+7 SET VAMT=$$LST^DGMTCOU1(DFN,VADT,3)
+8 IF VAMT
IF $PIECE(VAMT,U,4)'="N"
IF $PIECE(VAMT,U,4)'="L"
IF $DATA(^DGMT(408.31,+VAMT,0))
SET VADEP=$PIECE(^(0),U,18)
+9 IF VADEP']""
Begin DoDot:1
+10 DO ALL^DGMTU21(DFN,"DSV",VADT)
IF '$DATA(DGREL)
QUIT
+11 SET VAVIRI=+$GET(DGINR("V"))
SET VAVIR0=$GET(^DGMT(408.22,VAVIRI,0))
SET VADEP=$PIECE(VAVIR0,U,13)
+12 IF 'VADEP&($PIECE(VAVIR0,U,8))
if VADEP=0
SET VAMTDEP=""
QUIT
+13 ; Questions: piece 5=married last calender year
+14 ; piece 6=lived with patient
+15 ; piece 7=amount contributed to spouse
+16 ;
+17 ; If no spouse, and questions not answered, set dep=null
+18 ;
+19 IF '$DATA(DGREL("S"))&($PIECE(VAVIR0,U,5,7)']"")
SET VADEP=""
QUIT
+20 ;
+21 ; If no spouse, but questions answered, set dep=$S
+22 ;
+23 IF '$DATA(DGREL("S"))
IF $PIECE(VAVIR0,U,5,7)]""
SET VADEP=VADEP+$SELECT('$PIECE(VAVIR0,U,5):0,$PIECE(VAVIR0,U,6)'=0:1,$PIECE(VAVIR0,U,7)>49:1,1:0)
QUIT
+24 ;
+25 ; If spouse and no questions answered, set dep+1
+26 ;
+27 IF $DATA(DGREL("S"))
IF $PIECE(VAVIR0,U,5,7)']""
SET VADEP=VADEP+1
QUIT
+28 ;
+29 ; If spouse and questions answered, set dep=$S
+30 ;
+31 IF $DATA(DGREL("S"))
SET VADEP=VADEP+$SELECT($PIECE(VAVIR0,U,6):1,$PIECE(VAVIR0,U,7)>49:1,$PIECE(VAVIR0,U,5)&($PIECE(VAVIR0,U,6)=""):1,1:0)
End DoDot:1
IF VADEP]""
GOTO DEPQ
+32 ;
DEPQ QUIT VADEP
