PRCA444P.m

PRCA444P ;MNTVBB/AJR - Update for Annual Interest Rate in File 342 AR SITE PARAMETER ;11/18/24

 ;;4.5;Accounts Receivable;**444**;Mar 20, 1995;Build 4

 ;;Per VA Directive 6402, this routine should not be modified.

 Q

 ;

EN ;ENTRY POINT

 ; Call the Global Backup Tag (Backs up entire file to XTMP and sets the GLBRSTR node

 ; used to prevent a rerun of the backup and update, that would result in

 ; overwriting the backup file unintentionally)

 N GLBKUP

 D GLBBKUP

 I $D(GLBKUP) Q

 ; Initiate Update

 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="3250101" D  Q

 .S DA=X

 .S DIE="^RC(342,"_DA(1)_",4,",DR=".01///3250101;.02///.05;.03///1.51;.04///.06;.05///378.40"

 .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///3250101;.02///.05;.03///1.51;.04///.06;.05///378.40"

 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

 ;

GLBBKUP  ; XTMP Backup of file(s)

 S PRCA444P="PRCA444P-Update for Annual Interest Rate in File 342 AR SITE PARAMETER"

 S ^XTMP("PRCA444P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT

 M ^XTMP("PRCA444P",342,$H)=^RC(342)

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCA444P   1598     printed  Mar 13, 2025@20:43:31                                                                                                                                                                                                    Page 2

PRCA444P  ;MNTVBB/AJR - Update for Annual Interest Rate in File 342 AR SITE PARAMETER ;11/18/24

 +1       ;;4.5;Accounts Receivable;**444**;Mar 20, 1995;Build 4

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

 +4       ;

EN        ;ENTRY POINT

 +1       ; Call the Global Backup Tag (Backs up entire file to XTMP and sets the GLBRSTR node

 +2       ; used to prevent a rerun of the backup and update, that would result in

 +3       ; overwriting the backup file unintentionally)

 +4        NEW GLBKUP

 +5        DO GLBBKUP

 +6        IF $DATA(GLBKUP)

               QUIT 

 +7       ; Initiate Update

 +8        DO PRCANEW

 +9        QUIT 

 +10      ;

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="3250101"

               Begin DoDot:1

 +7                SET DA=X

 +8                SET DIE="^RC(342,"_DA(1)_",4,"

                   SET DR=".01///3250101;.02///.05;.03///1.51;.04///.06;.05///378.40"

 +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///3250101;.02///.05;.03///1.51;.04///.06;.05///378.40"

 +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 

 +3       ;

GLBBKUP   ; XTMP Backup of file(s)

 +1        SET PRCA444P="PRCA444P-Update for Annual Interest Rate in File 342 AR SITE PARAMETER"

 +2        SET ^XTMP("PRCA444P",0)=$$FMADD^XLFDT(DT,120)_"^"_DT

 +3        MERGE ^XTMP("PRCA444P",342,$HOROLOG)=^RC(342)

 +4        QUIT 

 +5       ;