- IVMCME4 ;ALB/SEK,BRM,TDM - CHECK INCOME TEST DATA ; 8/28/02 2:19pm
- ;;2.0;INCOME VERIFICATION MATCH;**17,49,58,62**;21-OCT-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ; This routine is called from IVMCME.
- ;
- ZMT(STRING) ; check ZMT segment
- ;
- ; Input: STRING as ZMT segment
- ;
- ; Output: ERROR message or null
- ;
- N ERROR,I,X,Y
- S ERROR=""
- S X=$P(STRING,HLFS,2) I $E(X,1,4)<1993 S ERROR="Invalid Date of Test" G ZMTQ
- S X=$$FMDATE^HLFNC(X),%DT="X" D ^%DT I Y<0 S ERROR="Invalid Date of Test" G ZMTQ
- ;
- ; Means Test Status Checks
- I IVMTYPE=1 D MT^IVMCME5(STRING,ARRAY("ZIC")) I ERROR]"" G ZMTQ
- ;
- ; Copay Test Status Checks
- I IVMTYPE=2 D CO^IVMCME5(STRING) I ERROR]"" G ZMTQ
- ;
- ; Long Term Care Status Checks
- I IVMTYPE=4 D LTC^IVMCME5(STRING) I ERROR]"" G ZMTQ
- ;
- ; Field content/length
- F I=4,5 I $$NUM^IVMCME2($P(STRING,HLFS,I),10,2) S ERROR=$S(I=4:"INCOME",1:"NET WORTH")_" field content/length error" Q
- I ERROR]"" G ZMTQ
- ;
- ; gather income totals
- D INC^IVMCME5 I ERROR]"" G ZMTQ
- ;
- ; Adjudicate Date/Time
- S X=$P(STRING,HLFS,6) I X]"" D I ERROR]"" G ZMTQ
- . I $E(X,1,4)<1993!($E(X,1,4)>($E(DT,1,3)+1700)) S ERROR="Invalid Adjudication Date/Time" Q
- . S X=$$FMDATE^HLFNC(X),%DT="TX" D ^%DT I Y<0 S ERROR="Invalid Adjudication Date/Time" Q
- ;
- ; Agree to Pay Deductible
- S X=$P(STRING,HLFS,7) I X]"",(X'=0),(X'=1) S ERROR="Invalid Agreed To Pay Deductible Value" G ZMTQ
- I $P(STRING,HLFS,26)="A",X'="" S ERROR="MT Copay Exempt veteran-Agree to Pay Deductible should be null" G ZMTQ
- ;
- ; Threshold A value
- I IVMTYPE=1 D I ERROR]"" G ZMTQ
- .S X=$P(STRING,HLFS,8) I X']"" S ERROR="Invalid Threshold A value"
- .I (X'>0)!(X'<99001) S ERROR="Invalid Threshold A value"
- ;
- ; GMT Threshold Value
- I IVMTYPE=1 D I ERROR]"" G ZMTQ
- .S X=$P(STRING,HLFS,28)
- .I ((X'="")&(X'=0))&((X'>0)!(X'<100000)) S ERROR="Invalid GMT Threshold"
- ;
- ; Deductibe Expenses
- I $$NUM^IVMCME2($P(STRING,HLFS,9),10,2) S ERROR="Deductible Expenses field content/length error" G ZMTQ
- I $P(STRING,HLFS,4)<($P(STRING,HLFS,9)) S ERROR="Deductible Expenses cannot exceed income" G ZMTQ
- ;
- ; Means Test Completion Date/Time
- S X=$P(STRING,HLFS,10) I $E(X,1,4)<1992 S ERROR="Invalid Completion Date/Time" G ZMTQ
- S X=$$FMDATE^HLFNC(X),%DT="TX" D ^%DT I Y<0 S ERROR="Invalid Completion Date/Time" G ZMTQ
- ;
- ; Hardship consistency checks
- N HARDSHIP K HARDSHIP
- S HARDSHIP("Y/N")=$P(STRING,HLFS,13)
- S HARDSHIP("SITE")=$P(STRING,HLFS,23)
- S HARDSHIP("EFFDATE")=$P(STRING,HLFS,24)
- ;
- I (IVMTYPE'=4),(HARDSHIP("Y/N"))!(+HARDSHIP("SITE"))!(HARDSHIP("EFFDATE")) D I ERROR]"" G ZMTQ
- .I HARDSHIP("Y/N")="" S ERROR="Missing Hardship Indicator" Q
- .I HARDSHIP("SITE")="" S ERROR="Missing Site Granting Hardship" Q
- .;starting in year 2000, all hardships should have an effective date
- .I $E($P(STRING,HLFS,2),1,4)'<2000,(HARDSHIP("EFFDATE")="") S ERROR="Missing Hardship Effective Date" Q
- .I $L(HARDSHIP("EFFDATE")) S X=$$FMDATE^HLFNC(HARDSHIP("EFFDATE")),%DT=X D ^%DT I Y<0 S ERROR="Invalid Hardship Effective Date" Q
- .I HARDSHIP("EFFDATE"),(HARDSHIP("EFFDATE")<$P(STRING,HLFS,2)) S ERROR="Hardship Effective Date earlier than Means Test Date" Q
- ;
- ; Date Veteran Signed/Refused to Sign
- D SIGN^IVMCME5 I ERROR]"" G ZMTQ
- ;
- ; Source of Test
- S X=$P(STRING,HLFS,18)
- I X'=1,X'=2,X'=3,X'=4 S ERROR="Source of Test must be identified" G ZMTQ
- I X=4,$P(STRING,HLFS,22)="" S ERROR="Site Conducting Test must be identified" G ZMTQ
- ;
- ZMTQ Q ERROR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCME4 3538 printed Mar 13, 2025@21:05:30 Page 2
- IVMCME4 ;ALB/SEK,BRM,TDM - CHECK INCOME TEST DATA ; 8/28/02 2:19pm
- +1 ;;2.0;INCOME VERIFICATION MATCH;**17,49,58,62**;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 ;
- ZMT(STRING) ; check ZMT segment
- +1 ;
- +2 ; Input: STRING as ZMT segment
- +3 ;
- +4 ; Output: ERROR message or null
- +5 ;
- +6 NEW ERROR,I,X,Y
- +7 SET ERROR=""
- +8 SET X=$PIECE(STRING,HLFS,2)
- IF $EXTRACT(X,1,4)<1993
- SET ERROR="Invalid Date of Test"
- GOTO ZMTQ
- +9 SET X=$$FMDATE^HLFNC(X)
- SET %DT="X"
- DO ^%DT
- IF Y<0
- SET ERROR="Invalid Date of Test"
- GOTO ZMTQ
- +10 ;
- +11 ; Means Test Status Checks
- +12 IF IVMTYPE=1
- DO MT^IVMCME5(STRING,ARRAY("ZIC"))
- IF ERROR]""
- GOTO ZMTQ
- +13 ;
- +14 ; Copay Test Status Checks
- +15 IF IVMTYPE=2
- DO CO^IVMCME5(STRING)
- IF ERROR]""
- GOTO ZMTQ
- +16 ;
- +17 ; Long Term Care Status Checks
- +18 IF IVMTYPE=4
- DO LTC^IVMCME5(STRING)
- IF ERROR]""
- GOTO ZMTQ
- +19 ;
- +20 ; Field content/length
- +21 FOR I=4,5
- IF $$NUM^IVMCME2($PIECE(STRING,HLFS,I),10,2)
- SET ERROR=$SELECT(I=4:"INCOME",1:"NET WORTH")_" field content/length error"
- QUIT
- +22 IF ERROR]""
- GOTO ZMTQ
- +23 ;
- +24 ; gather income totals
- +25 DO INC^IVMCME5
- IF ERROR]""
- GOTO ZMTQ
- +26 ;
- +27 ; Adjudicate Date/Time
- +28 SET X=$PIECE(STRING,HLFS,6)
- IF X]""
- Begin DoDot:1
- +29 IF $EXTRACT(X,1,4)<1993!($EXTRACT(X,1,4)>($EXTRACT(DT,1,3)+1700))
- SET ERROR="Invalid Adjudication Date/Time"
- QUIT
- +30 SET X=$$FMDATE^HLFNC(X)
- SET %DT="TX"
- DO ^%DT
- IF Y<0
- SET ERROR="Invalid Adjudication Date/Time"
- QUIT
- End DoDot:1
- IF ERROR]""
- GOTO ZMTQ
- +31 ;
- +32 ; Agree to Pay Deductible
- +33 SET X=$PIECE(STRING,HLFS,7)
- IF X]""
- IF (X'=0)
- IF (X'=1)
- SET ERROR="Invalid Agreed To Pay Deductible Value"
- GOTO ZMTQ
- +34 IF $PIECE(STRING,HLFS,26)="A"
- IF X'=""
- SET ERROR="MT Copay Exempt veteran-Agree to Pay Deductible should be null"
- GOTO ZMTQ
- +35 ;
- +36 ; Threshold A value
- +37 IF IVMTYPE=1
- Begin DoDot:1
- +38 SET X=$PIECE(STRING,HLFS,8)
- IF X']""
- SET ERROR="Invalid Threshold A value"
- +39 IF (X'>0)!(X'<99001)
- SET ERROR="Invalid Threshold A value"
- End DoDot:1
- IF ERROR]""
- GOTO ZMTQ
- +40 ;
- +41 ; GMT Threshold Value
- +42 IF IVMTYPE=1
- Begin DoDot:1
- +43 SET X=$PIECE(STRING,HLFS,28)
- +44 IF ((X'="")&(X'=0))&((X'>0)!(X'<100000))
- SET ERROR="Invalid GMT Threshold"
- End DoDot:1
- IF ERROR]""
- GOTO ZMTQ
- +45 ;
- +46 ; Deductibe Expenses
- +47 IF $$NUM^IVMCME2($PIECE(STRING,HLFS,9),10,2)
- SET ERROR="Deductible Expenses field content/length error"
- GOTO ZMTQ
- +48 IF $PIECE(STRING,HLFS,4)<($PIECE(STRING,HLFS,9))
- SET ERROR="Deductible Expenses cannot exceed income"
- GOTO ZMTQ
- +49 ;
- +50 ; Means Test Completion Date/Time
- +51 SET X=$PIECE(STRING,HLFS,10)
- IF $EXTRACT(X,1,4)<1992
- SET ERROR="Invalid Completion Date/Time"
- GOTO ZMTQ
- +52 SET X=$$FMDATE^HLFNC(X)
- SET %DT="TX"
- DO ^%DT
- IF Y<0
- SET ERROR="Invalid Completion Date/Time"
- GOTO ZMTQ
- +53 ;
- +54 ; Hardship consistency checks
- +55 NEW HARDSHIP
- KILL HARDSHIP
- +56 SET HARDSHIP("Y/N")=$PIECE(STRING,HLFS,13)
- +57 SET HARDSHIP("SITE")=$PIECE(STRING,HLFS,23)
- +58 SET HARDSHIP("EFFDATE")=$PIECE(STRING,HLFS,24)
- +59 ;
- +60 IF (IVMTYPE'=4)
- IF (HARDSHIP("Y/N"))!(+HARDSHIP("SITE"))!(HARDSHIP("EFFDATE"))
- Begin DoDot:1
- +61 IF HARDSHIP("Y/N")=""
- SET ERROR="Missing Hardship Indicator"
- QUIT
- +62 IF HARDSHIP("SITE")=""
- SET ERROR="Missing Site Granting Hardship"
- QUIT
- +63 ;starting in year 2000, all hardships should have an effective date
- +64 IF $EXTRACT($PIECE(STRING,HLFS,2),1,4)'<2000
- IF (HARDSHIP("EFFDATE")="")
- SET ERROR="Missing Hardship Effective Date"
- QUIT
- +65 IF $LENGTH(HARDSHIP("EFFDATE"))
- SET X=$$FMDATE^HLFNC(HARDSHIP("EFFDATE"))
- SET %DT=X
- DO ^%DT
- IF Y<0
- SET ERROR="Invalid Hardship Effective Date"
- QUIT
- +66 IF HARDSHIP("EFFDATE")
- IF (HARDSHIP("EFFDATE")<$PIECE(STRING,HLFS,2))
- SET ERROR="Hardship Effective Date earlier than Means Test Date"
- QUIT
- End DoDot:1
- IF ERROR]""
- GOTO ZMTQ
- +67 ;
- +68 ; Date Veteran Signed/Refused to Sign
- +69 DO SIGN^IVMCME5
- IF ERROR]""
- GOTO ZMTQ
- +70 ;
- +71 ; Source of Test
- +72 SET X=$PIECE(STRING,HLFS,18)
- +73 IF X'=1
- IF X'=2
- IF X'=3
- IF X'=4
- SET ERROR="Source of Test must be identified"
- GOTO ZMTQ
- +74 IF X=4
- IF $PIECE(STRING,HLFS,22)=""
- SET ERROR="Site Conducting Test must be identified"
- GOTO ZMTQ
- +75 ;
- ZMTQ QUIT ERROR
