IVMCME2 ;ALB/SEK,BRM - CHECK ANNUAL INCOME DATA ; 12/18/01 2:19pm
;;2.0;INCOME VERIFICATION MATCH;**17,49**;21-OCT-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine is called from IVMCME.
;
;
ZIC(STRING,DEPIEN) ; check validity of ZIC segment
;
; Input: STRING as ZIC segment
; DEPIEN as the IEN of the dependent in the array, if applicable
;
; Output: ERROR message or null
;
N ERROR,FLAG,I,X,Y
S ERROR="",X=$P(STRING,HLFS,2),FLAG=0
I $E(X,1,4)<1992!($E(X,5,8)'="0000") S ERROR="Invalid Income Year in ZIC" G ZICQ
F I=3:1:20 I $$NUM($P(STRING,HLFS,I),7,2) S ERROR=$P($T(ZICFLD+I),";;",2)_" field content/length error" Q
I ERROR]"" G ZICQ
I $G(DEPIEN) D I ERROR]"" G ZICQ
. F I=13,14 I $P(STRING,HLFS,I)]"" S ERROR="Dependents can't have medical or funeral expenses" Q
. I DEPIEN=SPOUSE,($P(STRING,HLFS,15)]"") S ERROR="No educational expenses for spouse" Q
. I DEPIEN'=SPOUSE D Q:ERROR]""
. . I $P(STRING,HLFS,15)&('$P(ARRAY(DEPIEN,"ZIR"),U,9)) S ERROR="Dependent Educational Exp. error-income not avail. to vet" Q
. . S X=$E($P(STRING,HLFS,2),1,4) D ^%DT S X=Y
. . I $P(STRING,HLFS,15)]"" S X=$P(^DG(43,1,"MT",X,0),U,17) I X'<$P(STRING,HLFS,9) S ERROR="Income does not exceed child exclusion amount-educational expense not allowed" Q
. . F I=16:1:20 I $P(STRING,HLFS,I)]"" S ERROR="No net worth figures allowed for dependent children"
I $P(STRING,HLFS,20)>$P(STRING,HLFS,19) S ERROR="Debts can't be greater than Other Property or Assets" G ZICQ
I '$G(DEPIEN) D I ERROR]"" G ZICQ
. I IVMTYPE'=1 Q
. I $P(ARRAY("ZMT"),HLFS,3)="C" Q
. S FLAG=0 F I=16:1:20 I $P(STRING,HLFS,I)]"" S FLAG=1 Q
. I 'FLAG,SPOUSE F I=16:1:20 I $P(ARRAY(SPOUSE,"ZIC"),HLFS,I)]"" S FLAG=1 Q
ZICQ Q ERROR
;
;
NUM(NUMBER,DIGIT,DECIMAL) ; function to determine if valid numeric value
;
; Input: NUMBER as data element to evaluate
; DIGIT as number of digits allowed
; DECIMAL as number of decimal places
;
N ERROR
S ERROR=0
I NUMBER'?.N.1".".2N S ERROR=1 G NUMQ
I $L($P(NUMBER,".",1))>DIGIT S ERROR=1 G NUMQ
I NUMBER<0 S ERROR=1
NUMQ Q ERROR
;
;
ZICFLD ; ZIC field names
;;
;;INCOME YEAR
;;SOCIAL SECURITY
;;US CIVIL SERVICE
;;US RAILROAD RETIREMENT
;;MILITARY RETIREMENT
;;UNEMPLOYMENT COMPENSATION
;;OTHER RETIREMENT
;;EMPLOYMENT INCOME
;;INTEREST, DIVIDEND, ANNUITY
;;WORKERS COMP/BLACK LUNG
;;OTHER INCOME
;;MEDICAL EXPENSES
;;FUNERAL AND BURIAL EXPENSES
;;EDUCATIONAL EXPENSES
;;CASH AMOUNT IN BANK ACCOUNTS
;;STOCKS AND BONDS
;;REAL PROPERTY
;;OTHER PROPERTY OR ASSETS
;;DEBTS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCME2 2658 printed Oct 16, 2024@18:02:09 Page 2
IVMCME2 ;ALB/SEK,BRM - CHECK ANNUAL INCOME DATA ; 12/18/01 2:19pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,49**;21-OCT-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine is called from IVMCME.
+5 ;
+6 ;
ZIC(STRING,DEPIEN) ; check validity of ZIC segment
+1 ;
+2 ; Input: STRING as ZIC segment
+3 ; DEPIEN as the IEN of the dependent in the array, if applicable
+4 ;
+5 ; Output: ERROR message or null
+6 ;
+7 NEW ERROR,FLAG,I,X,Y
+8 SET ERROR=""
SET X=$PIECE(STRING,HLFS,2)
SET FLAG=0
+9 IF $EXTRACT(X,1,4)<1992!($EXTRACT(X,5,8)'="0000")
SET ERROR="Invalid Income Year in ZIC"
GOTO ZICQ
+10 FOR I=3:1:20
IF $$NUM($PIECE(STRING,HLFS,I),7,2)
SET ERROR=$PIECE($TEXT(ZICFLD+I),";;",2)_" field content/length error"
QUIT
+11 IF ERROR]""
GOTO ZICQ
+12 IF $GET(DEPIEN)
Begin DoDot:1
+13 FOR I=13,14
IF $PIECE(STRING,HLFS,I)]""
SET ERROR="Dependents can't have medical or funeral expenses"
QUIT
+14 IF DEPIEN=SPOUSE
IF ($PIECE(STRING,HLFS,15)]"")
SET ERROR="No educational expenses for spouse"
QUIT
+15 IF DEPIEN'=SPOUSE
Begin DoDot:2
+16 IF $PIECE(STRING,HLFS,15)&('$PIECE(ARRAY(DEPIEN,"ZIR"),U,9))
SET ERROR="Dependent Educational Exp. error-income not avail. to vet"
QUIT
+17 SET X=$EXTRACT($PIECE(STRING,HLFS,2),1,4)
DO ^%DT
SET X=Y
+18 IF $PIECE(STRING,HLFS,15)]""
SET X=$PIECE(^DG(43,1,"MT",X,0),U,17)
IF X'<$PIECE(STRING,HLFS,9)
SET ERROR="Income does not exceed child exclusion amount-educational expense not allowed"
QUIT
+19 FOR I=16:1:20
IF $PIECE(STRING,HLFS,I)]""
SET ERROR="No net worth figures allowed for dependent children"
End DoDot:2
if ERROR]""
QUIT
End DoDot:1
IF ERROR]""
GOTO ZICQ
+20 IF $PIECE(STRING,HLFS,20)>$PIECE(STRING,HLFS,19)
SET ERROR="Debts can't be greater than Other Property or Assets"
GOTO ZICQ
+21 IF '$GET(DEPIEN)
Begin DoDot:1
+22 IF IVMTYPE'=1
QUIT
+23 IF $PIECE(ARRAY("ZMT"),HLFS,3)="C"
QUIT
+24 SET FLAG=0
FOR I=16:1:20
IF $PIECE(STRING,HLFS,I)]""
SET FLAG=1
QUIT
+25 IF 'FLAG
IF SPOUSE
FOR I=16:1:20
IF $PIECE(ARRAY(SPOUSE,"ZIC"),HLFS,I)]""
SET FLAG=1
QUIT
End DoDot:1
IF ERROR]""
GOTO ZICQ
ZICQ QUIT ERROR
+1 ;
+2 ;
NUM(NUMBER,DIGIT,DECIMAL) ; function to determine if valid numeric value
+1 ;
+2 ; Input: NUMBER as data element to evaluate
+3 ; DIGIT as number of digits allowed
+4 ; DECIMAL as number of decimal places
+5 ;
+6 NEW ERROR
+7 SET ERROR=0
+8 IF NUMBER'?.N.1".".2N
SET ERROR=1
GOTO NUMQ
+9 IF $LENGTH($PIECE(NUMBER,".",1))>DIGIT
SET ERROR=1
GOTO NUMQ
+10 IF NUMBER<0
SET ERROR=1
NUMQ QUIT ERROR
+1 ;
+2 ;
ZICFLD ; ZIC field names
+1 ;;
+2 ;;INCOME YEAR
+3 ;;SOCIAL SECURITY
+4 ;;US CIVIL SERVICE
+5 ;;US RAILROAD RETIREMENT
+6 ;;MILITARY RETIREMENT
+7 ;;UNEMPLOYMENT COMPENSATION
+8 ;;OTHER RETIREMENT
+9 ;;EMPLOYMENT INCOME
+10 ;;INTEREST, DIVIDEND, ANNUITY
+11 ;;WORKERS COMP/BLACK LUNG
+12 ;;OTHER INCOME
+13 ;;MEDICAL EXPENSES
+14 ;;FUNERAL AND BURIAL EXPENSES
+15 ;;EDUCATIONAL EXPENSES
+16 ;;CASH AMOUNT IN BANK ACCOUNTS
+17 ;;STOCKS AND BONDS
+18 ;;REAL PROPERTY
+19 ;;OTHER PROPERTY OR ASSETS
+20 ;;DEBTS
