ACRFPPR ;IHS/OIRM/DSD/THL,AEF - PROMPT PAYMENT REPORT; [ 10/27/2004 4:18 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
;;
EN D EXIT
D PPR
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
K ACRIVA,ACRIVB,ACRVA,ACRVB,ACRVC,ACRVE1,ACRVE2,ACRVF,ACRVG,ACRIVA1,ACRIVA2,ACRIVB1,ACRIVB2,ACRNIIB
Q
PPR ;EP;TO SETUP PRINT OF THE PROMPT PAYMENT REPORT
D EXIT
K ACRQUIT,ACROUT
N ACRFYDA,ACRQT,ACRDC
S DIC="^AFSLAFP("
S DIC(0)="AEMQZ"
S DIC("A")="Fiscal Year: "
S DIC("B")=$E(DT,1,3)+1700
S DIC("S")="I $P(^(0),U)=X"
W !
D DIC^ACRFDIC
Q:Y<1
S ACRFYDA=+Y
S ACRFY=$P(^AFSLAFP(+Y,0),U)
S DIR(0)="SO^1:First Quarter;2:Second Quarter;3:Third Quarter;4:Fourth Quarter;5:Fiscal Year"
S DIR("A")="Which Quarter"
D DIR^ACRFDIC
Q:'Y
S ACRQT=Y
S ACRBEGIN=$$FYBEG^ACRFPPR(ACRFY,ACRQT) ; ACR*2.1*13.03 IM11657
S ACREND=$$FYEND^ACRFPPR(ACRFY,ACRQT) ; ACR*2.1*13.03 IM11657
S (ZTRTN,ACRRTN)="PPR1^ACRFPPR"
S ZTDESC="Prompt Payment Report"
D ZIS
Q
PPR1 ;EP;TO PRINT PROMPT PAYMENT REPORT
D GATHER^ACRFPPR1
K ACRDC
D PPRH
W !!,"For ",$S(ACRQT'=5:"Quarter",1:"Fiscal Year")," ending: "
W:ACRQT=1 "December 31, "
W:ACRQT=2 "March 31, "
W:ACRQT=3 "June 31, "
W:ACRQT>3 "September 30, "
W $E(ACREND,1,3)+1700
W !!!,"I. Invoices paid subject to the Prompt Payment Act and OMB Circular A-125:"
W !!?4,"A. Dollar value of invoices",?50,$J($FN($G(ACRIA),"P,",2),14)
W !?4,"B. Number of invoices",?50,$J($G(ACRIB),10)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !!!,"II. Invoices paid after the due date:"
W !!?4,"A. Dollar value of invoices",?50,$J($FN($G(ACRIIA),"P,",2),14)
W !?4,"B. Number of invoices (sum C.2 and F.1.b)",?50,$J($G(ACRNIIB),10)
W !!?4,"C. Late Payment interest penalties paid:"
W !!?9,"1. Dollar amount",?50,$J($FN($G(ACRIIC1),"P,",2),14)
W !?9,"2. Number",?50,$J($G(ACRIIC2),10)
W !?9,"3. Relative Frequency (II.C.2/IB)"
W:$G(ACRIB) ?52,$J($FN($G(ACRIIC2)/ACRIB,"P",4),14)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !?9,"4. Frequency distribution of late payment interest penalties paid"
W !?9," this year (as reported on line 1 and 2 of this seciton)."
W !!?40,"Number of",?55,"Dollars"
W !?4,"Amount of Penalty",?40,"Payments",?55,"Paid"
W !!?4,"$ 1.00 - $ 25.00",?40,$J($G(ACRIIC4(1)),5),?55,$J($FN($G(ACRIIC4(11)),"P,",2),10)
W !!?4,"$ 25.01 - $ 500.00",?40,$J($G(ACRIIC4(2)),5),?55,$J($FN($G(ACRIIC4(22)),"P,",2),10)
W !!?4,"$ 500.01 - $1000.00",?40,$J($G(ACRIIC4(3)),5),?55,$J($FN($G(ACRIIC4(33)),"P,",2),10)
W !!?4,"$1000.01 - $2500.00",?40,$J($G(ACRIIC4(4)),5),?55,$J($FN($G(ACRIIC4(44)),"P,",2),10)
W !!?4,"$2500.01 - $3000.00",?40,$J($G(ACRIIC4(5)),5),?55,$J($FN($G(ACRIIC4(55)),"P,",2),10)
W !!?4,"$3000.01 - plus",?40,$J($G(ACRIIC4(6)),5),?55,$J($FN($G(ACRIIC4(66)),"P,",2),10)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
D PPRH
W !!?4,"D. Additional penalties paid for failure to pay interest penalties:"
W !!?9,"1. Dollar amount",?50,$J($FN($G(ACRIID(1)),"P,",2),14)
W !?9,"2. Number",?50,$J($G(ACRIID(2)),10)
W !?9,"3. Relative Frequency"
W:$G(ACRIB) ?52,$J($FN($G(ACRIID(2))/ACRIB,"P,",4),14)
W !?9,"4. Number of minimum penalties",?50,$J($G(ACRIID(4)),14)
W !?9,"5. Number of maximum penalties",?50,$J($G(ACRIID(5)),14)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !!?4,"E. Reasons why interest of other late payment penalties were incurred."
W !?4," RANK from highest to lowest, according to frequency of occurences."
W !!?9,"1. Delay in paying offices' receipt of:"
W !!?14,"a. Receiving Report",?45,"( ",$J($G(ACRIIE1(1)),5)," )",?60,"( ",$J($G(ACRIIE1(11)),5)," )"
W !?14,"b. Proper invoice",?45,"( ",$J($G(ACRIIE1(2)),5)," )",?60,"( ",$J($G(ACRIIE1(22)),5)," )"
W !?14,"c. Purchase order or contract",?45,"( ",$J($G(ACRIIE1(3)),5)," )",?60,"( ",$J($G(ACRIIE1(33)),5)," )"
W !!?9,"2. Delay or error by paying office in:"
W !!?14,"a. Taking discount",?45,"( ",$J($G(ACRIIE2(1)),5)," )",?60,"( ",$J($G(ACRIIE2(11)),5)," )"
W !?14,"b. Notifying vendor of",?45,"( ",$J($G(ACRIIE2(2)),5)," )",?60,"( ",$J($G(ACRIIE2(22)),5)," )"
W !?14," defective invoice"
W !?14,"c. Computer or other",?45,"( ",$J($G(ACRIIE2(3)),5)," )",?60,"( ",$J($G(ACRIIE2(33)),5)," )"
W !?14," system processing"
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !!?4,"F. Interest and other late payment penalties which were due but not paid:"
W !?4," (use interest rate in effect on the date the obligation accrues)"
W !!?9,"1. Total:"
W !!?14,"a. Interest dollars",?45,"( ",$J($FN($G(ACRIIF1(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF1(11)),"P",2),10)," )"
W !?14,"b. Number",?45,"( ",$J($G(ACRIIF1(2)),10)," )",?60,"( ",$J($G(ACRIIF1(2)),10)," )"
W !!?9,"2. Because payments were less than $1.00"
W !!?14,"a. Interest dollars",?45,"( ",$J($FN($G(ACRIIF2(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF2(11)),"P",2),10)," )"
W !?14,"b. Number",?45,"( ",$J($G(ACRIIF2(2)),10)," )",?60,"( ",$J($G(ACRIIF2(22)),10)," )"
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
D PPRH
W !!?9,"3. For other reasons"
W !!?14,"a. Interest dollars",?45,"( ",$J($FN($G(ACRIIF3(1)),"P",2),10)," )",?60,"( ",$J($FN($G(ACRIIF3(11)),"P",2),10)," )"
W !?14,"b. Number",?45,"( ",$J($G(ACRIIF3(2)),10)," )",?60,"( ",$J($G(ACRIIF3(22)),10)," )"
W !?14,"c. Specify Reasons:"
W !!?19,"__________________________________________________________"
W !!?19,"__________________________________________________________"
W !!?19,"__________________________________________________________"
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !!!,"III. Invoices paid 1 - 15 days after the due date:"
W !!?4,"A. Dollar amount",?50,$J($FN($G(ACRIIIA),"P,",2),14)
W !?4,"B. Number",?50,$J($G(ACRIIIB),14)
W !?4,"C. Relative Frequency: Current Year"
W:$G(ACRIB) ?52,$J($FN($G(ACRIIIC)/ACRIB,"P",4),14)
W !?4," Prior Year",?52,$J($FN($G(ACRIIC(2)),"P",4),14)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
W !!!,"IV. Invoices paid 8 days or more before due date,"
W !!!," except where cash discounts are taken:"
W !!?4,"A. Subject to a determination under section 4.1 of circular A-125:"
W !!?9,"1. Dollar amount",?50,$J($FN($G(ACRIVA1),"P,",2),14)
W !?9,"2. Number",?50,$J($G(ACRIVA2),14)
W !?9,"3. Relative Frequency"
W:$G(ACRIB) ?52,$J($FN($G(ACRIVA2)/ACRIB,"P",4),14)
W !!?4,"B. Without a determinaiton under section 4.1:"
W !!?9,"1. Dollar amount",?50,$J($FN($G(ACRIVB1),"P,",2),14)
W !?9,"2. Number",?50,$J($G(ACRIVB2),14)
W !?9,"3. Relative Frequency"
W:$G(ACRIB) ?52,$J($FN($G(ACRIVB2)/ACRIB,"P",4),14)
D PAUSE^ACRFWARN
Q:$D(ACRQUIT)
D PPRH
W !!!,"V. Discounts"
W !!?4,"A. Number available",?50,$J($G(ACRVA(1)),10),?65,$J($FN($G(ACRVA(11)),"P,",2),14)
W !?4,"B. Number taken",?50,$J($G(ACRVB(2)),10),?65,$J($FN($G(ACRVA(22)),"P,",2),14)
W !?4,"C. Number not taken because not",?50,$J($G(ACRVB(3)),10),?65,$J($FN($G(ACRVB(33)),"P,",2),14)
W !?4," economically justified"
W !!?4,"D. Reason for failing to take discounts, in order of importance:"
W !!?9,"1. ____________________________________"
W !!?9,"2. ____________________________________"
W !!?9,"3. ____________________________________"
W !!?4,"E. Total third party draft payments subject to Prompt Payment Act"
W !!?9,"Dollar Amount: ",$J($FN($G(ACRVE1),"P,",2),10)
W !!?9,"Number : ",$J($G(ACRVE2),10)
W !!?4,"F. Third party drafts which included",?50,$J($G(ACRVF(1)),10),?65,$J($FN($G(ACRVF(11)),"P,",2),14)
W !?4," interest"
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)
D PAUSE^ACRFWARN
Q
CENTER(X) ;CENTER HEADER INFO
W !?80-$L(X)/2,X
Q
PPRH ;PROMPT PAYMENT REPORT HEADER
S ACRDC=$G(ACRDC)+1
W @IOF
S X=$P($G(^AUTTAREA(+$G(^ACRSYS(1,0)),0)),U)_" AREA INDIAN HEALTH SERVICE"
D CENTER(X)
F X="U.S. DEPARTMENT OF HEALTH AND HUMAN SERVICES","PROMPT PAYMENT REPORT" D CENTER(X)
S Y=DT
X ^DD("DD")
S X="DATE OF REPORT: "_Y
D CENTER(X)
W !?65,"Page ",ACRDC
Q
ZIS ;SELECT OUTPUT DEVICE
S:'$D(ZTRTN) (ZTRTN,ACRRTN)="PORR1^ACRFPAYR"
S:'$D(ZTDESC) ZTDESC="Print payment source document"
D ^ACRFZIS
Q
FYBEG(ACRFY,ACRQT) ;EP; EXTRINSIC FUNCTION TO RETURN BEGIN DATES FOR LOOP ; ACR*2.1*13.03 IM11657
; ACRFY=4 digit fiscal year
; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
; ACRQT=5 represents the full Fiscal Year
N X,Y
I ACRQT=1!(ACRQT=5) S Y=(ACRFY-1)-1700_1000
I ACRQT=2 S Y=ACRFY-1700_"0100"
I ACRQT=3 S Y=ACRFY-1700_"0400"
I ACRQT=4 S Y=ACRFY-1700_"0700"
Q Y
;
FYEND(ACRFY,ACRQT) ;EP; EXTRINSIC FUNCTION TO RETURN END DATE FOR LOOP ; ACR*2.1*13.03 IM11657
; ACRFY=4 digit fiscal year
; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
; ACRQT=5 represents the full Fiscal Year
N X,Y
I ACRQT=1 S Y=(ACRFY-1)-1700_1231
I ACRQT=2 S Y=ACRFY-1700_"0331"
I ACRQT=3 S Y=ACRFY-1700_"0630"
I ACRQT=4!(ACRQT=5) S Y=ACRFY-1700_"0930"
Q Y
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
+2 ;;
EN DO EXIT
+1 DO PPR
EXIT KILL 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 KILL ACRIVA,ACRIVB,ACRVA,ACRVB,ACRVC,ACRVE1,ACRVE2,ACRVF,ACRVG,ACRIVA1,ACRIVA2,ACRIVB1,ACRIVB2,ACRNIIB
+2 QUIT
PPR ;EP;TO SETUP PRINT OF THE PROMPT PAYMENT REPORT
+1 DO EXIT
+2 KILL ACRQUIT,ACROUT
+3 NEW ACRFYDA,ACRQT,ACRDC
+4 SET DIC="^AFSLAFP("
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Fiscal Year: "
+7 SET DIC("B")=$EXTRACT(DT,1,3)+1700
+8 SET DIC("S")="I $P(^(0),U)=X"
+9 WRITE !
+10 DO DIC^ACRFDIC
+11 IF Y<1
QUIT
+12 SET ACRFYDA=+Y
+13 SET ACRFY=$PIECE(^AFSLAFP(+Y,0),U)
+14 SET DIR(0)="SO^1:First Quarter;2:Second Quarter;3:Third Quarter;4:Fourth Quarter;5:Fiscal Year"
+15 SET DIR("A")="Which Quarter"
+16 DO DIR^ACRFDIC
+17 IF 'Y
QUIT
+18 SET ACRQT=Y
+19 ; ACR*2.1*13.03 IM11657
SET ACRBEGIN=$$FYBEG^ACRFPPR(ACRFY,ACRQT)
+20 ; ACR*2.1*13.03 IM11657
SET ACREND=$$FYEND^ACRFPPR(ACRFY,ACRQT)
+21 SET (ZTRTN,ACRRTN)="PPR1^ACRFPPR"
+22 SET ZTDESC="Prompt Payment Report"
+23 DO ZIS
+24 QUIT
PPR1 ;EP;TO PRINT PROMPT PAYMENT REPORT
+1 DO GATHER^ACRFPPR1
+2 KILL ACRDC
+3 DO PPRH
+4 WRITE !!,"For ",$SELECT(ACRQT'=5:"Quarter",1:"Fiscal Year")," ending: "
+5 IF ACRQT=1
WRITE "December 31, "
+6 IF ACRQT=2
WRITE "March 31, "
+7 IF ACRQT=3
WRITE "June 31, "
+8 IF ACRQT>3
WRITE "September 30, "
+9 WRITE $EXTRACT(ACREND,1,3)+1700
+10 WRITE !!!,"I. Invoices paid subject to the Prompt Payment Act and OMB Circular A-125:"
+11 WRITE !!?4,"A. Dollar value of invoices",?50,$JUSTIFY($FNUMBER($GET(ACRIA),"P,",2),14)
+12 WRITE !?4,"B. Number of invoices",?50,$JUSTIFY($GET(ACRIB),10)
+13 DO PAUSE^ACRFWARN
+14 IF $DATA(ACRQUIT)
QUIT
+15 WRITE !!!,"II. Invoices paid after the due date:"
+16 WRITE !!?4,"A. Dollar value of invoices",?50,$JUSTIFY($FNUMBER($GET(ACRIIA),"P,",2),14)
+17 WRITE !?4,"B. Number of invoices (sum C.2 and F.1.b)",?50,$JUSTIFY($GET(ACRNIIB),10)
+18 WRITE !!?4,"C. Late Payment interest penalties paid:"
+19 WRITE !!?9,"1. Dollar amount",?50,$JUSTIFY($FNUMBER($GET(ACRIIC1),"P,",2),14)
+20 WRITE !?9,"2. Number",?50,$JUSTIFY($GET(ACRIIC2),10)
+21 WRITE !?9,"3. Relative Frequency (II.C.2/IB)"
+22 IF $GET(ACRIB)
WRITE ?52,$JUSTIFY($FNUMBER($GET(ACRIIC2)/ACRIB,"P",4),14)
+23 DO PAUSE^ACRFWARN
+24 IF $DATA(ACRQUIT)
QUIT
+25 WRITE !?9,"4. Frequency distribution of late payment interest penalties paid"
+26 WRITE !?9," this year (as reported on line 1 and 2 of this seciton)."
+27 WRITE !!?40,"Number of",?55,"Dollars"
+28 WRITE !?4,"Amount of Penalty",?40,"Payments",?55,"Paid"
+29 WRITE !!?4,"$ 1.00 - $ 25.00",?40,$JUSTIFY($GET(ACRIIC4(1)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(11)),"P,",2),10)
+30 WRITE !!?4,"$ 25.01 - $ 500.00",?40,$JUSTIFY($GET(ACRIIC4(2)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(22)),"P,",2),10)
+31 WRITE !!?4,"$ 500.01 - $1000.00",?40,$JUSTIFY($GET(ACRIIC4(3)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(33)),"P,",2),10)
+32 WRITE !!?4,"$1000.01 - $2500.00",?40,$JUSTIFY($GET(ACRIIC4(4)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(44)),"P,",2),10)
+33 WRITE !!?4,"$2500.01 - $3000.00",?40,$JUSTIFY($GET(ACRIIC4(5)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(55)),"P,",2),10)
+34 WRITE !!?4,"$3000.01 - plus",?40,$JUSTIFY($GET(ACRIIC4(6)),5),?55,$JUSTIFY($FNUMBER($GET(ACRIIC4(66)),"P,",2),10)
+35 DO PAUSE^ACRFWARN
+36 IF $DATA(ACRQUIT)
QUIT
+37 DO PPRH
+38 WRITE !!?4,"D. Additional penalties paid for failure to pay interest penalties:"
+39 WRITE !!?9,"1. Dollar amount",?50,$JUSTIFY($FNUMBER($GET(ACRIID(1)),"P,",2),14)
+40 WRITE !?9,"2. Number",?50,$JUSTIFY($GET(ACRIID(2)),10)
+41 WRITE !?9,"3. Relative Frequency"
+42 IF $GET(ACRIB)
WRITE ?52,$JUSTIFY($FNUMBER($GET(ACRIID(2))/ACRIB,"P,",4),14)
+43 WRITE !?9,"4. Number of minimum penalties",?50,$JUSTIFY($GET(ACRIID(4)),14)
+44 WRITE !?9,"5. Number of maximum penalties",?50,$JUSTIFY($GET(ACRIID(5)),14)
+45 DO PAUSE^ACRFWARN
+46 IF $DATA(ACRQUIT)
QUIT
+47 WRITE !!?4,"E. Reasons why interest of other late payment penalties were incurred."
+48 WRITE !?4," RANK from highest to lowest, according to frequency of occurences."
+49 WRITE !!?9,"1. Delay in paying offices' receipt of:"
+50 WRITE !!?14,"a. Receiving Report",?45,"( ",$JUSTIFY($GET(ACRIIE1(1)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE1(11)),5)," )"
+51 WRITE !?14,"b. Proper invoice",?45,"( ",$JUSTIFY($GET(ACRIIE1(2)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE1(22)),5)," )"
+52 WRITE !?14,"c. Purchase order or contract",?45,"( ",$JUSTIFY($GET(ACRIIE1(3)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE1(33)),5)," )"
+53 WRITE !!?9,"2. Delay or error by paying office in:"
+54 WRITE !!?14,"a. Taking discount",?45,"( ",$JUSTIFY($GET(ACRIIE2(1)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE2(11)),5)," )"
+55 WRITE !?14,"b. Notifying vendor of",?45,"( ",$JUSTIFY($GET(ACRIIE2(2)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE2(22)),5)," )"
+56 WRITE !?14," defective invoice"
+57 WRITE !?14,"c. Computer or other",?45,"( ",$JUSTIFY($GET(ACRIIE2(3)),5)," )",?60,"( ",$JUSTIFY($GET(ACRIIE2(33)),5)," )"
+58 WRITE !?14," system processing"
+59 DO PAUSE^ACRFWARN
+60 IF $DATA(ACRQUIT)
QUIT
+61 WRITE !!?4,"F. Interest and other late payment penalties which were due but not paid:"
+62 WRITE !?4," (use interest rate in effect on the date the obligation accrues)"
+63 WRITE !!?9,"1. Total:"
+64 WRITE !!?14,"a. Interest dollars",?45,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF1(1)),"P",2),10)," )",?60,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF1(11)),"P",2),10)," )"
+65 WRITE !?14,"b. Number",?45,"( ",$JUSTIFY($GET(ACRIIF1(2)),10)," )",?60,"( ",$JUSTIFY($GET(ACRIIF1(2)),10)," )"
+66 WRITE !!?9,"2. Because payments were less than $1.00"
+67 WRITE !!?14,"a. Interest dollars",?45,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF2(1)),"P",2),10)," )",?60,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF2(11)),"P",2),10)," )"
+68 WRITE !?14,"b. Number",?45,"( ",$JUSTIFY($GET(ACRIIF2(2)),10)," )",?60,"( ",$JUSTIFY($GET(ACRIIF2(22)),10)," )"
+69 DO PAUSE^ACRFWARN
+70 IF $DATA(ACRQUIT)
QUIT
+71 DO PPRH
+72 WRITE !!?9,"3. For other reasons"
+73 WRITE !!?14,"a. Interest dollars",?45,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF3(1)),"P",2),10)," )",?60,"( ",$JUSTIFY($FNUMBER($GET(ACRIIF3(11)),"P",2),10)," )"
+74 WRITE !?14,"b. Number",?45,"( ",$JUSTIFY($GET(ACRIIF3(2)),10)," )",?60,"( ",$JUSTIFY($GET(ACRIIF3(22)),10)," )"
+75 WRITE !?14,"c. Specify Reasons:"
+76 WRITE !!?19,"__________________________________________________________"
+77 WRITE !!?19,"__________________________________________________________"
+78 WRITE !!?19,"__________________________________________________________"
+79 DO PAUSE^ACRFWARN
+80 IF $DATA(ACRQUIT)
QUIT
+81 WRITE !!!,"III. Invoices paid 1 - 15 days after the due date:"
+82 WRITE !!?4,"A. Dollar amount",?50,$JUSTIFY($FNUMBER($GET(ACRIIIA),"P,",2),14)
+83 WRITE !?4,"B. Number",?50,$JUSTIFY($GET(ACRIIIB),14)
+84 WRITE !?4,"C. Relative Frequency: Current Year"
+85 IF $GET(ACRIB)
WRITE ?52,$JUSTIFY($FNUMBER($GET(ACRIIIC)/ACRIB,"P",4),14)
+86 WRITE !?4," Prior Year",?52,$JUSTIFY($FNUMBER($GET(ACRIIC(2)),"P",4),14)
+87 DO PAUSE^ACRFWARN
+88 IF $DATA(ACRQUIT)
QUIT
+89 WRITE !!!,"IV. Invoices paid 8 days or more before due date,"
+90 WRITE !!!," except where cash discounts are taken:"
+91 WRITE !!?4,"A. Subject to a determination under section 4.1 of circular A-125:"
+92 WRITE !!?9,"1. Dollar amount",?50,$JUSTIFY($FNUMBER($GET(ACRIVA1),"P,",2),14)
+93 WRITE !?9,"2. Number",?50,$JUSTIFY($GET(ACRIVA2),14)
+94 WRITE !?9,"3. Relative Frequency"
+95 IF $GET(ACRIB)
WRITE ?52,$JUSTIFY($FNUMBER($GET(ACRIVA2)/ACRIB,"P",4),14)
+96 WRITE !!?4,"B. Without a determinaiton under section 4.1:"
+97 WRITE !!?9,"1. Dollar amount",?50,$JUSTIFY($FNUMBER($GET(ACRIVB1),"P,",2),14)
+98 WRITE !?9,"2. Number",?50,$JUSTIFY($GET(ACRIVB2),14)
+99 WRITE !?9,"3. Relative Frequency"
+100 IF $GET(ACRIB)
WRITE ?52,$JUSTIFY($FNUMBER($GET(ACRIVB2)/ACRIB,"P",4),14)
+101 DO PAUSE^ACRFWARN
+102 IF $DATA(ACRQUIT)
QUIT
+103 DO PPRH
+104 WRITE !!!,"V. Discounts"
+105 WRITE !!?4,"A. Number available",?50,$JUSTIFY($GET(ACRVA(1)),10),?65,$JUSTIFY($FNUMBER($GET(ACRVA(11)),"P,",2),14)
+106 WRITE !?4,"B. Number taken",?50,$JUSTIFY($GET(ACRVB(2)),10),?65,$JUSTIFY($FNUMBER($GET(ACRVA(22)),"P,",2),14)
+107 WRITE !?4,"C. Number not taken because not",?50,$JUSTIFY($GET(ACRVB(3)),10),?65,$JUSTIFY($FNUMBER($GET(ACRVB(33)),"P,",2),14)
+108 WRITE !?4," economically justified"
+109 WRITE !!?4,"D. Reason for failing to take discounts, in order of importance:"
+110 WRITE !!?9,"1. ____________________________________"
+111 WRITE !!?9,"2. ____________________________________"
+112 WRITE !!?9,"3. ____________________________________"
+113 WRITE !!?4,"E. Total third party draft payments subject to Prompt Payment Act"
+114 WRITE !!?9,"Dollar Amount: ",$JUSTIFY($FNUMBER($GET(ACRVE1),"P,",2),10)
+115 WRITE !!?9,"Number : ",$JUSTIFY($GET(ACRVE2),10)
+116 WRITE !!?4,"F. Third party drafts which included",?50,$JUSTIFY($GET(ACRVF(1)),10),?65,$JUSTIFY($FNUMBER($GET(ACRVF(11)),"P,",2),14)
+117 WRITE !?4," interest"
+118 WRITE !!?4,"G. Amount of interest included in line F.",?50,$JUSTIFY($GET(ACRVG(1)),10),?65,$JUSTIFY($FNUMBER($GET(ACRVG(11)),"P,",2),14)
+119 DO PAUSE^ACRFWARN
+120 QUIT
CENTER(X) ;CENTER HEADER INFO
+1 WRITE !?80-$LENGTH(X)/2,X
+2 QUIT
PPRH ;PROMPT PAYMENT REPORT HEADER
+1 SET ACRDC=$GET(ACRDC)+1
+2 WRITE @IOF
+3 SET X=$PIECE($GET(^AUTTAREA(+$GET(^ACRSYS(1,0)),0)),U)_" AREA INDIAN HEALTH SERVICE"
+4 DO CENTER(X)
+5 FOR X="U.S. DEPARTMENT OF HEALTH AND HUMAN SERVICES","PROMPT PAYMENT REPORT"
DO CENTER(X)
+6 SET Y=DT
+7 XECUTE ^DD("DD")
+8 SET X="DATE OF REPORT: "_Y
+9 DO CENTER(X)
+10 WRITE !?65,"Page ",ACRDC
+11 QUIT
ZIS ;SELECT OUTPUT DEVICE
+1 IF '$DATA(ZTRTN)
SET (ZTRTN,ACRRTN)="PORR1^ACRFPAYR"
+2 IF '$DATA(ZTDESC)
SET ZTDESC="Print payment source document"
+3 DO ^ACRFZIS
+4 QUIT
FYBEG(ACRFY,ACRQT) ;EP; EXTRINSIC FUNCTION TO RETURN BEGIN DATES FOR LOOP ; ACR*2.1*13.03 IM11657
+1 ; ACRFY=4 digit fiscal year
+2 ; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
+3 ; ACRQT=5 represents the full Fiscal Year
+4 NEW X,Y
+5 IF ACRQT=1!(ACRQT=5)
SET Y=(ACRFY-1)-1700_1000
+6 IF ACRQT=2
SET Y=ACRFY-1700_"0100"
+7 IF ACRQT=3
SET Y=ACRFY-1700_"0400"
+8 IF ACRQT=4
SET Y=ACRFY-1700_"0700"
+9 QUIT Y
+10 ;
FYEND(ACRFY,ACRQT) ;EP; EXTRINSIC FUNCTION TO RETURN END DATE FOR LOOP ; ACR*2.1*13.03 IM11657
+1 ; ACRFY=4 digit fiscal year
+2 ; ACRQT=1,2,3,4 represents quarters of the Fiscal Year
+3 ; ACRQT=5 represents the full Fiscal Year
+4 NEW X,Y
+5 IF ACRQT=1
SET Y=(ACRFY-1)-1700_1231
+6 IF ACRQT=2
SET Y=ACRFY-1700_"0331"
+7 IF ACRQT=3
SET Y=ACRFY-1700_"0630"
+8 IF ACRQT=4!(ACRQT=5)
SET Y=ACRFY-1700_"0930"
+9 QUIT Y
