DG53211P ;ALB/SEK - 1999 MEANS TEST THRESHOLD UPDATE ROUTINE; 17 November 1998
;;5.3;Registration;**211**;Aug 13, 1993
;
; This routine will upload the 1999 means test thresholds onto your system.
;
EN ; enter values distributed by Roscoe Butler. VHA Directive soon to be released.
N DA,DIE,DIC,DINUM,DR,I,X,Y
D BMES^XPDUTL(">>>Means Test Thesholds for 1999 being installed...")
I $D(^DG(43,1,"MT",2990000)) D Q
. D BMES^XPDUTL(" ...Thresholds already exist for 1999...nothing done.")
;
S DIC="^DG(43,1,""MT"",",DIC(0)="L"
S DIC("P")=$P(^DD(43,250,0),U,2),DA(1)=1
S (DINUM,X)=2990000
D FILE^DICN
S DA=+Y
;
I +Y'=2990000 D Q
. D BMES^XPDUTL(" ...Problem encountered adding 1999 thresholds. Please try")
. D MES^XPDUTL(" again or contact your IRM 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^22351^CAT A VET INCOME
;;3^4473^CAT A FIRST DEPENDENT INCOME
;;4^1496^CAT A INCOME PER DEPENDENT
;;8^50000^THRESHOLD PROPERTY
;;17^7050^CHILD INCOME EXCLUSION
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53211P 1311 printed Nov 22, 2024@17:46:40 Page 2
DG53211P ;ALB/SEK - 1999 MEANS TEST THRESHOLD UPDATE ROUTINE; 17 November 1998
+1 ;;5.3;Registration;**211**;Aug 13, 1993
+2 ;
+3 ; This routine will upload the 1999 means test thresholds onto your system.
+4 ;
EN ; enter values distributed by Roscoe Butler. VHA Directive soon to be released.
+1 NEW DA,DIE,DIC,DINUM,DR,I,X,Y
+2 DO BMES^XPDUTL(">>>Means Test Thesholds for 1999 being installed...")
+3 IF $DATA(^DG(43,1,"MT",2990000))
Begin DoDot:1
+4 DO BMES^XPDUTL(" ...Thresholds already exist for 1999...nothing done.")
End DoDot:1
QUIT
+5 ;
+6 SET DIC="^DG(43,1,""MT"","
SET DIC(0)="L"
+7 SET DIC("P")=$PIECE(^DD(43,250,0),U,2)
SET DA(1)=1
+8 SET (DINUM,X)=2990000
+9 DO FILE^DICN
+10 SET DA=+Y
+11 ;
+12 IF +Y'=2990000
Begin DoDot:1
+13 DO BMES^XPDUTL(" ...Problem encountered adding 1999 thresholds. Please try")
+14 DO MES^XPDUTL(" again or contact your IRM Field Office for assistance.")
End DoDot:1
QUIT
+15 ;
+16 DO MES^XPDUTL("")
+17 SET DIE=DIC
SET DR=""
+18 ; build dr string
FOR I=1:1
SET X=$PIECE($TEXT(DATA+I),";;",2)
if X="QUIT"
QUIT
Begin DoDot:1
+19 SET DR=DR_+X_"////"_$PIECE(X,"^",2)_";"
+20 DO MES^XPDUTL(" "_$PIECE(X,"^",3)_" set to $"_$FNUMBER($PIECE(X,"^",2),","))
End DoDot:1
+21 DO ^DIE
+22 QUIT
+23 ;
+24 ;
DATA ; lines to stuff in values (field////value)
+1 ;;2^22351^CAT A VET INCOME
+2 ;;3^4473^CAT A FIRST DEPENDENT INCOME
+3 ;;4^1496^CAT A INCOME PER DEPENDENT
+4 ;;8^50000^THRESHOLD PROPERTY
+5 ;;17^7050^CHILD INCOME EXCLUSION
+6 ;;QUIT
