| 1 | IVMUCHK5 ;ALB/CAW Edit Checks con't ; 9/29/94
|
|---|
| 2 | ;;2.0;INCOME VERIFICATION MATCH;**10**; 21-OCT-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine is a continuation of IVMUCHK. It performs checks on incoming means test
|
|---|
| 6 | ; transmissions to ensure they are accurate prior to their upload into DHCP.
|
|---|
| 7 | ;
|
|---|
| 8 | ;
|
|---|
| 9 | MT(STRING,INCOME) ; Calculate means test status
|
|---|
| 10 | ;
|
|---|
| 11 | N X,Y,ADJ,INC,NET,THRESH S STATUS="C"
|
|---|
| 12 | S X=$P(STRING,HLFS,3) I X'="A",(X'="C") S ERROR="Invalid Means Test Status" G MTQ
|
|---|
| 13 | ;
|
|---|
| 14 | S X=$E($P(STRING,HLFS,2),1,4),%DT="" D ^%DT S X=Y K %DT
|
|---|
| 15 | S THRESH=$G(^DG(43,1,"MT",X,0))
|
|---|
| 16 | 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))
|
|---|
| 17 | ;
|
|---|
| 18 | S CAT=$P(STRING,HLFS,3)
|
|---|
| 19 | S ADJ=$P(STRING,HLFS,6)
|
|---|
| 20 | S INC=$P(STRING,HLFS,4)-$P(STRING,HLFS,9)
|
|---|
| 21 | S NET=$P(STRING,HLFS,5)
|
|---|
| 22 | S THRESHA=$P(STRING,HLFS,8)
|
|---|
| 23 | I THRESHT'=THRESHA S ERROR="Threshold A value incorrect" G MTQ
|
|---|
| 24 | I INC'>THRESHA D I ERROR]"" G MTQ
|
|---|
| 25 | . I NET']"" S ERROR="This veteran requires net worth" Q
|
|---|
| 26 | . I ((INC+NET)'>$P(THRESH,U,8))&(CAT="C") S ERROR="Income plus net worth not greater than threshold value-incorrect status" Q
|
|---|
| 27 | . I ((INC+NET)'<$P(THRESH,U,8))&(CAT="C"),'$P(STRING,HLFS,6) S ERROR="Patient should be adjudicated-no adjudicated date/time" Q
|
|---|
| 28 | I INC>THRESHA,CAT'="C" S ERROR="Incorrect means test status"
|
|---|
| 29 | MTQ Q
|
|---|
| 30 | ;
|
|---|
| 31 | INC ; gather income totals
|
|---|
| 32 | N DEBD,DEB,DEBT,DGX,EXCL,INC,NET,X,Y
|
|---|
| 33 | I $P(STRING,HLFS,4)']"" S ERROR="No Income transmitted"
|
|---|
| 34 | S INC=$P(ARRAY("ZIC"),HLFS,21),DEBT=$P(ARRAY("ZIC"),HLFS,22),NET=$P(ARRAY("ZIC"),HLFS,23)
|
|---|
| 35 | S DGX=0 F S DGX=$O(ARRAY(DGX)) Q:'DGX D
|
|---|
| 36 | .S INC=INC+($P(ARRAY(DGX,"ZIC"),HLFS,21))
|
|---|
| 37 | .S NET=NET+($P(ARRAY(DGX,"ZIC"),HLFS,23))
|
|---|
| 38 | .I $P(ARRAY(DGX,"ZDP"),U,6)'=2 D Q
|
|---|
| 39 | ..S X=$E($P(ARRAY("ZMT"),U,2),1,4),%DT="" D ^%DT S INCYR=Y
|
|---|
| 40 | ..S EXCL=$P($G(^DG(43,1,"MT",INCYR,0)),U,17)
|
|---|
| 41 | ..S DEBD=($P(ARRAY(DGX,"ZIC"),HLFS,9)-EXCL-$P(ARRAY(DGX,"ZIC"),HLFS,15))
|
|---|
| 42 | ..S DEBD=$S(DEBD>0:DEBD,1:0)
|
|---|
| 43 | ..S DEB=($P(ARRAY(DGX,"ZIC"),HLFS,9)-DEBD)
|
|---|
| 44 | ..S DEBT=DEBT+DEB
|
|---|
| 45 | .S DEBT=DEBT+($P(ARRAY(DGX,"ZIC"),HLFS,22))
|
|---|
| 46 | I +INC'=+$P(STRING,HLFS,4) S ERROR="Income total does not match Income total on means test" G INCQ
|
|---|
| 47 | I +DEBT'=+$P(STRING,HLFS,9) S ERROR="Deductible Expenses total does not match Deductible Expenses total on means test" G INCQ
|
|---|
| 48 | I +NET'=+$P(STRING,HLFS,5) S ERROR="Net Worth total does not match Net Worth total on means test" G INCQ
|
|---|
| 49 | INCQ Q
|
|---|
| 50 | ;
|
|---|
| 51 | SIGN ; Date Veteran Signed/Refused to Sign
|
|---|
| 52 | I $P(STRING,HLFS,15)]"" D G:ERROR]"" SIGNQ
|
|---|
| 53 | .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
|
|---|
| 54 | .S X=$$FMDATE^HLFNC($P(STRING,HLFS,15)),%DT="X" D ^%DT I Y<0 S ERROR="Invalid Date Veteran Signed Test" Q
|
|---|
| 55 | .I $P(STRING,HLFS,20)]"" S ERROR="Veteran Signed Test, IVM Complete Date should be blank" Q
|
|---|
| 56 | I $P(STRING,HLFS,15)']"" D
|
|---|
| 57 | .I $P(STRING,HLFS,20)']"" S ERROR="Both Date Veteran Signed and IVM Complete Date are blank"
|
|---|
| 58 | SIGNQ Q
|
|---|
