DG53551P ;ALB/PHH - 2004 MEANS TEST THRESHOLDS ;12/10/03
;;5.3;Registration;**551**;Aug 13, 1993
;
; This routine will upload the 2004 means test thresholds onto your
; system.
;
EN ; Enter values distributed in VHA DIRECTIVE 2003-069, MEANS TEST AND
; GEOGRAPHIC-BASED MEANS TEST THRESHOLDS FOR CALENDAR YEAR 2004.
;
N DA,DIE,DIC,DINUM,DR,I,X,Y,EXST
S EXST=0
D BMES^XPDUTL(">>>Means Test Thresholds for 2004 being installed...")
I $D(^DG(43,1,"MT",3040000)) D
.D BMES^XPDUTL(" ...Entry exists for income year 2003, entry being deleted")
.D MES^XPDUTL(" and replaced with nationally released thresholds.")
.S DIK="^DG(43,1,""MT"",",DA=3040000,DA(1)=1
.D ^DIK,IX1^DIK
.K DA,D0,DIK
K DO
S DIC="^DG(43,1,""MT"","
S DIC(0)="L"
S DA(1)=1
S (DINUM,X)=3040000
D FILE^DICN
S DA=+Y
;
I +Y'=3040000 D Q
. D BMES^XPDUTL(" ...Problem encountered adding 2004 thresholds. Please try")
. D MES^XPDUTL(" again or contact the CIO Field Office for assistance.")
;
D MES^XPDUTL("")
S DIE=DIC,DR=""
F I=1:1 S X=$P($T(DATA+I),";;",2) Q:X="QUIT" D ; build dr string
. S DR=DR_+X_"////"_$P(X,"^",2)_";"
. D MES^XPDUTL(" "_$P(X,"^",3)_" set to $"_$FN($P(X,"^",2),","))
D ^DIE
Q
;
;
DATA ; lines to stuff in values (field////value)
;;2^25162^MT COPAY EXEMPT VET INCOME
;;3^5035^MT COPAY EXEMPT 1ST DEP INCOME
;;4^1688^MT COPAY EXEMPT INCOME PER DEP
;;8^80000^THRESHOLD PROPERTY
;;17^7950^CHILD INCOME EXCLUSION
;;QUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53551P 1504 printed Dec 13, 2024@02:37:47 Page 2
DG53551P ;ALB/PHH - 2004 MEANS TEST THRESHOLDS ;12/10/03
+1 ;;5.3;Registration;**551**;Aug 13, 1993
+2 ;
+3 ; This routine will upload the 2004 means test thresholds onto your
+4 ; system.
+5 ;
EN ; Enter values distributed in VHA DIRECTIVE 2003-069, MEANS TEST AND
+1 ; GEOGRAPHIC-BASED MEANS TEST THRESHOLDS FOR CALENDAR YEAR 2004.
+2 ;
+3 NEW DA,DIE,DIC,DINUM,DR,I,X,Y,EXST
+4 SET EXST=0
+5 DO BMES^XPDUTL(">>>Means Test Thresholds for 2004 being installed...")
+6 IF $DATA(^DG(43,1,"MT",3040000))
Begin DoDot:1
+7 DO BMES^XPDUTL(" ...Entry exists for income year 2003, entry being deleted")
+8 DO MES^XPDUTL(" and replaced with nationally released thresholds.")
+9 SET DIK="^DG(43,1,""MT"","
SET DA=3040000
SET DA(1)=1
+10 DO ^DIK
DO IX1^DIK
+11 KILL DA,D0,DIK
End DoDot:1
+12 KILL DO
+13 SET DIC="^DG(43,1,""MT"","
+14 SET DIC(0)="L"
+15 SET DA(1)=1
+16 SET (DINUM,X)=3040000
+17 DO FILE^DICN
+18 SET DA=+Y
+19 ;
+20 IF +Y'=3040000
Begin DoDot:1
+21 DO BMES^XPDUTL(" ...Problem encountered adding 2004 thresholds. Please try")
+22 DO MES^XPDUTL(" again or contact the CIO Field Office for assistance.")
End DoDot:1
QUIT
+23 ;
+24 DO MES^XPDUTL("")
+25 SET DIE=DIC
SET DR=""
+26 ; build dr string
FOR I=1:1
SET X=$PIECE($TEXT(DATA+I),";;",2)
if X="QUIT"
QUIT
Begin DoDot:1
+27 SET DR=DR_+X_"////"_$PIECE(X,"^",2)_";"
+28 DO MES^XPDUTL(" "_$PIECE(X,"^",3)_" set to $"_$FNUMBER($PIECE(X,"^",2),","))
End DoDot:1
+29 DO ^DIE
+30 QUIT
+31 ;
+32 ;
DATA ; lines to stuff in values (field////value)
+1 ;;2^25162^MT COPAY EXEMPT VET INCOME
+2 ;;3^5035^MT COPAY EXEMPT 1ST DEP INCOME
+3 ;;4^1688^MT COPAY EXEMPT INCOME PER DEP
+4 ;;8^80000^THRESHOLD PROPERTY
+5 ;;17^7950^CHILD INCOME EXCLUSION
+6 ;;QUIT
+7 QUIT
