- IVMUCHK5 ;ALB/CAW Edit Checks con't ; 9/29/94
- ;;2.0;INCOME VERIFICATION MATCH;**10**; 21-OCT-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ; This routine is a continuation of IVMUCHK. It performs checks on incoming means test
- ; transmissions to ensure they are accurate prior to their upload into DHCP.
- ;
- ;
- MT(STRING,INCOME) ; Calculate means test status
- ;
- N X,Y,ADJ,INC,NET,THRESH S STATUS="C"
- S X=$P(STRING,HLFS,3) I X'="A",(X'="C") S ERROR="Invalid Means Test Status" G MTQ
- ;
- S X=$E($P(STRING,HLFS,2),1,4),%DT="" D ^%DT S X=Y K %DT
- S THRESH=$G(^DG(43,1,"MT",X,0))
- S THRESHT=$P(THRESH,U,2) I $P(STRING,HLFS,12) S THRESHT=THRESHT+$P(THRESH,U,3)+(($P(STRING,HLFS,12)-1)*$P(THRESH,U,4))
- ;
- S CAT=$P(STRING,HLFS,3)
- S ADJ=$P(STRING,HLFS,6)
- S INC=$P(STRING,HLFS,4)-$P(STRING,HLFS,9)
- S NET=$P(STRING,HLFS,5)
- S THRESHA=$P(STRING,HLFS,8)
- I THRESHT'=THRESHA S ERROR="Threshold A value incorrect" G MTQ
- I INC'>THRESHA D I ERROR]"" G MTQ
- . I NET']"" S ERROR="This veteran requires net worth" Q
- . I ((INC+NET)'>$P(THRESH,U,8))&(CAT="C") S ERROR="Income plus net worth not greater than threshold value-incorrect status" Q
- . I ((INC+NET)'<$P(THRESH,U,8))&(CAT="C"),'$P(STRING,HLFS,6) S ERROR="Patient should be adjudicated-no adjudicated date/time" Q
- I INC>THRESHA,CAT'="C" S ERROR="Incorrect means test status"
- MTQ Q
- ;
- INC ; gather income totals
- N DEBD,DEB,DEBT,DGX,EXCL,INC,NET,X,Y
- I $P(STRING,HLFS,4)']"" S ERROR="No Income transmitted"
- S INC=$P(ARRAY("ZIC"),HLFS,21),DEBT=$P(ARRAY("ZIC"),HLFS,22),NET=$P(ARRAY("ZIC"),HLFS,23)
- S DGX=0 F S DGX=$O(ARRAY(DGX)) Q:'DGX D
- .S INC=INC+($P(ARRAY(DGX,"ZIC"),HLFS,21))
- .S NET=NET+($P(ARRAY(DGX,"ZIC"),HLFS,23))
- .I $P(ARRAY(DGX,"ZDP"),U,6)'=2 D Q
- ..S X=$E($P(ARRAY("ZMT"),U,2),1,4),%DT="" D ^%DT S INCYR=Y
- ..S EXCL=$P($G(^DG(43,1,"MT",INCYR,0)),U,17)
- ..S DEBD=($P(ARRAY(DGX,"ZIC"),HLFS,9)-EXCL-$P(ARRAY(DGX,"ZIC"),HLFS,15))
- ..S DEBD=$S(DEBD>0:DEBD,1:0)
- ..S DEB=($P(ARRAY(DGX,"ZIC"),HLFS,9)-DEBD)
- ..S DEBT=DEBT+DEB
- .S DEBT=DEBT+($P(ARRAY(DGX,"ZIC"),HLFS,22))
- I +INC'=+$P(STRING,HLFS,4) S ERROR="Income total does not match Income total on means test" G INCQ
- I +DEBT'=+$P(STRING,HLFS,9) S ERROR="Deductible Expenses total does not match Deductible Expenses total on means test" G INCQ
- I +NET'=+$P(STRING,HLFS,5) S ERROR="Net Worth total does not match Net Worth total on means test" G INCQ
- INCQ Q
- ;
- SIGN ; Date Veteran Signed/Refused to Sign
- I $P(STRING,HLFS,15)]"" D G:ERROR]"" SIGNQ
- .S X=$P(STRING,HLFS,15) I $E(X,1,4)<1994!($E(X,1,4)>($E(DT,1,3)+1700)) S ERROR="Invalid Date Veteran Signed Test" Q
- .S X=$$FMDATE^HLFNC($P(STRING,HLFS,15)),%DT="X" D ^%DT I Y<0 S ERROR="Invalid Date Veteran Signed Test" Q
- .I $P(STRING,HLFS,20)]"" S ERROR="Veteran Signed Test, IVM Complete Date should be blank" Q
- I $P(STRING,HLFS,15)']"" D
- .I $P(STRING,HLFS,20)']"" S ERROR="Both Date Veteran Signed and IVM Complete Date are blank"
- SIGNQ Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMUCHK5 2995 printed Apr 23, 2025@18:16:27 Page 2
- IVMUCHK5 ;ALB/CAW Edit Checks con't ; 9/29/94
- +1 ;;2.0;INCOME VERIFICATION MATCH;**10**; 21-OCT-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ; This routine is a continuation of IVMUCHK. It performs checks on incoming means test
- +5 ; transmissions to ensure they are accurate prior to their upload into DHCP.
- +6 ;
- +7 ;
- MT(STRING,INCOME) ; Calculate means test status
- +1 ;
- +2 NEW X,Y,ADJ,INC,NET,THRESH
- SET STATUS="C"
- +3 SET X=$PIECE(STRING,HLFS,3)
- IF X'="A"
- IF (X'="C")
- SET ERROR="Invalid Means Test Status"
- GOTO MTQ
- +4 ;
- +5 SET X=$EXTRACT($PIECE(STRING,HLFS,2),1,4)
- SET %DT=""
- DO ^%DT
- SET X=Y
- KILL %DT
- +6 SET THRESH=$GET(^DG(43,1,"MT",X,0))
- +7 SET THRESHT=$PIECE(THRESH,U,2)
- IF $PIECE(STRING,HLFS,12)
- SET THRESHT=THRESHT+$PIECE(THRESH,U,3)+(($PIECE(STRING,HLFS,12)-1)*$PIECE(THRESH,U,4))
- +8 ;
- +9 SET CAT=$PIECE(STRING,HLFS,3)
- +10 SET ADJ=$PIECE(STRING,HLFS,6)
- +11 SET INC=$PIECE(STRING,HLFS,4)-$PIECE(STRING,HLFS,9)
- +12 SET NET=$PIECE(STRING,HLFS,5)
- +13 SET THRESHA=$PIECE(STRING,HLFS,8)
- +14 IF THRESHT'=THRESHA
- SET ERROR="Threshold A value incorrect"
- GOTO MTQ
- +15 IF INC'>THRESHA
- Begin DoDot:1
- +16 IF NET']""
- SET ERROR="This veteran requires net worth"
- QUIT
- +17 IF ((INC+NET)'>$PIECE(THRESH,U,8))&(CAT="C")
- SET ERROR="Income plus net worth not greater than threshold value-incorrect status"
- QUIT
- +18 IF ((INC+NET)'<$PIECE(THRESH,U,8))&(CAT="C")
- IF '$PIECE(STRING,HLFS,6)
- SET ERROR="Patient should be adjudicated-no adjudicated date/time"
- QUIT
- End DoDot:1
- IF ERROR]""
- GOTO MTQ
- +19 IF INC>THRESHA
- IF CAT'="C"
- SET ERROR="Incorrect means test status"
- MTQ QUIT
- +1 ;
- INC ; gather income totals
- +1 NEW DEBD,DEB,DEBT,DGX,EXCL,INC,NET,X,Y
- +2 IF $PIECE(STRING,HLFS,4)']""
- SET ERROR="No Income transmitted"
- +3 SET INC=$PIECE(ARRAY("ZIC"),HLFS,21)
- SET DEBT=$PIECE(ARRAY("ZIC"),HLFS,22)
- SET NET=$PIECE(ARRAY("ZIC"),HLFS,23)
- +4 SET DGX=0
- FOR
- SET DGX=$ORDER(ARRAY(DGX))
- if 'DGX
- QUIT
- Begin DoDot:1
- +5 SET INC=INC+($PIECE(ARRAY(DGX,"ZIC"),HLFS,21))
- +6 SET NET=NET+($PIECE(ARRAY(DGX,"ZIC"),HLFS,23))
- +7 IF $PIECE(ARRAY(DGX,"ZDP"),U,6)'=2
- Begin DoDot:2
- +8 SET X=$EXTRACT($PIECE(ARRAY("ZMT"),U,2),1,4)
- SET %DT=""
- DO ^%DT
- SET INCYR=Y
- +9 SET EXCL=$PIECE($GET(^DG(43,1,"MT",INCYR,0)),U,17)
- +10 SET DEBD=($PIECE(ARRAY(DGX,"ZIC"),HLFS,9)-EXCL-$PIECE(ARRAY(DGX,"ZIC"),HLFS,15))
- +11 SET DEBD=$SELECT(DEBD>0:DEBD,1:0)
- +12 SET DEB=($PIECE(ARRAY(DGX,"ZIC"),HLFS,9)-DEBD)
- +13 SET DEBT=DEBT+DEB
- End DoDot:2
- QUIT
- +14 SET DEBT=DEBT+($PIECE(ARRAY(DGX,"ZIC"),HLFS,22))
- End DoDot:1
- +15 IF +INC'=+$PIECE(STRING,HLFS,4)
- SET ERROR="Income total does not match Income total on means test"
- GOTO INCQ
- +16 IF +DEBT'=+$PIECE(STRING,HLFS,9)
- SET ERROR="Deductible Expenses total does not match Deductible Expenses total on means test"
- GOTO INCQ
- +17 IF +NET'=+$PIECE(STRING,HLFS,5)
- SET ERROR="Net Worth total does not match Net Worth total on means test"
- GOTO INCQ
- INCQ QUIT
- +1 ;
- SIGN ; Date Veteran Signed/Refused to Sign
- +1 IF $PIECE(STRING,HLFS,15)]""
- Begin DoDot:1
- +2 SET X=$PIECE(STRING,HLFS,15)
- IF $EXTRACT(X,1,4)<1994!($EXTRACT(X,1,4)>($EXTRACT(DT,1,3)+1700))
- SET ERROR="Invalid Date Veteran Signed Test"
- QUIT
- +3 SET X=$$FMDATE^HLFNC($PIECE(STRING,HLFS,15))
- SET %DT="X"
- DO ^%DT
- IF Y<0
- SET ERROR="Invalid Date Veteran Signed Test"
- QUIT
- +4 IF $PIECE(STRING,HLFS,20)]""
- SET ERROR="Veteran Signed Test, IVM Complete Date should be blank"
- QUIT
- End DoDot:1
- if ERROR]""
- GOTO SIGNQ
- +5 IF $PIECE(STRING,HLFS,15)']""
- Begin DoDot:1
- +6 IF $PIECE(STRING,HLFS,20)']""
- SET ERROR="Both Date Veteran Signed and IVM Complete Date are blank"
- End DoDot:1
- SIGNQ QUIT
