PRCA434P ;MNTVBB/RFS - Update for Annual Interest Rate in File 342 AR SITE PARAMETER ;01/18/24
;;4.5;Accounts Receivable;**434**;Mar 20, 1995;Build 4
;;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ;ENTRY POINT
D PRCANEW
Q
PRCANEW ;Add new rates in File 342 AR SITE PARAMETER
N X,Y,PRCAEFF
D BMES^XPDUTL("** Updating AR SITE PARAMETER (#342) file **")
S DA(1)=0 S DA(1)=$O(^RC(342,DA(1)))
S X=999999 S X=$O(^RC(342,DA(1),4,X),-1)
S PRCAEFF=$P($G(^RC(342,DA(1),4,X,0)),U)
I PRCAEFF="3240101" D Q
.S DA=X
.S DIE="^RC(342,"_DA(1)_",4,",DR=".01///3240101;.02///.04;.03///1.43;.04///.06;.05///368.81"
.D ^DIE
.K DIE,DR,DA,DA(1)
.D BMES^XPDUTL("** Done **")
.Q
S X=X+1
K DO
S DIC="^RC(342,"_DA(1)_",4,",DIC(0)="L",DIC("DR")=".01///3240101;.02///.04;.03///1.43;.04///.06;.05///368.81"
D FILE^DICN I Y=-1 D PRCAERR Q
K DA(1),DIC
D BMES^XPDUTL("** Done **") Q
PRCAERR ;Message to the user that an error occurred.
D BMES^XPDUTL("*** AN ERROR OCCURRED WHEN ATTEMPTING TO ADD NEW FILE ENTRIES. PLEASE CONTACT PRODUCT SUPPORT ***")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA434P 1099 printed Dec 13, 2024@01:38:50 Page 2
PRCA434P ;MNTVBB/RFS - Update for Annual Interest Rate in File 342 AR SITE PARAMETER ;01/18/24
+1 ;;4.5;Accounts Receivable;**434**;Mar 20, 1995;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ;ENTRY POINT
+1 DO PRCANEW
+2 QUIT
PRCANEW ;Add new rates in File 342 AR SITE PARAMETER
+1 NEW X,Y,PRCAEFF
+2 DO BMES^XPDUTL("** Updating AR SITE PARAMETER (#342) file **")
+3 SET DA(1)=0
SET DA(1)=$ORDER(^RC(342,DA(1)))
+4 SET X=999999
SET X=$ORDER(^RC(342,DA(1),4,X),-1)
+5 SET PRCAEFF=$PIECE($GET(^RC(342,DA(1),4,X,0)),U)
+6 IF PRCAEFF="3240101"
Begin DoDot:1
+7 SET DA=X
+8 SET DIE="^RC(342,"_DA(1)_",4,"
SET DR=".01///3240101;.02///.04;.03///1.43;.04///.06;.05///368.81"
+9 DO ^DIE
+10 KILL DIE,DR,DA,DA(1)
+11 DO BMES^XPDUTL("** Done **")
+12 QUIT
End DoDot:1
QUIT
+13 SET X=X+1
+14 KILL DO
+15 SET DIC="^RC(342,"_DA(1)_",4,"
SET DIC(0)="L"
SET DIC("DR")=".01///3240101;.02///.04;.03///1.43;.04///.06;.05///368.81"
+16 DO FILE^DICN
IF Y=-1
DO PRCAERR
QUIT
+17 KILL DA(1),DIC
+18 DO BMES^XPDUTL("** Done **")
QUIT
PRCAERR ;Message to the user that an error occurred.
+1 DO BMES^XPDUTL("*** AN ERROR OCCURRED WHEN ATTEMPTING TO ADD NEW FILE ENTRIES. PLEASE CONTACT PRODUCT SUPPORT ***")
+2 QUIT
