PRCA434P.m

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 ---PRCA434P   1099     printed  Apr 09, 2024@20:46:10                                                                                                                                                                                                    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