ACRFIV41 ;IHS/OIRM/DSD/THL,AEF - ARMS TO 1166 PAYMENT INTERFACE; [ 04/21/2005 7:53 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,17**;MAY 15, 2001
;;
;UTILITY TO EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
Q:'$G(ACRDOCDA)
EN D EN1
EXIT K ACRDATE,ACRIVDAT,ACRRRDAT,ACRPAY,ACRDATE,ACRTYPE
Q
EN1 D GATHER
W !!,"BATCH YEAR: ",$S($E($G(ACRPAYDA),1,3)]"":$E($G(ACRPAYDA),1,3)+1700,1:"")
W !,"BATCH NO..: ",$G(ACRBATNO)
W $$DASH^ACRFMENU
W !,"DOC YEAR: ",$G(ACRDOCYR)
W ?40,"FY OF FUNDS: ",$G(ACRFYFUN)
W !,"DOC NO..: ",$G(ACRDOC)
D PAUSE^ACRFWARN
Q
GATHER ;GATHER ALL DATA
S:'$D(ACRBATNO) ACRBATNO="XXXXXX"
S ACRDOC=$S($P(^ACRDOC(ACRDOCDA,0),U,2)]"":$P(^(0),U,2),1:$P(^(0),U))
S ACRDOCYR=$S(ACRREF=116&(ACRDOC["-"):$E(ACRDOC,9),1:$E(ACRDOC))
S ACRFYFUN=$P(^ACRLOCB($P(ACRDOC0,U,6),"DT"),U)
Q
LATEPAY(ACRIVT,ACRPEN,ACRIRATE) ;EP;TO CALCULATE THE LATE PAYMENT INTEREST CHARGE
Q:'$G(ACRIVT) "" ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE TOTAL AMOUNT OF THE PAYMENT DUE
Q:'$G(ACRPEN) "" ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE NUMBER OF DAYS LATE
Q:'$G(ACRIRATE) "" ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE DAY ON WHICH THE PAYMENT IS TO BE MADE
N X,Y,Z
;ADD 2 DAYS TO NUMBER OF PENALTY DAYS TO COVER PROCESSING DAYS
S Y=ACRIVT*(ACRIRATE/100*((ACRPEN+2)/360))
S Y=$FN(Y,"P",2)
S Y=+$TR(Y," ","")
Q Y
IRATE(ACRPAYDA) ;EP;CALCULATE APPLICABLE INTEREST RATE
Q:ACRPAYDA="" ""
S X=$O(^ACRSYS(1,40,"B",ACRPAYDA+1),-1)
Q:'X "" ;PENALTY CANNOT BE CALCULATED IF NO APPLICABLE RATE IS ON FILE
S X=$O(^ACRSYS(1,40,"B",X,0))
S X=$P($G(^ACRSYS(1,40,X,0)),U,2)
Q X
INTEREST ;EP;INDICATE INTEREST PAYMENT DUE
Q:$D(ACRQUIT)!$D(ACROUT)
K ACRDT,ACRQUIT,ACRTERMS,ACRTYPE,ACRT,ACRPPEN
W !!,"Payment will be made ",ACRPEN," days late"
S ACRIRATE=$$IRATE^ACRFIV41(ACRPAYDA)
W !,"At the current daily interest rate of ",ACRIRATE
S ACRP=$$LATEPAY(ACRIVT,ACRPEN,ACRIRATE)
;S ACRTERMS=ACRPEN_U_ACRP ;ACR*2.1*16.06 IM15505
;S ACRT=-1 ;ACR*2.1*16.06 IM15505
;D PAY ;ACR*2.1*16.06 IM15505
S ACRTERMS=ACRPEN_U_ACRP_U_ACRIRATE ;ACR*2.1*16.06 IM15505
S $P(ACRTERMS,U,13)=4319 ;INTEREST OCC ;ACR*2.1*16.06 IM15505
S $P(ACRTERMS,U,8)=19917 ;INTEREST TCODE;ACR*2.1*16.06 IM15505
S ACRT=-1
S $P(ACRTERMS,U,14)=ACRT ;TYPE INT/DSC ;ACR*2.1*16.06 IM15505
D PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT) ;ACR*2.1*16.06 IM15505
Q:$D(ACROUT)
I +$G(ACRTERMS)<1 D Q
.W !!,"Payment will be made ",+$G(ACRTERMS)*-1," days early. No Interest payment due."
.D PAUSE^ACRFWARN
.K ACROUT,ACRT,ACRTERMS
.S ACRQUIT=""
;D CORRECT^ACRFIV4 ;ACR*2.1*16.06 IM15505
D CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRIVTF) ;ACR*2.1*16.06 IM15505
I '$D(ACRDT) K ACRTERMS,ACRP,ACRPCNT,ACRIRATE,ACRQUIT Q
D DCAN^ACRFIV42(.ACRTERMS,ACRT,.ACRIVDIS)
K ACRQUIT
Q
PAYDATE ;EP;CALCULATE PAYMENT DATE
I '$G(ACRDOCDA) D PD1 Q
S ACRIVDAT=$P(^ACRDOC(ACRDOCDA,"PO"),U,21)
S ACRRRDAT=$P(^ACRDOC(ACRDOCDA,"REQ1"),U,7)
I ACRIVDAT=""!(ACRRRDAT="") D Q
.W !!,"The "
.W:ACRIVDAT="" "Invoice Date"
.W:ACRIVDAT=""&(ACRRRDAT="") " and the "
.W:ACRRRDAT="" "Receiving Report Date"
.I ACRIVDAT=""&(ACRRRDAT="") W " are "
.E W " is "
.W "missing."
.W !,"You cannot proceed with payment processing until"
.I ACRIVDAT=""&(ACRRRDAT="") W " they are "
.E W " it is "
.W "entered."
.D PAUSE^ACRFWARN
.S ACRQUIT=""
PD1 ;FOR NON-ARMS DOCUMENTS
I '$G(ACRRRDAT)!'$G(ACRIVDAT) D PAYDUE Q
W !!,"Receiving Report done on: "
S Y=$P(ACRRRDAT,"@")
X ^DD("DD")
W Y
W !,"Invoice received on.....: "
S Y=$P(ACRIVDAT,"@")
X ^DD("DD")
W Y
S X1=ACRIVDAT,X2=ACRRRDAT
D ^%DTC
;S (X1,ACRDATE)=$S(X>-1!(X<-7):ACRIVDAT,1:ACRRRDAT) ;ACR*2.1*17.01 IM17097
S (X1,ACRDATE)=ACRRRDAT ;ACR*2.1*17.01 IM17097
I $G(X)]"",X>-1&(X<-7) S (X1,ACRDATE)=X ;ACR*2.1*17.01 IM17097
Q:X1=""
S X2=30
D C^%DTC
S Y=$P(X,"@")
X ^DD("DD")
S DIR("B")=$P(Y,"@")
PAYDUE ;EP;TO SELECT PAYMENT DUE DATE
S DIR(0)="DT^::E"
S DIR("A",1)="To avoid penalties"
S DIR("A")="Payment is due by......."
D DIR^ACRFDIC
I '+Y K ACRQUIT Q
I +Y S ACRPAYDU=+Y
S X1=ACRPAYDU
S X2=-7
D C^%DTC
I $E(X,4,7)=1225 S X=$E(X,1,3)_1224
I $E(X,4,7)="0101" S X=$E(X,1,3)_"0102"
I $E(X,4,7)="0704" S X=$E(X,1,3)_"0705"
S Z=X
D DW^%DTC
I $E(X)="S" D
.S X1=Z
.S X2=$S($E(X,1,2)="SA":-1,1:-2)
.D C^%DTC
.S Z=$P(X,"@")
PAYON S Y=$S(Z>DT:Z,1:DT)
X ^DD("DD")
S DIR(0)="D^::ET"
S DIR("A")="Make payment on........."
S DIR("B")=$P(Y,"@")
D DIR^ACRFDIC
I '+Y K ACRQUIT Q
I Y<DT W !!,"Payment CANNOT be made prior to TODAY." G PAYON
S ACRPAYDA=Y
S X=Y
D DW^%DTC
I $E(X)="S" W *7,*7,!!,"You cannot schedule a payment to be made on a ",X,! G PAYON
S X1=ACRPAYDA,X2=ACRPAYDU
D ^%DTC
S ACRPEN=X
K ACRQUIT
W !!,"Payment will be scheduled "
W @ACRON
I ACRPEN=0 W "the same day"
E W $TR(ACRPEN,"-","")," days ",$S(ACRPEN<0:" before",1:"after")
W @ACROF
W " the payment is due"
Q
LOST ;EP;INDICATE THE PERCENT OF DISCOUNT LOST
; Moved to ACRFIV42 ;ACR*2.1*16.06 IM15505
Q ;ACR*2.1*16.06 IM15505
PAY ;EP;TO DISPLAY PAYMENT SUMMARY
; Moved to ACRFIV43 ;ACR*2.1*16.06 IM15505
Q ;ACR*2.1*16.06 IM15505
ACRFIV41 ;IHS/OIRM/DSD/THL,AEF - ARMS TO 1166 PAYMENT INTERFACE; [ 04/21/2005 7:53 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,17**;MAY 15, 2001
+2 ;;
+3 ;UTILITY TO EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
+4 IF '$GET(ACRDOCDA)
QUIT
EN DO EN1
EXIT KILL ACRDATE,ACRIVDAT,ACRRRDAT,ACRPAY,ACRDATE,ACRTYPE
+1 QUIT
EN1 DO GATHER
+1 WRITE !!,"BATCH YEAR: ",$SELECT($EXTRACT($GET(ACRPAYDA),1,3)]"":$EXTRACT($GET(ACRPAYDA),1,3)+1700,1:"")
+2 WRITE !,"BATCH NO..: ",$GET(ACRBATNO)
+3 WRITE $$DASH^ACRFMENU
+4 WRITE !,"DOC YEAR: ",$GET(ACRDOCYR)
+5 WRITE ?40,"FY OF FUNDS: ",$GET(ACRFYFUN)
+6 WRITE !,"DOC NO..: ",$GET(ACRDOC)
+7 DO PAUSE^ACRFWARN
+8 QUIT
GATHER ;GATHER ALL DATA
+1 IF '$DATA(ACRBATNO)
SET ACRBATNO="XXXXXX"
+2 SET ACRDOC=$SELECT($PIECE(^ACRDOC(ACRDOCDA,0),U,2)]"":$PIECE(^(0),U,2),1:$PIECE(^(0),U))
+3 SET ACRDOCYR=$SELECT(ACRREF=116&(ACRDOC["-"):$EXTRACT(ACRDOC,9),1:$EXTRACT(ACRDOC))
+4 SET ACRFYFUN=$PIECE(^ACRLOCB($PIECE(ACRDOC0,U,6),"DT"),U)
+5 QUIT
LATEPAY(ACRIVT,ACRPEN,ACRIRATE) ;EP;TO CALCULATE THE LATE PAYMENT INTEREST CHARGE
+1 ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE TOTAL AMOUNT OF THE PAYMENT DUE
IF '$GET(ACRIVT)
QUIT ""
+2 ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE NUMBER OF DAYS LATE
IF '$GET(ACRPEN)
QUIT ""
+3 ;PENALTY CANNOT BE CALCULATED WITH OUT KNOWING THE DAY ON WHICH THE PAYMENT IS TO BE MADE
IF '$GET(ACRIRATE)
QUIT ""
+4 NEW X,Y,Z
+5 ;ADD 2 DAYS TO NUMBER OF PENALTY DAYS TO COVER PROCESSING DAYS
+6 SET Y=ACRIVT*(ACRIRATE/100*((ACRPEN+2)/360))
+7 SET Y=$FNUMBER(Y,"P",2)
+8 SET Y=+$TRANSLATE(Y," ","")
+9 QUIT Y
IRATE(ACRPAYDA) ;EP;CALCULATE APPLICABLE INTEREST RATE
+1 IF ACRPAYDA=""
QUIT ""
+2 SET X=$ORDER(^ACRSYS(1,40,"B",ACRPAYDA+1),-1)
+3 ;PENALTY CANNOT BE CALCULATED IF NO APPLICABLE RATE IS ON FILE
IF 'X
QUIT ""
+4 SET X=$ORDER(^ACRSYS(1,40,"B",X,0))
+5 SET X=$PIECE($GET(^ACRSYS(1,40,X,0)),U,2)
+6 QUIT X
INTEREST ;EP;INDICATE INTEREST PAYMENT DUE
+1 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+2 KILL ACRDT,ACRQUIT,ACRTERMS,ACRTYPE,ACRT,ACRPPEN
+3 WRITE !!,"Payment will be made ",ACRPEN," days late"
+4 SET ACRIRATE=$$IRATE^ACRFIV41(ACRPAYDA)
+5 WRITE !,"At the current daily interest rate of ",ACRIRATE
+6 SET ACRP=$$LATEPAY(ACRIVT,ACRPEN,ACRIRATE)
+7 ;S ACRTERMS=ACRPEN_U_ACRP ;ACR*2.1*16.06 IM15505
+8 ;S ACRT=-1 ;ACR*2.1*16.06 IM15505
+9 ;D PAY ;ACR*2.1*16.06 IM15505
+10 ;ACR*2.1*16.06 IM15505
SET ACRTERMS=ACRPEN_U_ACRP_U_ACRIRATE
+11 ;INTEREST OCC ;ACR*2.1*16.06 IM15505
SET $PIECE(ACRTERMS,U,13)=4319
+12 ;INTEREST TCODE;ACR*2.1*16.06 IM15505
SET $PIECE(ACRTERMS,U,8)=19917
+13 SET ACRT=-1
+14 ;TYPE INT/DSC ;ACR*2.1*16.06 IM15505
SET $PIECE(ACRTERMS,U,14)=ACRT
+15 ;ACR*2.1*16.06 IM15505
DO PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
+16 IF $DATA(ACROUT)
QUIT
+17 IF +$GET(ACRTERMS)<1
Begin DoDot:1
+18 WRITE !!,"Payment will be made ",+$GET(ACRTERMS)*-1," days early. No Interest payment due."
+19 DO PAUSE^ACRFWARN
+20 KILL ACROUT,ACRT,ACRTERMS
+21 SET ACRQUIT=""
End DoDot:1
QUIT
+22 ;D CORRECT^ACRFIV4 ;ACR*2.1*16.06 IM15505
+23 ;ACR*2.1*16.06 IM15505
DO CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRIVTF)
+24 IF '$DATA(ACRDT)
KILL ACRTERMS,ACRP,ACRPCNT,ACRIRATE,ACRQUIT
QUIT
+25 DO DCAN^ACRFIV42(.ACRTERMS,ACRT,.ACRIVDIS)
+26 KILL ACRQUIT
+27 QUIT
PAYDATE ;EP;CALCULATE PAYMENT DATE
+1 IF '$GET(ACRDOCDA)
DO PD1
QUIT
+2 SET ACRIVDAT=$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,21)
+3 SET ACRRRDAT=$PIECE(^ACRDOC(ACRDOCDA,"REQ1"),U,7)
+4 IF ACRIVDAT=""!(ACRRRDAT="")
Begin DoDot:1
+5 WRITE !!,"The "
+6 IF ACRIVDAT=""
WRITE "Invoice Date"
+7 IF ACRIVDAT=""&(ACRRRDAT="")
WRITE " and the "
+8 IF ACRRRDAT=""
WRITE "Receiving Report Date"
+9 IF ACRIVDAT=""&(ACRRRDAT="")
WRITE " are "
+10 IF '$TEST
WRITE " is "
+11 WRITE "missing."
+12 WRITE !,"You cannot proceed with payment processing until"
+13 IF ACRIVDAT=""&(ACRRRDAT="")
WRITE " they are "
+14 IF '$TEST
WRITE " it is "
+15 WRITE "entered."
+16 DO PAUSE^ACRFWARN
+17 SET ACRQUIT=""
End DoDot:1
QUIT
PD1 ;FOR NON-ARMS DOCUMENTS
+1 IF '$GET(ACRRRDAT)!'$GET(ACRIVDAT)
DO PAYDUE
QUIT
+2 WRITE !!,"Receiving Report done on: "
+3 SET Y=$PIECE(ACRRRDAT,"@")
+4 XECUTE ^DD("DD")
+5 WRITE Y
+6 WRITE !,"Invoice received on.....: "
+7 SET Y=$PIECE(ACRIVDAT,"@")
+8 XECUTE ^DD("DD")
+9 WRITE Y
+10 SET X1=ACRIVDAT
SET X2=ACRRRDAT
+11 DO ^%DTC
+12 ;S (X1,ACRDATE)=$S(X>-1!(X<-7):ACRIVDAT,1:ACRRRDAT) ;ACR*2.1*17.01 IM17097
+13 ;ACR*2.1*17.01 IM17097
SET (X1,ACRDATE)=ACRRRDAT
+14 ;ACR*2.1*17.01 IM17097
IF $GET(X)]""
IF X>-1&(X<-7)
SET (X1,ACRDATE)=X
+15 IF X1=""
QUIT
+16 SET X2=30
+17 DO C^%DTC
+18 SET Y=$PIECE(X,"@")
+19 XECUTE ^DD("DD")
+20 SET DIR("B")=$PIECE(Y,"@")
PAYDUE ;EP;TO SELECT PAYMENT DUE DATE
+1 SET DIR(0)="DT^::E"
+2 SET DIR("A",1)="To avoid penalties"
+3 SET DIR("A")="Payment is due by......."
+4 DO DIR^ACRFDIC
+5 IF '+Y
KILL ACRQUIT
QUIT
+6 IF +Y
SET ACRPAYDU=+Y
+7 SET X1=ACRPAYDU
+8 SET X2=-7
+9 DO C^%DTC
+10 IF $EXTRACT(X,4,7)=1225
SET X=$EXTRACT(X,1,3)_1224
+11 IF $EXTRACT(X,4,7)="0101"
SET X=$EXTRACT(X,1,3)_"0102"
+12 IF $EXTRACT(X,4,7)="0704"
SET X=$EXTRACT(X,1,3)_"0705"
+13 SET Z=X
+14 DO DW^%DTC
+15 IF $EXTRACT(X)="S"
Begin DoDot:1
+16 SET X1=Z
+17 SET X2=$SELECT($EXTRACT(X,1,2)="SA":-1,1:-2)
+18 DO C^%DTC
+19 SET Z=$PIECE(X,"@")
End DoDot:1
PAYON SET Y=$SELECT(Z>DT:Z,1:DT)
+1 XECUTE ^DD("DD")
+2 SET DIR(0)="D^::ET"
+3 SET DIR("A")="Make payment on........."
+4 SET DIR("B")=$PIECE(Y,"@")
+5 DO DIR^ACRFDIC
+6 IF '+Y
KILL ACRQUIT
QUIT
+7 IF Y<DT
WRITE !!,"Payment CANNOT be made prior to TODAY."
GOTO PAYON
+8 SET ACRPAYDA=Y
+9 SET X=Y
+10 DO DW^%DTC
+11 IF $EXTRACT(X)="S"
WRITE *7,*7,!!,"You cannot schedule a payment to be made on a ",X,!
GOTO PAYON
+12 SET X1=ACRPAYDA
SET X2=ACRPAYDU
+13 DO ^%DTC
+14 SET ACRPEN=X
+15 KILL ACRQUIT
+16 WRITE !!,"Payment will be scheduled "
+17 WRITE @ACRON
+18 IF ACRPEN=0
WRITE "the same day"
+19 IF '$TEST
WRITE $TRANSLATE(ACRPEN,"-","")," days ",$SELECT(ACRPEN<0:" before",1:"after")
+20 WRITE @ACROF
+21 WRITE " the payment is due"
+22 QUIT
LOST ;EP;INDICATE THE PERCENT OF DISCOUNT LOST
+1 ; Moved to ACRFIV42 ;ACR*2.1*16.06 IM15505
+2 ;ACR*2.1*16.06 IM15505
QUIT
PAY ;EP;TO DISPLAY PAYMENT SUMMARY
+1 ; Moved to ACRFIV43 ;ACR*2.1*16.06 IM15505
+2 ;ACR*2.1*16.06 IM15505
QUIT
