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 ---[H[J[2J[HPRCA444P 1598 printed Sep 23, 2025@19:14:50 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 ;
