PRCAP383 ;EDE/YMG - PRCA*4.5*383 PRE-INSTALL; 08/12/21
;;4.5;Accounts Receivable;**383**;Mar 20, 1995;Build 5
;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ; entry point
D BMES^XPDUTL(" >> Start of the Pre-Installation routine for PRCA*4.5*383")
; update interest / administrative rates
D UPDRT
D BMES^XPDUTL(" >> End of the Pre-Installation routine for PRCA*4.5*383")
Q
;
UPDRT ; update interest / admin. rates in AR site parameters
N DATA,FDA,IEN,IENS,LN,RATES,TMPDT,TMPDT1
D MES^XPDUTL("Updating interest / admin. rates...")
; load rates from the table
F LN=1:1 S DATA=$T(RTBL+LN) Q:$P(DATA,";",3)="END" S RATES($P(DATA,";",3))=$P(DATA,";",4)_U_$P(DATA,";",5)
; loop through sub-file 342.04
L +^RC(342,1):2 I '$T D MES^XPDUTL(" Unable to establish lock on file 342 - exiting.") Q
S TMPDT=0 F S TMPDT=$O(^RC(342,1,4,"B",TMPDT)) Q:'TMPDT D
.S IEN=0 F S IEN=$O(^RC(342,1,4,"B",TMPDT,IEN)) Q:'IEN D
..S IENS=IEN_",1,"
..S TMPDT1=$S('$D(RATES(TMPDT)):$O(RATES(TMPDT),-1),1:TMPDT) Q:'TMPDT1
..; update rates
..S FDA(342.04,IENS,.02)=$P(RATES(TMPDT1),U) ; int. rate
..S FDA(342.04,IENS,.03)=$P(RATES(TMPDT1),U,2) ; adm. rate
..D FILE^DIE("","FDA") K FDA
..Q
.Q
L -^RC(342,1)
D MES^XPDUTL(" Done.")
Q
;
RTBL ; Rates table (effective date;interest rate;admin. rate)
;;2860101;.09;.63
;;2870101;.07;.70
;;2890101;.07;.99
;;2900101;.09;.98
;;2910101;.09;.91
;;2920101;.06;1.16
;;2930101;.04;1.33
;;2940101;.03;.60
;;2980101;.05;.45
;;3000101;.05;.50
;;3010101;.06;.50
;;3020101;.05;.50
;;3020701;.03;.50
;;3030101;.02;.50
;;3040101;.01;1.50
;;3050101;.01;1.55
;;3060101;.02;1.60
;;3060701;.04;1.60
;;3070101;.04;1.65
;;3080101;.05;1.70
;;3080701;.03;1.70
;;3090101;.03;1.76
;;3100101;.01;1.83
;;3110101;.01;1.87
;;3120101;.01;1.87
;;3130101;.01;1.87
;;3140101;.01;1.87
;;3150101;.01;1.87
;;3160101;.01;1.87
;;3170101;.01;1.90
;;3180101;.01;1.93
;;3190101;.01;1.94
;;3200101;.02;1.64
;;3210101;.01;1.52
;;END
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAP383 2071 printed Sep 23, 2025@19:16:51 Page 2
PRCAP383 ;EDE/YMG - PRCA*4.5*383 PRE-INSTALL; 08/12/21
+1 ;;4.5;Accounts Receivable;**383**;Mar 20, 1995;Build 5
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ; entry point
+1 DO BMES^XPDUTL(" >> Start of the Pre-Installation routine for PRCA*4.5*383")
+2 ; update interest / administrative rates
+3 DO UPDRT
+4 DO BMES^XPDUTL(" >> End of the Pre-Installation routine for PRCA*4.5*383")
+5 QUIT
+6 ;
UPDRT ; update interest / admin. rates in AR site parameters
+1 NEW DATA,FDA,IEN,IENS,LN,RATES,TMPDT,TMPDT1
+2 DO MES^XPDUTL("Updating interest / admin. rates...")
+3 ; load rates from the table
+4 FOR LN=1:1
SET DATA=$TEXT(RTBL+LN)
if $PIECE(DATA,";",3)="END"
QUIT
SET RATES($PIECE(DATA,";",3))=$PIECE(DATA,";",4)_U_$PIECE(DATA,";",5)
+5 ; loop through sub-file 342.04
+6 LOCK +^RC(342,1):2
IF '$TEST
DO MES^XPDUTL(" Unable to establish lock on file 342 - exiting.")
QUIT
+7 SET TMPDT=0
FOR
SET TMPDT=$ORDER(^RC(342,1,4,"B",TMPDT))
if 'TMPDT
QUIT
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^RC(342,1,4,"B",TMPDT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+9 SET IENS=IEN_",1,"
+10 SET TMPDT1=$SELECT('$DATA(RATES(TMPDT)):$ORDER(RATES(TMPDT),-1),1:TMPDT)
if 'TMPDT1
QUIT
+11 ; update rates
+12 ; int. rate
SET FDA(342.04,IENS,.02)=$PIECE(RATES(TMPDT1),U)
+13 ; adm. rate
SET FDA(342.04,IENS,.03)=$PIECE(RATES(TMPDT1),U,2)
+14 DO FILE^DIE("","FDA")
KILL FDA
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 LOCK -^RC(342,1)
+18 DO MES^XPDUTL(" Done.")
+19 QUIT
+20 ;
RTBL ; Rates table (effective date;interest rate;admin. rate)
+1 ;;2860101;.09;.63
+2 ;;2870101;.07;.70
+3 ;;2890101;.07;.99
+4 ;;2900101;.09;.98
+5 ;;2910101;.09;.91
+6 ;;2920101;.06;1.16
+7 ;;2930101;.04;1.33
+8 ;;2940101;.03;.60
+9 ;;2980101;.05;.45
+10 ;;3000101;.05;.50
+11 ;;3010101;.06;.50
+12 ;;3020101;.05;.50
+13 ;;3020701;.03;.50
+14 ;;3030101;.02;.50
+15 ;;3040101;.01;1.50
+16 ;;3050101;.01;1.55
+17 ;;3060101;.02;1.60
+18 ;;3060701;.04;1.60
+19 ;;3070101;.04;1.65
+20 ;;3080101;.05;1.70
+21 ;;3080701;.03;1.70
+22 ;;3090101;.03;1.76
+23 ;;3100101;.01;1.83
+24 ;;3110101;.01;1.87
+25 ;;3120101;.01;1.87
+26 ;;3130101;.01;1.87
+27 ;;3140101;.01;1.87
+28 ;;3150101;.01;1.87
+29 ;;3160101;.01;1.87
+30 ;;3170101;.01;1.90
+31 ;;3180101;.01;1.93
+32 ;;3190101;.01;1.94
+33 ;;3200101;.02;1.64
+34 ;;3210101;.01;1.52
+35 ;;END
+36 QUIT
