ACRFPAYR ;IHS/OIRM/DSD/THL,AEF - INTEREST PENALY REPORT; [ 07/23/2002 2:22 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3**;NOV 05, 2001
;;
IPPR ;EP;TO SET UP PRINT OF INTEREST REPORT
D IPEN
IPEXIT K ACRDATE,ACRBEGIN,ACREND,ACRFYDA,ACRBATDA,ACRSEQDA,ACRFY,ACRBATNO,ACRSEQNO,ACRQUIT,ACROUT,ACRFR,ACRTO,ACRRTN,ACRT1,ACRT2,ACRJ
Q
IPEN W @IOF
W !?10,"Interest Payment Report"
S DIR(0)="NO^1000:9999"
S DIR("A",1)="Report for"
S DIR("A")="FISCAL YEAR..."
S DIR("B")=$S($E(DT,4,5)<10:$E(DT,1,3)+1700,1:($E(DT,1,3)+1)+1700)
W !!
D DIR^ACRFDIC
I $L(Y)'=4 S ACRQUIT="" Q
S ACRFY=Y
S ACRFYDA=$O(^AFSLAFP("B",Y,0))
I 'ACRFYDA D Q
.W !!,"FISCAL YEAR ",Y," NOT FOUND."
.D PAUSE^ACRFWARN
IDATES D DATES^ACRFDATE
I '$G(ACRBEGIN) S ACRQUIT="" Q
I '$G(ACREND) W !,"Both BEGINNING and ENDING dates required." G IDATES
IPAMT ;SPECIFY DOLLAR AMOUNT RANGE
S DIR(0)="NOA^1:99999999:2"
S DIR("A",1)="Interest"
S DIR("A")="Amount From...: "
S DIR("B")="1.00"
D DIR^ACRFDIC
I Y<1 S ACRQUIT="" Q
S ACRFR=Y-1
S DIR(0)="NOA^1:99999999:2"
S DIR("A")="Interest"
S DIR("A")="Amount To.....: "
D DIR^ACRFDIC
Q:$D(ACRQUIT)
I Y<1 D K ACRQUIT,ACROUT G IPAMT
S ACRTO=Y+1
S (ZTRTN,ACRRTN)="IP^ACRFPAYR"
S ZTDESC="Payment Management Interest Penalty Report"
D ^ACRFZIS
Q
IP ;EP;TO PRINT INTEREST PENALTY REPORT
D IPH
D IPDATA
Q
IPH ;HEADER
W @IOF
W !?10,"INTEREST PENALTY REPORT"
W !?10,"-----------------------"
W !?10,"FISCAL YEAR: ",ACRFY
W !?10,"REPORT FROM: "
S Y=ACRBEGIN
X ^DD("DD")
W Y
W !?10,"REPORT TO..: "
S Y=ACREND
X ^DD("DD")
W Y
W !?10,"REPORT DATE: "
S Y=DT
X ^DD("DD")
W Y
L1 W !,"--------------------------------------------------------------------------------"
Q
IPDATA ;FIND RECORDS TO INCLUDE
N ACRDATE,ACROBJDA
S ACROBJDA=$O(^AUTTOBJC("B","4319 ",0))
Q:'ACROBJDA
S (ACRT1,ACRT2,ACRJ)=0
S ACRDATE=ACRBEGIN-1
F S ACRDATE=$O(^AFSLAFP(ACRFYDA,1,"E",ACRDATE)) Q:'ACRDATE!$D(ACRQUIT)!(ACRDATE>ACREND) D
.S ACRBATDA=0
.F S ACRBATDA=$O(^AFSLAFP(ACRFYDA,1,"E",ACRDATE,ACRBATDA)) Q:'ACRBATDA D
..D IPGET
D L1
W !,?35,"TOTAL PAYMENTS: ",$J($FN(ACRT2,"P,",2),14)
W !,?35,"TOTAL INTEREST: ",$J($FN(ACRT1,"P,",2),14)
W !,?35,"TOTAL DOCUMENTS "
W !,?35,"WITH INTEREST.: ",$J(ACRJ,13)
D PAUSE^ACRFWARN
Q
IPGET ;
S ACRSEQDA=0
F S ACRSEQDA=$O(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA)) Q:'ACRSEQDA!$D(ACRQUIT) I $P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0)),U,8)=ACROBJDA,$P(^(0),U,11)>ACRFR,$P(^(0),U,11)<ACRTO D
.S ACRBATNO=$P(^AFSLAFP(ACRFYDA,1,ACRBATDA,0),U)
.N W,X,Y,Z
.S X=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0))
.S Y=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,1))
.S Z=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,2))
.S W=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA-1,0))
.S:$P(X,U,20)'=$P(W,U,20)!($P(W,U,8)=ACROBJDA) W=""
.D IPDISP
.S ACRJ=ACRJ+1
.I IOSL-8<$Y D PAUSE^ACRFWARN Q:$D(ACRQUIT) D IPH
Q
IPDISP ;DISPLAY EACH INTEREST PENALTY
W !!,"FY......: ",ACRFY,?22,"BATCH NO.: ",ACRBATNO
W !,"DOCUMENT: ",$P(W,U,20),?22,"REF CODE.: ",$P(W,U,5),?41,"SEQ. NO.: ",$P(W,U),?57,"GRS. PMT: ",$J($FN($P(W,U,11),"P,",2),10)
W !,"DOCUMENT: ",$P(X,U,20),?22,"REF CODE.: ",$P(X,U,6),?41,"SEQ. NO.: ",$P(X,U),?57,"INT. PMT: ",$J($FN($P(X,U,11),"P,",2),10)
W !,"VENDOR..: ",$E($P($G(^AUTTVNDR(+$P(X,U,10),0)),U),1,20)
W !,"PAID FOR: ",$P(X,U,14)
W !,"CAN.....: ",$P($G(^AUTTCAN(+$P(X,U,7),0)),U),?22,"OBJECT CD: ",$P($G(^AUTTOBJC(+$P(X,U,8),0)),U),?41,"FED CODE: ",$P(X,U,15),?57,"PIG-P/F.: ",$P(Y,U,19),?71,"WKLD: ",$P(X,U,17)
S ACRT1=ACRT1+$P(X,U,11)
S ACRT2=ACRT2+$P(W,U,11)
Q
CENTER(X) ;CENTER HEADER INFO
W !?80-$L(X)/2,X
Q
PORR ;EP;TO SETUP PRINT OF THE PURCHASE ORDER OR RECEIVING REPORT
N ACRXX,ACRXXX
K ACRQUIT
D WHICHP^ACRFPAY6
Q:$D(ACRQUIT)
S ACRXX=ACRY
I ACRBTYP="T" S ACRXXX=4 D ZIS Q
S DIR(0)="SO^1:Purchase Order;2:Receiving Report;3:PO and Receiving Report"
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
Q:+Y<1
S ACRXXX=Y
I ACRXXX>1 D RRNO
D ZIS
Q
ZIS ;SELECT OUTPUT DEVICE
S:'$D(ZTRTN) (ZTRTN,ACRRTN)="PORR1^ACRFPAYR"
S:'$D(ZTDESC) ZTDESC="Print payment source document"
D ^ACRFZIS
Q
PORR1 ;EP;TO PRINT PO AND/OR RECEIVING REPORT
N X,ACRJ,ACRSEQDA,ACRDOCDA,ACRRRNO
F ACRJ=1:1 S X=$P(ACRXX,",",ACRJ) Q:'X D:+$G(^TMP("ACRPAY",$J,X))
.D SETDOC
.Q:'ACRDOCDA
.I ACRXXX=4 D PO Q
.I ACRXXX=1 D PO Q
.I ACRXXX=2 D RR Q
.D PO
.D RR
Q
PO D ^ACRFQ
Q
RR S ACRRRNO=$G(ACRRR(X))
Q:'ACRRRNO
S ACRREFX=499
D ^ACRFQ
Q
SETDOC ;
S ACRSEQDA=+^TMP("ACRPAY",$J,X)
Q:'ACRSEQDA
S ACRDOCDA=$P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS")),U) ;ACR*2.1*3.2
Q:'ACRDOCDA
D SETDOC^ACRFEA1
S ACRREFDA=$P(^ACRDOC(ACRDOCDA,0),U,13)
S (ACRREF,ACRREFX)=$P($G(^AUTTDOCR(+ACRREFDA,0)),U)
Q
RRNO ;SELECT RECEIVING REPORT NUMBER FOR EACH DOCUMENT
N ACRX,ACRJ,ACRSEQDA,ACRDOCDA
F ACRJ=1:1 S ACRX=$P(ACRXX,",",ACRJ) Q:'ACRX D:+$G(^TMP("ACRPAY",$J,ACRX))
.S X=ACRX
.D SETDOC
.Q:'$G(ACRDOCDA)
.D RRNO^ACRFRRPT
.Q:'$G(ACRRRNO)
.S ACRRR(ACRX)=ACRRRNO
Q
ACRFPAYR ;IHS/OIRM/DSD/THL,AEF - INTEREST PENALY REPORT; [ 07/23/2002 2:22 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3**;NOV 05, 2001
+2 ;;
IPPR ;EP;TO SET UP PRINT OF INTEREST REPORT
+1 DO IPEN
IPEXIT KILL ACRDATE,ACRBEGIN,ACREND,ACRFYDA,ACRBATDA,ACRSEQDA,ACRFY,ACRBATNO,ACRSEQNO,ACRQUIT,ACROUT,ACRFR,ACRTO,ACRRTN,ACRT1,ACRT2,ACRJ
+1 QUIT
IPEN WRITE @IOF
+1 WRITE !?10,"Interest Payment Report"
+2 SET DIR(0)="NO^1000:9999"
+3 SET DIR("A",1)="Report for"
+4 SET DIR("A")="FISCAL YEAR..."
+5 SET DIR("B")=$SELECT($EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3)+1700,1:($EXTRACT(DT,1,3)+1)+1700)
+6 WRITE !!
+7 DO DIR^ACRFDIC
+8 IF $LENGTH(Y)'=4
SET ACRQUIT=""
QUIT
+9 SET ACRFY=Y
+10 SET ACRFYDA=$ORDER(^AFSLAFP("B",Y,0))
+11 IF 'ACRFYDA
Begin DoDot:1
+12 WRITE !!,"FISCAL YEAR ",Y," NOT FOUND."
+13 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
IDATES DO DATES^ACRFDATE
+1 IF '$GET(ACRBEGIN)
SET ACRQUIT=""
QUIT
+2 IF '$GET(ACREND)
WRITE !,"Both BEGINNING and ENDING dates required."
GOTO IDATES
IPAMT ;SPECIFY DOLLAR AMOUNT RANGE
+1 SET DIR(0)="NOA^1:99999999:2"
+2 SET DIR("A",1)="Interest"
+3 SET DIR("A")="Amount From...: "
+4 SET DIR("B")="1.00"
+5 DO DIR^ACRFDIC
+6 IF Y<1
SET ACRQUIT=""
QUIT
+7 SET ACRFR=Y-1
+8 SET DIR(0)="NOA^1:99999999:2"
+9 SET DIR("A")="Interest"
+10 SET DIR("A")="Amount To.....: "
+11 DO DIR^ACRFDIC
+12 IF $DATA(ACRQUIT)
QUIT
+13 IF Y<1
Begin DoDot:1
End DoDot:1
KILL ACRQUIT,ACROUT
GOTO IPAMT
+14 SET ACRTO=Y+1
+15 SET (ZTRTN,ACRRTN)="IP^ACRFPAYR"
+16 SET ZTDESC="Payment Management Interest Penalty Report"
+17 DO ^ACRFZIS
+18 QUIT
IP ;EP;TO PRINT INTEREST PENALTY REPORT
+1 DO IPH
+2 DO IPDATA
+3 QUIT
IPH ;HEADER
+1 WRITE @IOF
+2 WRITE !?10,"INTEREST PENALTY REPORT"
+3 WRITE !?10,"-----------------------"
+4 WRITE !?10,"FISCAL YEAR: ",ACRFY
+5 WRITE !?10,"REPORT FROM: "
+6 SET Y=ACRBEGIN
+7 XECUTE ^DD("DD")
+8 WRITE Y
+9 WRITE !?10,"REPORT TO..: "
+10 SET Y=ACREND
+11 XECUTE ^DD("DD")
+12 WRITE Y
+13 WRITE !?10,"REPORT DATE: "
+14 SET Y=DT
+15 XECUTE ^DD("DD")
+16 WRITE Y
L1 WRITE !,"--------------------------------------------------------------------------------"
+1 QUIT
IPDATA ;FIND RECORDS TO INCLUDE
+1 NEW ACRDATE,ACROBJDA
+2 SET ACROBJDA=$ORDER(^AUTTOBJC("B","4319 ",0))
+3 IF 'ACROBJDA
QUIT
+4 SET (ACRT1,ACRT2,ACRJ)=0
+5 SET ACRDATE=ACRBEGIN-1
+6 FOR
SET ACRDATE=$ORDER(^AFSLAFP(ACRFYDA,1,"E",ACRDATE))
IF 'ACRDATE!$DATA(ACRQUIT)!(ACRDATE>ACREND)
QUIT
Begin DoDot:1
+7 SET ACRBATDA=0
+8 FOR
SET ACRBATDA=$ORDER(^AFSLAFP(ACRFYDA,1,"E",ACRDATE,ACRBATDA))
IF 'ACRBATDA
QUIT
Begin DoDot:2
+9 DO IPGET
End DoDot:2
End DoDot:1
+10 DO L1
+11 WRITE !,?35,"TOTAL PAYMENTS: ",$JUSTIFY($FNUMBER(ACRT2,"P,",2),14)
+12 WRITE !,?35,"TOTAL INTEREST: ",$JUSTIFY($FNUMBER(ACRT1,"P,",2),14)
+13 WRITE !,?35,"TOTAL DOCUMENTS "
+14 WRITE !,?35,"WITH INTEREST.: ",$JUSTIFY(ACRJ,13)
+15 DO PAUSE^ACRFWARN
+16 QUIT
IPGET ;
+1 SET ACRSEQDA=0
+2 FOR
SET ACRSEQDA=$ORDER(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA))
IF 'ACRSEQDA!$DATA(ACRQUIT)
QUIT
IF $PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0)),U,8)=ACROBJDA
IF $PIECE(^(0),U,11)>ACRFR
IF $PIECE(^(0),U,11)<ACRTO
Begin DoDot:1
+3 SET ACRBATNO=$PIECE(^AFSLAFP(ACRFYDA,1,ACRBATDA,0),U)
+4 NEW W,X,Y,Z
+5 SET X=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0))
+6 SET Y=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,1))
+7 SET Z=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,2))
+8 SET W=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA-1,0))
+9 IF $PIECE(X,U,20)'=$PIECE(W,U,20)!($PIECE(W,U,8)=ACROBJDA)
SET W=""
+10 DO IPDISP
+11 SET ACRJ=ACRJ+1
+12 IF IOSL-8<$Y
DO PAUSE^ACRFWARN
IF $DATA(ACRQUIT)
QUIT
DO IPH
End DoDot:1
+13 QUIT
IPDISP ;DISPLAY EACH INTEREST PENALTY
+1 WRITE !!,"FY......: ",ACRFY,?22,"BATCH NO.: ",ACRBATNO
+2 WRITE !,"DOCUMENT: ",$PIECE(W,U,20),?22,"REF CODE.: ",$PIECE(W,U,5),?41,"SEQ. NO.: ",$PIECE(W,U),?57,"GRS. PMT: ",$JUSTIFY($FNUMBER($PIECE(W,U,11),"P,",2),10)
+3 WRITE !,"DOCUMENT: ",$PIECE(X,U,20),?22,"REF CODE.: ",$PIECE(X,U,6),?41,"SEQ. NO.: ",$PIECE(X,U),?57,"INT. PMT: ",$JUSTIFY($FNUMBER($PIECE(X,U,11),"P,",2),10)
+4 WRITE !,"VENDOR..: ",$EXTRACT($PIECE($GET(^AUTTVNDR(+$PIECE(X,U,10),0)),U),1,20)
+5 WRITE !,"PAID FOR: ",$PIECE(X,U,14)
+6 WRITE !,"CAN.....: ",$PIECE($GET(^AUTTCAN(+$PIECE(X,U,7),0)),U),?22,"OBJECT CD: ",$PIECE($GET(^AUTTOBJC(+$PIECE(X,U,8),0)),U),?41,"FED CODE: ",$PIECE(X,U,15),?57,"PIG-P/F.: ",$PIECE(Y,U,19),?71,"WKLD: ",$PIECE(X,U,17)
+7 SET ACRT1=ACRT1+$PIECE(X,U,11)
+8 SET ACRT2=ACRT2+$PIECE(W,U,11)
+9 QUIT
CENTER(X) ;CENTER HEADER INFO
+1 WRITE !?80-$LENGTH(X)/2,X
+2 QUIT
PORR ;EP;TO SETUP PRINT OF THE PURCHASE ORDER OR RECEIVING REPORT
+1 NEW ACRXX,ACRXXX
+2 KILL ACRQUIT
+3 DO WHICHP^ACRFPAY6
+4 IF $DATA(ACRQUIT)
QUIT
+5 SET ACRXX=ACRY
+6 IF ACRBTYP="T"
SET ACRXXX=4
DO ZIS
QUIT
+7 SET DIR(0)="SO^1:Purchase Order;2:Receiving Report;3:PO and Receiving Report"
+8 SET DIR("A")="Which one"
+9 WRITE !
+10 DO DIR^ACRFDIC
+11 IF +Y<1
QUIT
+12 SET ACRXXX=Y
+13 IF ACRXXX>1
DO RRNO
+14 DO ZIS
+15 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
PORR1 ;EP;TO PRINT PO AND/OR RECEIVING REPORT
+1 NEW X,ACRJ,ACRSEQDA,ACRDOCDA,ACRRRNO
+2 FOR ACRJ=1:1
SET X=$PIECE(ACRXX,",",ACRJ)
IF 'X
QUIT
IF +$GET(^TMP("ACRPAY",$JOB,X))
Begin DoDot:1
+3 DO SETDOC
+4 IF 'ACRDOCDA
QUIT
+5 IF ACRXXX=4
DO PO
QUIT
+6 IF ACRXXX=1
DO PO
QUIT
+7 IF ACRXXX=2
DO RR
QUIT
+8 DO PO
+9 DO RR
End DoDot:1
+10 QUIT
PO DO ^ACRFQ
+1 QUIT
RR SET ACRRRNO=$GET(ACRRR(X))
+1 IF 'ACRRRNO
QUIT
+2 SET ACRREFX=499
+3 DO ^ACRFQ
+4 QUIT
SETDOC ;
+1 SET ACRSEQDA=+^TMP("ACRPAY",$JOB,X)
+2 IF 'ACRSEQDA
QUIT
+3 ;ACR*2.1*3.2
SET ACRDOCDA=$PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS")),U)
+4 IF 'ACRDOCDA
QUIT
+5 DO SETDOC^ACRFEA1
+6 SET ACRREFDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,13)
+7 SET (ACRREF,ACRREFX)=$PIECE($GET(^AUTTDOCR(+ACRREFDA,0)),U)
+8 QUIT
RRNO ;SELECT RECEIVING REPORT NUMBER FOR EACH DOCUMENT
+1 NEW ACRX,ACRJ,ACRSEQDA,ACRDOCDA
+2 FOR ACRJ=1:1
SET ACRX=$PIECE(ACRXX,",",ACRJ)
IF 'ACRX
QUIT
IF +$GET(^TMP("ACRPAY",$JOB,ACRX))
Begin DoDot:1
+3 SET X=ACRX
+4 DO SETDOC
+5 IF '$GET(ACRDOCDA)
QUIT
+6 DO RRNO^ACRFRRPT
+7 IF '$GET(ACRRRNO)
QUIT
+8 SET ACRRR(ACRX)=ACRRRNO
End DoDot:1
+9 QUIT
