Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFIV11

ACRFIV11.m

Go to the documentation of this file. 
  1. ACRFIV11 ;IHS/OIRM/DSD/THL,AEF - CREATE PAYMENT RECORDS IN 1166 PACKAGE;  [ 05/03/2005  9:55 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,16,17**;JUL 31, 2001
  1.  ;ACR*2.1*16.06 THIS ROUTINE IS REWRITTEN
  1.  ;
  1.  ;CREATE NEW 1166 BATCHES AND SEQUENCE NO. ENTRIES
  1.  ;
  1.  ;CALLED FROM THE TOP BY; ^ACRFIV13 ;^ACRFPRC3 ;^ACRFRR11 ;^ACRFTA
  1.  ;CODES COMMONLY USED: IV - Invoice; VV - Travel voucher; 
  1.  ; ACRTERMS IS SET ONLY WHEN THERE IS A PENALTY OR DISCOUNT
  1.  ; SET IN ROUTINES: ACRFDT, ACRFIV41, ACRFIV42, ACRFIV43
  1.  ; ACRTADD IS SET FOR ACH ADDENDUM
  1.  ;
  1. 1166 ;EP;TO CREATE 1166 RECORD IN 1166 PROGRAM
  1.  F ACR=0:1:125,"A","B","C","D","E" K @("ACR"_ACR)
  1.  ;N ACRA,ACRB,ACRC,ACRD,ACRE,ACRTADD,ACRCANDA,ACROBJDA,ACRINT ;ACR*2.1*17.01 IM17097
  1.  N ACRA,ACRB,ACRC,ACRD,ACRE,ACRTADD,ACRCANDA,ACROBJDA,ACRINT,ACRMSG ;ACR*2.1*17.01 IM17097
  1.  K ACRT
  1.  D 11661
  1. EXIT ;EP;CALLED BY ACRFPAY TO INIT VARIABLES
  1.  K ACR,ACRIVDC,ACRIVPAY,ACRIVDIS,ACRVDA,ACRLBDT,ACREND
  1.  K ACRFYFUN,ACRDOC,ACRDOC2,ACRGTA,ACRINV,ACRDT,ACRDTDA,ACRIP,ACRIVACP
  1.  K ACRIVACT,ACRIVD,ACRIVDAT,ACRIVDIS,ACRIVIT,ACRIVT,ACRIVTF
  1.  K ACRIVTX,ACRIVUP,ACRMAX,ACRLBDA,ACRNOTES,ACRPCNT,ACRPDA,ACRPEN,ACRPODA
  1.  K ACRRCD,ACRRDATE,ACRRRDA,ACRRRDAT,ACRRRDT,ACRSS0,ACRSSACP,ACRSSACT
  1.  K ACRSSDA,ACRSSDSC,ACRSSDT,ACRSSIT,ACRSSMAX,ACRSSNMS,ACRSSNO,ACRSST
  1.  K ACRTCODE,ACRUC,ACRTXDA,ACRTERMS,ACRSSUP,ACRV11,ACRV13,ACRBEG
  1.  F ACR=0:1:125,"A","B","C","D","E","P" K @("ACR"_ACR)
  1.  Q
  1. 11661 ;LOCAL ENTRY;
  1.  ;Q:$P(^ACRSYS(1,"DT1"),U,9)<1  ;FMS SYSTEM DEFAULT says not use;ACR*2.1*17.01 IM17097
  1.  ;Q:'$D(^AFSLAFP(0))#2    ;No data in payment file;ACR*2.1*17.01 IM17097
  1.  ;Q:'$D(ACRIVPAY)            ;Nothing to pay     ;ACR*2.1*17.01 IM17097
  1.  ;D BCHECK^ACRFIV12          ;Returns batch info ;ACR*2.1*17.01 IM17097
  1.  ;Q:$G(ACRBATDA)=""          ;No batch           ;ACR*2.1*17.01 IM17097
  1.  S ACRDOC=$G(ACRDOC)                             ;ACR*2.1*17.01 IM17097
  1.  I $P(^ACRSYS(1,"DT1"),U,9)<1 D  Q               ;ACR*2.1*17.01 IM17097
  1.  .S ACRMSG="FMS SYSTEM DEFAULT file set to **not* use 1166 Approval for Payment"  ; ACR*2.1*17.01 IM17097
  1.  .D FIN(ACRDOC,"",ACRMSG)                      ;ACR*2.1*17.01 IM17097
  1.  I '$D(^AFSLAFP(0))#2 D  Q                     ;ACR*2.1*17.01 IM17097
  1.  .S ACRMSG="FMS SYSTEM DEFAULT file not set up for 1166 Approval for Payments"  ; ACR*2.1*17.01 IM17097
  1.  .D FIN(ACRDOC,"",ACRMSG)                      ;ACR*2.1*17.01 IM17097
  1.  I '$D(ACRIVPAY) D  Q                          ;ACR*2.1*17.01 IM17097
  1.  .S ACRMSG="No payments for this document"     ;ACR*2.1*17.01 IM17097
  1.  .D FIN(ACRDOC,"",ACRMSG)                      ;ACR*2.1*17.01 IM17097
  1.  ;
  1.  D BCHECK^ACRFIV12
  1.  ;
  1. N1166 ;EP;      NON-ARMS/AIRLINE ENTRY POINT        ;ACR*2.1*17.01 IM17097
  1.  I $G(ACRBATDA)="" D  Q                        ;ACR*2.1*17.01 IM17097
  1.  .S ACRMSG="Batch entry not created "          ;ACR*2.1*17.01 IM17097
  1.  .D FIN($G(ACRDOC),ACRBATDA,ACRMSG)            ;ACR*2.1*17.01 IM17097
  1.  ;
  1.  S ACRCANDA=0
  1.  F  S ACRCANDA=$O(ACRIVPAY(ACRCANDA)) Q:'ACRCANDA  D
  1.  .S ACROBJDA=0
  1.  .F  S ACROBJDA=$O(ACRIVPAY(ACRCANDA,ACROBJDA)) Q:'ACROBJDA  D
  1.  ..;I ACROBJDA=$P($G(^ACRSYS(1,400)),U,2),'$P($G(^ACRSYS(1,400)),U,4) Q  ;TRAVEL MGT FEE PMT  ; ACR*2.1*17.01 IM17097
  1.  ..I ACRBTYP="T",ACROBJDA=$P($G(^ACRSYS(1,400)),U,2),'$P($G(^ACRSYS(1,400)),U,4) Q  ;NO TRAVEL MGT FEE PMT ON VOUCHERS  ; ACR*2.1*17.01 IM17097
  1.  ..S ACRIVTF=ACRIVPAY(ACRCANDA,ACROBJDA)
  1.  ..I $D(ACRIVDIS(ACRCANDA,ACROBJDA,"D")) D
  1.  ...S ACRIVTF=ACRIVDIS(ACRCANDA,ACROBJDA)
  1.  ...S ACRIVDC=ACRIVDIS(ACRCANDA,ACROBJDA,"D")
  1.  ..S ACRINT=$G(ACRIVDIS(ACRCANDA,ACROBJDA,"P"))   ; Possible interest
  1.  ..Q:ACRIVTF'>0
  1.  ..D S11661
  1.  ..I $P(ACRTERMS,U,14)]"" D MORE(ACROBJDA)   ;Check for penalty/discount
  1.  ;
  1.  ;D FIN(ACRDOC,ACRBATNO)                     ;ACR*2.1*17.01 IM17097
  1.  D FIN(ACRDOC,ACRBATNO,.ACRMSG)              ;ACR*2.1*17.01 IM17097
  1.  Q
  1. S11661 ;----- PUT PAYMENT IN BATCH 
  1.  ;
  1.  S ACRSEQNO=$$NEWSEQ(ACRFYDA,ACRBATDA,.ACRDOCDA)
  1.  ;Q:ACRSEQNO=""                              ;ACR*2.1*17.01 IM17097
  1.  I ACRSEQNO="" D  Q                          ;ACR*2.1*17.01 IM17097
  1.  .S ACRMSG="No Sequence Number for Batch "_ACRBATNO  ;ACR*2.1*17.01 IM17097
  1.  .D FIN($G(ACRDOC),ACRBATNO,ACRMSG)          ;ACR*2.1*17.01 IM17097
  1.  S ACRSEQDA=+ACRSEQNO
  1.  ;
  1.  D EN^ACRFIV13(.ACRA,.ACRB,.ACRC,.ACRD,.ACRE)  ;Retrieve variables
  1.  ;
  1.  D SET(ACRA,ACRB,ACRC,ACRD,ACRE)          ;Set AFSLAFP & open doc file
  1.  ;
  1.  D PAY                                    ;Set ACRPAY file
  1.  Q
  1. MORE(ACROLDOB) ;Now look for needed extra sets for discount or penalties
  1.  N ACRX,ACRX2,ACROBJ,ACRTCODE,ACRP,ACROBJDA,ACRIVP,ACRIVPT
  1.  S ACRP=$P(ACRTERMS,U,2)                ;Amount
  1.  I +ACRP'>0 S ACRTERMS="" Q
  1.  S ACRTCODE=$P(ACRTERMS,U,8)            ;Tran code for penalty/discount 
  1.  S ACROBJ=$P(ACRTERMS,U,13)
  1.  S ACRT=$P(ACRTERMS,U,14)               ;Type penalty/discount
  1.  S ACROBJDA=$$OBJDA^ACRFUTL1(ACROBJ)
  1.  I ACROBJDA="" S ACROBJDA=ACROLDOB
  1.  S ACRIVP=$S(ACRT=-2:"Discount Lost",ACRT=-1:"Interest Penalty",1:"Discount Taken")
  1.  S ACRIVPT=$S(ACRT=-2:2,ACRT=-1:3,1:1)
  1.  ;
  1.  I ACRIVP["Taken" D  Q                   ;Discount node of ACRDOC file
  1.  .D UPDIS
  1.  .D SS(ACRIVP,ACRP,ACROBJDA)             ;Set FMS SUPPLIES AND SERVICES
  1.  .D DP(ACRP,ACRIVPT,ACRSEQNO)
  1.  ;
  1.  ;  GET NEW SEQUENCE, ACH ADDENDUM, SET INTO FILES
  1.  D SS(ACRIVP,ACRP,ACROBJDA)              ;Set FMS SUPPLIES AND SERVICES
  1.  D SETACH(ACRCANDA,ACROBJDA,ACRTCODE,ACRP,.ACRSEQNO)
  1.  D DP(ACRP,ACRIVPT,ACRSEQNO)
  1.  ;
  1.  Q
  1.  ;FIN(ACRDOC,ACRBATNO)         ;OLD SUB-ROUTINE; CLOSING MESSAGE  ; ACR*2.1*17.01 IM17097
  1.  ;W !!,"Document No. ",ACRDOC
  1.  ;W !,"Has been placed in Batch No. ",ACRBATNO
  1.  ;D PAUSE^ACRFWARN
  1.  ;Q
  1. FIN(ACRDOC,ACRBATNO,ACRMSG) ; CLOSING MESSAGE  ;NEW SUB-ROUTINE ACR*2.1*17.01 IM17097
  1.  W !!,"Document No. ",ACRDOC
  1.  I $D(ACRMSG) W !,ACRMSG K ACRT S ACRQUIT=""
  1.  I $G(ACRBATNO)]"" D
  1.  .W !,"Has been placed in Batch No. ",ACRBATNO
  1.  I $G(ACRBATNO)']"" D
  1.  .W !,"Has **not** been placed in Batch "
  1.  D PAUSE^ACRFWARN
  1.  Q
  1.  ;
  1. SETACH(ACRCANDA,ACROBJDA,ACRTCODE,ACRP,ACRSEQNO) ;LOCAL ENTRY
  1.  ;CREATE ADDITIONAL ENTRY FOR INTEREST PENALTY PAYMENT
  1.  S ACRIVTF=0
  1.  S ACRSEQNO=$$NEWSEQ(ACRFYDA,ACRBATDA,ACRDOCDA)
  1.  Q:ACRSEQNO=""                                  ;No sequence in AFSLAFP
  1.  S ACRX=$$EN^ACRFACH(ACRDOCDA,ACRDOC,.ACRTERMS,ACRTCODE,ACRREF)
  1.  S ACRSEQDA=+ACRSEQNO
  1.  S ACRP=$$17^ACRFIV13(ACRP)
  1.  S $P(ACRA,U)=ACRSEQNO                          ;Replace SEQ NO
  1.  S $P(ACRA,U,8)=ACROBJDA
  1.  S $P(ACRA,U,11)=ACRP                           ;Set payment amount
  1.  S $P(ACRA,U,18)=ACRTCODE                       ;Replace trans code
  1.  S $P(ACRB,U,6)=ACRP                            ;Set to interest amt
  1.  S $P(ACRC,U,2)=ACRX                            ;Reset ACH Addendum
  1.  S $P(ACRE,U,2)=ACRP
  1.  D PAY:$G(ACRDOCDA)                             ;Set ACRPAY
  1.  D SET(ACRA,ACRB,ACRC,ACRD,ACRE)                ;Set AFSLAFP
  1.  S ACRTERMS=""                                  ;ONLY PROCESS ONCE
  1.  Q
  1.  ;
  1. NEWSEQ(ACRFYDA,ACRBATDA,ACRDOCDA) ;LOCAL ENTRY 
  1.  ;ADD NEW SEQUENCE ENTRY TO BATCH
  1.  S ACRSEQNO=""
  1.  D SEQNO^ACRFIV12(ACRFYDA,ACRBATDA,.ACRSEQNO)
  1.  I $G(ACRSEQNO)="" Q ACRSEQNO
  1.  S X=ACRSEQNO
  1.  S DA(2)=ACRFYDA
  1.  S DA(1)=ACRBATDA
  1.  S DIC="^AFSLAFP("_ACRFYDA_",1,"_ACRBATDA_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")="2////"_DUZ
  1.  S:$G(ACRDOCDA) DIC("DR")=DIC("DR")_";.02////"_ACRDOCDA
  1.  I '$D(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,0)) D
  1.  .S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,0)="^9002325.02"
  1.  D FILE^ACRFDIC
  1.  I Y<1 S ACRSEQNO=""
  1.  Q ACRSEQNO
  1.  ;
  1. SET(ACRA,ACRB,ACRC,ACRD,ACRE)                           ;LOCAL ENTRY TO SET FILE
  1.  S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0)=ACRA
  1.  S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,1)=ACRB
  1.  S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,2)=ACRC
  1.  S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,3)=ACRD
  1.  S ^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,100)=ACRE
  1.  K ACRBEG,ACREND
  1.  S ACRDT=ACRA
  1.  S DA(2)=ACRFYDA
  1.  S DA(1)=ACRBATDA
  1.  S DA=ACRSEQDA
  1.  S DIK="^AFSLAFP("_DA(2)_",1,"_DA(1)_",1,"
  1.  D IX1^ACRFDIC
  1.  ;
  1.  ;UPDATE THE OPEN DOCUMENT RECORD
  1.  I '$D(ACRFY)#2 S ACRFY=$P(^AFSLAFP(ACRFYDA,0),U)
  1.  D ODOC
  1.  Q
  1.  ;
  1. PAY ;LOCAL ENTRY; CREATE ENTRY IN ARMS APPROVALS FOR PAYMENT FILE
  1.  S X=$S($G(ACRPAYDA):ACRPAYDA,1:DT)
  1.  S DIC="^ACRPAY("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_$G(ACRDOCDA)
  1.  S DIC("DR")=DIC("DR")_";.05////"_DUZ
  1.  S DIC("DR")=DIC("DR")_";.06////"_DT
  1.  S DIC("DR")=DIC("DR")_";50////"_$G(ACR50)
  1.  S DIC("DR")=DIC("DR")_";51////"_$G(ACR51)
  1.  D FILE^ACRFDIC
  1.  Q:+Y<1
  1.  S (DA,ACRPDA)=+Y
  1.  S ^ACRPAY(+Y,"DT")=$P(ACRDT,U,1,25)_U_U_U_$P(ACRDT,U,28)
  1.  S ^ACRPAY(+Y,1)=ACRB
  1.  S ^ACRPAY(+Y,2)=ACRC
  1.  S ^ACRPAY(+Y,3)=ACRD
  1.  S DIK="^ACRPAY("
  1.  D IX1^ACRFDIC
  1.  Q
  1.  ;
  1. DP(ACRTMP2,ACRTMP3,ACRSEQNO) ;LOCAL ENTRY
  1.  ; CREATE ENTRY IN FMS PAYMENT DISCOUNT/PENALTIES FILE
  1.  ; ENTERS WITH ACRTMP2=AMOUNT OF DISCOUNT, DISCOUNT LOST, INTEREST
  1.  ;             ACRTMP3  1= DISCOUNT TAKEN
  1.  ;                      2= DISCOUNT LOST
  1.  ;                      3= INTEREST PENALTY
  1.  S X=ACRSEQNO
  1.  S DIC="^ACRDP("
  1.  S DIC(0)="L"
  1.  S ACRTMP=".02////"_$G(ACRDOCDA)
  1.  S ACRTMP=ACRTMP_";.03////"_ACRPDA
  1.  S ACRTMP=ACRTMP_";.04////"_$G(ACRPAYDA)
  1.  S ACRTMP=ACRTMP_";.05////"_DUZ
  1.  S ACRTMP=ACRTMP_";1////"_ACRTMP3
  1.  S ACRTMP=ACRTMP_";2////"_ACRTMP2
  1.  S DIC("DR")=ACRTMP
  1.  D FILE^ACRFDIC
  1.  Q
  1.  ;
  1. ODOC ;LOCAL ENTRY; UPDATE OPEN DOCUMENT RECORD
  1.  N ACRDOCX
  1.  S ACRDFYDA=$O(^AFSLODOC("B",ACRFYFUN,0))
  1.  Q:'ACRDFYDA
  1.  S X=+ACRSEQNO
  1.  S DA(2)=ACRDFYDA
  1.  S ACRDOCX=$E("0000000000",1,10-$L(ACRDOC))_ACRDOC
  1.  S DA(1)=$$GETODOC(ACRDOCX)
  1.  Q:'DA(1)
  1.  S ACRODDA=DA(1)
  1.  ;I '$D(^AFSLODOC(DA(1),1,DA(1),1,0)) D            ;ACR*2.1*3.04
  1.  I '$D(^AFSLODOC(DA(2),1,DA(1),1,0)) D             ;ACR*2.1*3.04
  1.  .S ^AFSLODOC(DA(2),1,DA(1),1,0)="^9002325.3111A"  ;ACR*2.1*3.04
  1.  S DIC="^AFSLODOC("_DA(2)_",1,"_DA(1)_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".05////"_ACRBATNO
  1.  S DIC("DR")=DIC("DR")_";1////"_ACRPAYDA
  1.  S DIC("DR")=DIC("DR")_";2////"_$$DOL^ACRFUTL(ACRIVTF)
  1.  S DIC("DR")=DIC("DR")_";3////"_ACR58
  1.  S DIC("DR")=DIC("DR")_";5////"_$G(ACRPDFOR)
  1.  S DIC("DR")=DIC("DR")_";6////A"
  1.  S DIC("DR")=DIC("DR")_";8////"_ACRSEQNO
  1.  D FILE^ACRFDIC
  1.  ;I +Y>0 D UPDT(+Y,ACRFYDA,ACRODDA,ACRTCODE,ACR17) ;OPEN DOCUMENT INTERFACE  ;ACR*2.1*3.04
  1.  I +Y>0 D UPDT(+Y,ACRDFYDA,ACRODDA,ACRTCODE,ACR17) ;OPEN DOCUMENT INTERFACE  ;ACR*2.1*3.04
  1.  Q
  1.  ;
  1. UPDT(Y,ACRFYDA,ACRODDA,ACRTCODE,ACR17) ;
  1.  ;----- UPDATE OPEN DOCUMENT DATABASE
  1.  ;
  1.  N DA,DIE,DR,X
  1.  S DA(1)=ACRFYDA
  1.  S DA=ACRODDA
  1.  S DIE="^AFSLODOC("_DA(1)_",1,"
  1.  S DR="17////"_DT_";18////"_$G(ACRTCODE)_";19////"_$$DOL^ACRFUTL($G(ACR17))
  1.  D ^DIE
  1.  D BAL^ACRFODOC(ACRFYDA,ACRODDA)
  1.  Q
  1.  ;
  1. GETODOC(D) ;LOCAL ENTRY
  1.  N X,Y,Z
  1.  S X=0
  1.  F  S X=$O(^AFSLODOC(ACRDFYDA,1,"B",D,X)) Q:'X  S Y=X
  1.  K D
  1.  Q $G(Y)
  1.  ;
  1. SS(ACRX,ACRY,ACROBJDA) ;LOCAL ENTRY; ENTER INTEREST PAYMENT INTO FMS SUPPLIES & SERVICES
  1.  ;  ENTERS WITH ACRX = KEY WORD = "INTEREST PAYMENT"
  1.  ;                           OR = "DISCOUNT TAKEN"
  1.  ;                           OR = "DISCOUNT LOST"
  1.  ;              ACRY = AMOUNT
  1.  ;             ACROBJDA = OBJECT CLASS CODE IEN
  1.  Q:$G(ACRDOCDA)=""
  1.  S X=1
  1.  S DIC="^ACRSS("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_ACRDOCDA
  1.  S DIC("DR")=DIC("DR")_";.03////"_ACRDOCDA
  1.  S DIC("DR")=DIC("DR")_";.04////"_ACROBJDA
  1.  S DIC("DR")=DIC("DR")_";.05////"_ACRCANDA
  1.  S DIC("DR")=DIC("DR")_";.06////"_ACRLBDA
  1.  S DIC("DR")=DIC("DR")_";.07////"_ACRDOCDA
  1.  S DIC("DR")=DIC("DR")_";.1///617"
  1.  S DIC("DR")=DIC("DR")_";.2////"_ACRDOCDA
  1.  S DIC("DR")=DIC("DR")_";5////"_ACRX            ;KEY WORD
  1.  S DIC("DR")=DIC("DR")_";10////1"
  1.  S DIC("DR")=DIC("DR")_";11///EA"
  1.  S DIC("DR")=DIC("DR")_";12////"_ACRY
  1.  S DIC("DR")=DIC("DR")_";13////"_ACRY
  1.  S DIC("DR")=DIC("DR")_";14////1"
  1.  S DIC("DR")=DIC("DR")_";15////1"
  1.  S DIC("DR")=DIC("DR")_";16////"_ACRY
  1.  S DIC("DR")=DIC("DR")_";16.1////"_ACRY
  1.  D FILE^ACRFDIC
  1.  Q
  1.  ;
  1. UPDIS ;LOCAL ENTRY; CREATE ENTRY IN FMS DOCUMENT FILE AT ,70 NODE (DISCOUNT)
  1.  Q:ACRDOCDA'>0
  1.  N ACRTMP,DA,ACRPCENT,ACRAMT,ACRRRNUM
  1.  S DA(1)=ACRDOCDA
  1.  S (DIE,DIC)="^ACRDOC("_DA(1)_",70,"
  1.  S DIC("P")=$P(^DD(9002196,70,0),U,2)
  1.  S DIC(0)="L"
  1.  S X=+ACRTERMS
  1.  D FILE^ACRFDIC
  1.  Q:Y=-1
  1.  S ACRPCENT=$P(ACRTERMS,U,3)
  1.  S ACRAMT=$P(ACRTERMS,U,2)
  1.  S ACRRRNUM=$P($G(ACRRR0),U,4)
  1.  S DA=+Y
  1.  S ACRTMP=".02////"_ACRPCENT
  1.  S ACRTMP=ACRTMP_";.03////1"               ;HARDCODED 1=APPLIED DISCOUNT
  1.  S ACRTMP=ACRTMP_";.04////"_ACRRRNUM       ;RECEIVING REPORT NUMBER
  1.  S ACRTMP=ACRTMP_";.05////"_ACRAMT
  1.  S DR=ACRTMP
  1.  D DIE^ACRFDIC
  1.  Q