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

ACRFPPR.m

Go to the documentation of this file. 
  1. ACRFPPR ;IHS/OIRM/DSD/THL,AEF - PROMPT PAYMENT REPORT;  [ 10/27/2004   4:18 PM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
  1.  ;;
  1. EN D EXIT
  1.  D PPR
  1. EXIT K ACR,ACRQUIT,ACROUT,ACRFYDA,ACRBATDA,ACRSEQDA,ACRBEGIN,ACREND,ACRDATE,ACRFY,ACRIA,ACRIB,ACRIIA,ACRIIB,ACRIIC,ACRIIC1,ACRIIC2,ACRIIC3,ACRIIC4,ACROBJDA,ACRRTN,ACRIID,ACRIIE1,ACRIIE2,ACRIIF1,ACRIIF2,ACRIIF3,ACRIIIA,ACRIIIB,ACRIIIC
  1.  K ACRIVA,ACRIVB,ACRVA,ACRVB,ACRVC,ACRVE1,ACRVE2,ACRVF,ACRVG,ACRIVA1,ACRIVA2,ACRIVB1,ACRIVB2,ACRNIIB
  1.  Q
  1. PPR ;EP;TO SETUP PRINT OF THE PROMPT PAYMENT REPORT
  1.  D EXIT
  1.  K ACRQUIT,ACROUT
  1.  N ACRFYDA,ACRQT,ACRDC
  1.  S DIC="^AFSLAFP("
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Fiscal Year: "
  1.  S DIC("B")=$E(DT,1,3)+1700
  1.  S DIC("S")="I $P(^(0),U)=X"
  1.  W !
  1.  D DIC^ACRFDIC
  1.  Q:Y<1
  1.  S ACRFYDA=+Y
  1.  S ACRFY=$P(^AFSLAFP(+Y,0),U)
  1.  S DIR(0)="SO^1:First Quarter;2:Second Quarter;3:Third Quarter;4:Fourth Quarter;5:Fiscal Year"
  1.  S DIR("A")="Which Quarter"
  1.  D DIR^ACRFDIC
  1.  Q:'Y
  1.  S ACRQT=Y
  1.  S ACRBEGIN=$$FYBEG^ACRFPPR(ACRFY,ACRQT)   ; ACR*2.1*13.03 IM11657
  1.  S ACREND=$$FYEND^ACRFPPR(ACRFY,ACRQT)     ; ACR*2.1*13.03 IM11657
  1.  S (ZTRTN,ACRRTN)="PPR1^ACRFPPR"
  1.  S ZTDESC="Prompt Payment Report"
  1.  D ZIS
  1.  Q
  1. PPR1 ;EP;TO PRINT PROMPT PAYMENT REPORT
  1.  D GATHER^ACRFPPR1
  1.  K ACRDC
  1.  D PPRH
  1.  W !!,"For ",$S(ACRQT'=5:"Quarter",1:"Fiscal Year")," ending: "
  1.  W:ACRQT=1 "December 31, "
  1.  W:ACRQT=2 "March 31, "
  1.  W:ACRQT=3 "June 31, "
  1.  W:ACRQT>3 "September 30, "
  1.  W $E(ACREND,1,3)+1700
  1.  W !!!,"I.  Invoices paid subject to the Prompt Payment Act and OMB Circular A-125:"
  1.  W !!?4,"A.  Dollar value of invoices",?50,$J($FN($G(ACRIA),"P,",2),14)
  1.  W !?4,"B.  Number of invoices",?50,$J($G(ACRIB),10)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !!!,"II.  Invoices paid after the due date:"
  1.  W !!?4,"A.  Dollar value of invoices",?50,$J($FN($G(ACRIIA),"P,",2),14)
  1.  W !?4,"B.  Number of invoices (sum C.2 and F.1.b)",?50,$J($G(ACRNIIB),10)
  1.  W !!?4,"C.  Late Payment interest penalties paid:"
  1.  W !!?9,"1.  Dollar amount",?50,$J($FN($G(ACRIIC1),"P,",2),14)
  1.  W !?9,"2.  Number",?50,$J($G(ACRIIC2),10)
  1.  W !?9,"3.  Relative Frequency (II.C.2/IB)"
  1.  W:$G(ACRIB) ?52,$J($FN($G(ACRIIC2)/ACRIB,"P",4),14)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !?9,"4.  Frequency distribution of late payment interest penalties paid"
  1.  W !?9,"    this year (as reported on line 1 and 2 of this seciton)."
  1.  W !!?40,"Number of",?55,"Dollars"
  1.  W !?4,"Amount of Penalty",?40,"Payments",?55,"Paid"
  1.  W !!?4,"$   1.00 - $  25.00",?40,$J($G(ACRIIC4(1)),5),?55,$J($FN($G(ACRIIC4(11)),"P,",2),10)
  1.  W !!?4,"$  25.01 - $ 500.00",?40,$J($G(ACRIIC4(2)),5),?55,$J($FN($G(ACRIIC4(22)),"P,",2),10)
  1.  W !!?4,"$ 500.01 - $1000.00",?40,$J($G(ACRIIC4(3)),5),?55,$J($FN($G(ACRIIC4(33)),"P,",2),10)
  1.  W !!?4,"$1000.01 - $2500.00",?40,$J($G(ACRIIC4(4)),5),?55,$J($FN($G(ACRIIC4(44)),"P,",2),10)
  1.  W !!?4,"$2500.01 - $3000.00",?40,$J($G(ACRIIC4(5)),5),?55,$J($FN($G(ACRIIC4(55)),"P,",2),10)
  1.  W !!?4,"$3000.01 - plus",?40,$J($G(ACRIIC4(6)),5),?55,$J($FN($G(ACRIIC4(66)),"P,",2),10)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  D PPRH
  1.  W !!?4,"D.  Additional penalties paid for failure to pay interest penalties:"
  1.  W !!?9,"1.  Dollar amount",?50,$J($FN($G(ACRIID(1)),"P,",2),14)
  1.  W !?9,"2.  Number",?50,$J($G(ACRIID(2)),10)
  1.  W !?9,"3.  Relative Frequency"
  1.  W:$G(ACRIB) ?52,$J($FN($G(ACRIID(2))/ACRIB,"P,",4),14)
  1.  W !?9,"4.  Number of minimum penalties",?50,$J($G(ACRIID(4)),14)
  1.  W !?9,"5.  Number of maximum penalties",?50,$J($G(ACRIID(5)),14)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !!?4,"E.  Reasons why interest of other late payment penalties were incurred."
  1.  W !?4,"    RANK from highest to lowest, according to frequency of occurences."
  1.  W !!?9,"1.  Delay in paying offices' receipt of:"
  1.  W !!?14,"a.  Receiving Report",?45,"( ",$J($G(ACRIIE1(1)),5)," )",?60,"( ",$J($G(ACRIIE1(11)),5)," )"
  1.  W !?14,"b.  Proper invoice",?45,"( ",$J($G(ACRIIE1(2)),5)," )",?60,"( ",$J($G(ACRIIE1(22)),5)," )"
  1.  W !?14,"c.  Purchase order or contract",?45,"( ",$J($G(ACRIIE1(3)),5)," )",?60,"( ",$J($G(ACRIIE1(33)),5)," )"
  1.  W !!?9,"2.  Delay or error by paying office in:"
  1.  W !!?14,"a.  Taking discount",?45,"( ",$J($G(ACRIIE2(1)),5)," )",?60,"( ",$J($G(ACRIIE2(11)),5)," )"
  1.  W !?14,"b.  Notifying vendor of",?45,"( ",$J($G(ACRIIE2(2)),5)," )",?60,"( ",$J($G(ACRIIE2(22)),5)," )"
  1.  W !?14,"    defective invoice"
  1.  W !?14,"c.  Computer or other",?45,"( ",$J($G(ACRIIE2(3)),5)," )",?60,"( ",$J($G(ACRIIE2(33)),5)," )"
  1.  W !?14,"    system processing"
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !!?4,"F.  Interest and other late payment penalties which were due but not paid:"
  1.  W !?4,"    (use interest rate in effect on the date the obligation accrues)"
  1.  W !!?9,"1.  Total:"
  1.  W !!?14,"a.  Interest dollars",?45,"( ",$J($FN($G(ACRIIF1(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF1(11)),"P",2),10)," )"
  1.  W !?14,"b.  Number",?45,"( ",$J($G(ACRIIF1(2)),10)," )",?60,"( ",$J($G(ACRIIF1(2)),10)," )"
  1.  W !!?9,"2.  Because payments were less than $1.00"
  1.  W !!?14,"a.  Interest dollars",?45,"( ",$J($FN($G(ACRIIF2(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF2(11)),"P",2),10)," )"
  1.  W !?14,"b.  Number",?45,"( ",$J($G(ACRIIF2(2)),10)," )",?60,"( ",$J($G(ACRIIF2(22)),10)," )"
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  D PPRH
  1.  W !!?9,"3.  For other reasons"
  1.  W !!?14,"a.  Interest dollars",?45,"( ",$J($FN($G(ACRIIF3(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF3(11)),"P",2),10)," )"
  1.  W !?14,"b.  Number",?45,"( ",$J($G(ACRIIF3(2)),10)," )",?60,"( ",$J($G(ACRIIF3(22)),10)," )"
  1.  W !?14,"c.  Specify Reasons:"
  1.  W !!?19,"__________________________________________________________"
  1.  W !!?19,"__________________________________________________________"
  1.  W !!?19,"__________________________________________________________"
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !!!,"III.  Invoices paid 1 - 15 days after the due date:"
  1.  W !!?4,"A.  Dollar amount",?50,$J($FN($G(ACRIIIA),"P,",2),14)
  1.  W !?4,"B.  Number",?50,$J($G(ACRIIIB),14)
  1.  W !?4,"C.  Relative Frequency:  Current Year"
  1.  W:$G(ACRIB) ?52,$J($FN($G(ACRIIIC)/ACRIB,"P",4),14)
  1.  W !?4,"                         Prior Year",?52,$J($FN($G(ACRIIC(2)),"P",4),14)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  W !!!,"IV.  Invoices paid 8 days or more before due date,"
  1.  W !!!,"     except where cash discounts are taken:"
  1.  W !!?4,"A.  Subject to a determination under section 4.1 of circular A-125:"
  1.  W !!?9,"1.  Dollar amount",?50,$J($FN($G(ACRIVA1),"P,",2),14)
  1.  W !?9,"2.  Number",?50,$J($G(ACRIVA2),14)
  1.  W !?9,"3.  Relative Frequency"
  1.  W:$G(ACRIB) ?52,$J($FN($G(ACRIVA2)/ACRIB,"P",4),14)
  1.  W !!?4,"B.  Without a determinaiton under section 4.1:"
  1.  W !!?9,"1.  Dollar amount",?50,$J($FN($G(ACRIVB1),"P,",2),14)
  1.  W !?9,"2.  Number",?50,$J($G(ACRIVB2),14)
  1.  W !?9,"3.  Relative Frequency"
  1.  W:$G(ACRIB) ?52,$J($FN($G(ACRIVB2)/ACRIB,"P",4),14)
  1.  D PAUSE^ACRFWARN
  1.  Q:$D(ACRQUIT)
  1.  D PPRH
  1.  W !!!,"V.  Discounts"
  1.  W !!?4,"A.  Number available",?50,$J($G(ACRVA(1)),10),?65,$J($FN($G(ACRVA(11)),"P,",2),14)
  1.  W !?4,"B.  Number taken",?50,$J($G(ACRVB(2)),10),?65,$J($FN($G(ACRVA(22)),"P,",2),14)
  1.  W !?4,"C.  Number not taken because not",?50,$J($G(ACRVB(3)),10),?65,$J($FN($G(ACRVB(33)),"P,",2),14)
  1.  W !?4,"    economically justified"
  1.  W !!?4,"D.  Reason for failing to take discounts, in order of importance:"
  1.  W !!?9,"1.  ____________________________________"
  1.  W !!?9,"2.  ____________________________________"
  1.  W !!?9,"3.  ____________________________________"
  1.  W !!?4,"E.  Total third party draft payments subject to Prompt Payment Act"
  1.  W !!?9,"Dollar Amount: ",$J($FN($G(ACRVE1),"P,",2),10)
  1.  W !!?9,"Number       : ",$J($G(ACRVE2),10)
  1.  W !!?4,"F.  Third party drafts which included",?50,$J($G(ACRVF(1)),10),?65,$J($FN($G(ACRVF(11)),"P,",2),14)
  1.  W !?4,"    interest"
  1.  W !!?4,"G.  Amount of interest included in line F.",?50,$J($G(ACRVG(1)),10),?65,$J($FN($G(ACRVG(11)),"P,",2),14)
  1.  D PAUSE^ACRFWARN
  1.  Q
  1. CENTER(X) ;CENTER HEADER INFO
  1.  W !?80-$L(X)/2,X
  1.  Q
  1. PPRH ;PROMPT PAYMENT REPORT HEADER
  1.  S ACRDC=$G(ACRDC)+1
  1.  W @IOF
  1.  S X=$P($G(^AUTTAREA(+$G(^ACRSYS(1,0)),0)),U)_" AREA INDIAN HEALTH SERVICE"
  1.  D CENTER(X)
  1.  F X="U.S. DEPARTMENT OF HEALTH AND HUMAN SERVICES","PROMPT PAYMENT REPORT" D CENTER(X)
  1.  S Y=DT
  1.  X ^DD("DD")
  1.  S X="DATE OF REPORT: "_Y
  1.  D CENTER(X)
  1.  W !?65,"Page ",ACRDC
  1.  Q
  1. ZIS ;SELECT OUTPUT DEVICE
  1.  S:'$D(ZTRTN) (ZTRTN,ACRRTN)="PORR1^ACRFPAYR"
  1.  S:'$D(ZTDESC) ZTDESC="Print payment source document"
  1.  D ^ACRFZIS
  1.  Q
  1. FYBEG(ACRFY,ACRQT)    ;EP; EXTRINSIC FUNCTION TO RETURN BEGIN DATES FOR LOOP ; ACR*2.1*13.03 IM11657
  1.  ; ACRFY=4 digit fiscal year
  1.  ; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
  1.  ; ACRQT=5  represents the full Fiscal Year
  1.  N X,Y
  1.  I ACRQT=1!(ACRQT=5) S Y=(ACRFY-1)-1700_1000
  1.  I ACRQT=2 S Y=ACRFY-1700_"0100"
  1.  I ACRQT=3 S Y=ACRFY-1700_"0400"
  1.  I ACRQT=4 S Y=ACRFY-1700_"0700"
  1.  Q Y
  1.  ;
  1. FYEND(ACRFY,ACRQT) ;EP; EXTRINSIC FUNCTION TO RETURN END DATE FOR LOOP ; ACR*2.1*13.03 IM11657
  1.  ; ACRFY=4 digit fiscal year
  1.  ; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
  1.  ; ACRQT=5  represents the full Fiscal Year
  1.  N X,Y
  1.  I ACRQT=1 S Y=(ACRFY-1)-1700_1231
  1.  I ACRQT=2 S Y=ACRFY-1700_"0331"
  1.  I ACRQT=3 S Y=ACRFY-1700_"0630"
  1.  I ACRQT=4!(ACRQT=5) S Y=ACRFY-1700_"0930"
  1.  Q Y