ACRFIV42 ;IHS/OIRM/DSD/AEF,MRS - ARMS TO 1166 PAYMENT INTERFACE [ 05/09/2005 8:51 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,17**;JUL 31, 2001
;ACR*2.1*16.06 IM15505 ;NEW ROUTINE
;
; UTILITY EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
; CONTINUED FROM ACRFIV41
; CALLED TO DO DISCOUNT AND DISCOUNT LOST PROCESSING ONLY
;
LOST(ACRTERMS) ;EP;INDICATE THE PERCENT OF DISCOUNT LOST
;TEMPORARY OUT OF ORDER MESSAGE
W !!!,"The Discount Lost option is not available at this time"
D PAUSE^ACRFWARN
Q
S DIR(0)="NOA^0:99"
S DIR("A")="Percent of the Discount Lost: "
W !
D DIR^ACRFDIC
Q:$D(ACROUT)
I +Y D
. S $P(ACRTERMS,U,3)=+Y
. S ACRT=-2 ;Flag/Capture rate
I $G(ACRTERMS)="" D
.S DIR(0)="NOA^0:100000:2"
.S DIR("A")="Actual Dollar amount LOST...: "
.W !
.D DIR^ACRFDIC
.I +Y D
. . S $P(ACRTERMS,U,2)=+Y
. . S ACRT=-2 ;Flag/Capture amount
I $G(ACRTERMS)="" D Q
.W !!,"NO Lost Discount will be recorded."
.K ACRTERMS
.Q
S $P(ACRTERMS,U,14)=ACRT
D PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
D CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRTERMS,.ACRIVTF)
I '$D(ACRDT) D KILL G LOST
S $P(ACRTERMS,U,8)=19817 ;Discount Lost transaction code
Q
;
DISCOUNT(ACRTERMS,ACRDT,ACROUT,ACRQUIT,ACRIVPAY) ;EP;DISCOUNT TERMS
DISC K ACRDT,ACRQUIT,ACRTERMS,ACRTYPE,ACRT
N J,X,Y,Z
D DTSEL
Q:$D(ACRQUIT)
I $G(ACRTERMS)="" D
.W !!,"No DISCOUNT TERMS selected for this PAYMENT"
.D KILL
I ACRT]"",ACRT'=-1 D DCAN(.ACRTERMS,ACRT,.ACRIVDIS)
D PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
D CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRIVTF)
I '$D(ACRDT) D G DISC
.D KILL
.K ACRQUIT
K ACRQUIT
Q
;
DTSEL ;EP;SELECT TERMS APPLICABLE TO THIS PAYMENT
S ACRTYPE="APPLY"
S DIR(0)="SO^1:Discount Percent;2:Actual Dollar Discount"
S DIR(0)=DIR(0)_";3:No Discounts;4:Discount Adjustments Complete"
S DIR("A")="Discount Method"
D DIR^ACRFDIC
I '$G(Y) S ACRQUIT="" Q
I Y=1 D S Y=1 ;UPDATE/SELECT VENDOR DISCOUNT TERMS
.D DT^ACRFDT
.;I $D(ACRQUIT)!$G(ACRDTDA)']"" D Q ;ACR*2.1*17.09 IM17312
.I $D(ACRQUIT)!($G(ACRDTDA)']"") D Q ;ACR*2.1*17.09 IM17312
..W !!,"No DISCOUNT TERMS selected for this PAYMENT"
..D KILL
.S $P(ACRTERMS,U)=$P(ACRDTDA,U) ;Discount Days
.S $P(ACRTERMS,U,3)=$P(ACRDTDA,U,2) ;Discount % Rate
.S ACRT=1 ;Discount w/percentage
;
I Y=2 D DAMT
Q:$G(ACRTERMS)=""
S $P(ACRTERMS,U,8)="05025" ;Discount transaction code
S $P(ACRTERMS,U,12)=ACRIVTF ;Invoice total
S $P(ACRTERMS,U,14)=ACRT ;Type int/dsc (0 or 1)
;
I Y=3 D
.D KILL
.S ACRQUIT=""
Q
DAMT ;SELECT DISCOUNT DOLLAR AMOUNT
S DIR(0)="NOA^0:99999:2"
S DIR("A")="Discount Dollar Amount: "
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$G(ACRDTDA)']"" D Q
.W !!,"No DISCOUNT TERMS selected for this PAYMENT" K ACRTERMS
;S $P(ACRTERMS,U,1,2)="D"_U_Y
S $P(ACRTERMS,U,2)=Y
S ACRT=0 ;Discount w/dollar amount given
Q
DCAN(ACRTERMS,ACRT,ACRIVDIS) ;DETERMINE WHICH OCC/SET SEPARATE DISCOUNT AMOUNTS PER OCC
N ACR,ACRA,ACRC,ACRO,ACRJ,ACRDCNT,ACRPC
S (ACRC,ACRJ,ACRPCTOT)=0
S ACRDCNT=$$OBJCNT^ACRFIV43(.ACRIVPAY)
Q:'ACRDCNT
F S ACRC=$O(ACRIVPAY(ACRC)) Q:'ACRC D
.S ACRO=0
.F S ACRO=$O(ACRIVPAY(ACRC,ACRO)) Q:'ACRO D
..S ACR=ACRIVPAY(ACRC,ACRO) ;ORIGINAL ITEM AMOUNT
..S ACRA=$P(ACRTERMS,U,2) ;DISCOUNT DOLLAR AMOUNT
..S ACRATE=$P(ACRTERMS,U,3) ;DISCOUNT RATE
..S ACRTOT=$P(ACRTERMS,U,12) ;FULL INVOICE AMOUNT
..S ACRPC=$$PERCNT(ACR,ACRA,ACRATE,ACRTOT)
..S ACRPCTOT=ACRPCTOT+ACRPC
..D C1(ACR,.ACRIVDIS,ACRC,ACRO,ACRT,ACRPC,ACRPCTOT)
S:$P(ACRTERMS,U,2)="" $P(ACRTERMS,U,2)=ACRPCTOT
Q
;
C1(ACRORG,ACRIVDIS,ACRCANDA,ACROBJDA,ACRT,ACRPC,ACRP) ;LOCAL ENTRY
; Sets ACRIVDIS(ACRCANDA,ACROBJDA array using ACRT
; ACRT >0 = Discount w/percentage
; ACRT =0 = Discount w/amount given
; ACRT -1 = Interest penalty amount
; ACRT -2 = Discount Lost
; If an interest penalty, uses fixed OCC=4319 = INTEREST-ALL OTHER
;
;S ACROBJDA=$S(ACRT>0:1,ACRT=0:1,1:$O(^AUTTOBJC("C",4319,0)))
I ACRT=1!(ACRT=0) D ;DISCOUNT TAKEN FLAG
.S ACRIVDIS(ACRCANDA,ACROBJDA)=ACRORG-ACRPC ;-DISCOUNT AMOUNT
.S ACRIVDIS(ACRCANDA,ACROBJDA,"D")=ACRPC
.S ACRIVDIS(ACRCANDA,"D")=ACRP ;TOTAL DISCOUNT ON INVOICE
; Changes below by Linda to test Interest display on individual items
;I ACRT<0 D ;INTEREST PENALTY
I ACRT=-2 D ;LSL (Discount Lost)
.S ACRIVDIS(ACRCANDA,ACROBJDA)=ACRP ;PENALTY AMOUNT
.S ACRIVDIS(ACRCANDA,ACROBJDA,"P")=ACRP
.S ACRIVDIS(ACRCANDA,"P")=ACRP
I ACRT=-1 D ;LSL (Interest)
.S ACRIVDIS(ACRCANDA,ACROBJDA)=ACRPC ;PENALTY AMOUNT
.S ACRIVDIS(ACRCANDA,ACROBJDA,"P")=ACRPC
.S ACRIVDIS(ACRCANDA,"P")=ACRPC
Q
PERCNT(ACRAMT,ACRA,ACRATE,ACRTOT) ;EXTRINSIC FUNCTION TO CALCULATE PERCENTAGE
; ENTERS WITH ACRAMT: ORIGINAL AMOUNT DUE FOR ITEM
; ACRA : DOLLAR AMOUNT TO BE DISCOUNTED, IF THERE or
; ACRATE: PERCENTAGE TO BE DISCOUNTED, IF THERE
; ACRTOT: TOTAL AMOUNT OF INVOICE
; RETURNS AMOUNT OF DISCOUNT
;
N ACR
I ACRA]"" D
.S ACRATE=ACRA/ACRTOT ;CREATE PERCENTAGE
S:ACRATE'["." ACRATE=ACRATE/100
S ACR=ACRATE*ACRAMT
S ACR=$J(ACR,"P",2)
I ACR<0 S ACR=0
Q ACR
KILL ; KILL VARIABLES IF NOT CORRECT
K ACRTERMS
K ACRIVDIS
K ACRQUIT
S ACRT=""
Q
ACRFIV42 ;IHS/OIRM/DSD/AEF,MRS - ARMS TO 1166 PAYMENT INTERFACE [ 05/09/2005 8:51 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,17**;JUL 31, 2001
+2 ;ACR*2.1*16.06 IM15505 ;NEW ROUTINE
+3 ;
+4 ; UTILITY EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
+5 ; CONTINUED FROM ACRFIV41
+6 ; CALLED TO DO DISCOUNT AND DISCOUNT LOST PROCESSING ONLY
+7 ;
LOST(ACRTERMS) ;EP;INDICATE THE PERCENT OF DISCOUNT LOST
+1 ;TEMPORARY OUT OF ORDER MESSAGE
+2 WRITE !!!,"The Discount Lost option is not available at this time"
+3 DO PAUSE^ACRFWARN
+4 QUIT
+5 SET DIR(0)="NOA^0:99"
+6 SET DIR("A")="Percent of the Discount Lost: "
+7 WRITE !
+8 DO DIR^ACRFDIC
+9 IF $DATA(ACROUT)
QUIT
+10 IF +Y
Begin DoDot:1
+11 SET $PIECE(ACRTERMS,U,3)=+Y
+12 ;Flag/Capture rate
SET ACRT=-2
End DoDot:1
+13 IF $GET(ACRTERMS)=""
Begin DoDot:1
+14 SET DIR(0)="NOA^0:100000:2"
+15 SET DIR("A")="Actual Dollar amount LOST...: "
+16 WRITE !
+17 DO DIR^ACRFDIC
+18 IF +Y
Begin DoDot:2
+19 SET $PIECE(ACRTERMS,U,2)=+Y
+20 ;Flag/Capture amount
SET ACRT=-2
End DoDot:2
End DoDot:1
+21 IF $GET(ACRTERMS)=""
Begin DoDot:1
+22 WRITE !!,"NO Lost Discount will be recorded."
+23 KILL ACRTERMS
+24 QUIT
End DoDot:1
QUIT
+25 SET $PIECE(ACRTERMS,U,14)=ACRT
+26 DO PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
+27 DO CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRTERMS,.ACRIVTF)
+28 IF '$DATA(ACRDT)
DO KILL
GOTO LOST
+29 ;Discount Lost transaction code
SET $PIECE(ACRTERMS,U,8)=19817
+30 QUIT
+31 ;
DISCOUNT(ACRTERMS,ACRDT,ACROUT,ACRQUIT,ACRIVPAY) ;EP;DISCOUNT TERMS
DISC KILL ACRDT,ACRQUIT,ACRTERMS,ACRTYPE,ACRT
+1 NEW J,X,Y,Z
+2 DO DTSEL
+3 IF $DATA(ACRQUIT)
QUIT
+4 IF $GET(ACRTERMS)=""
Begin DoDot:1
+5 WRITE !!,"No DISCOUNT TERMS selected for this PAYMENT"
+6 DO KILL
End DoDot:1
+7 IF ACRT]""
IF ACRT'=-1
DO DCAN(.ACRTERMS,ACRT,.ACRIVDIS)
+8 DO PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
+9 DO CORRECT^ACRFIV43(.ACRDT,.ACRPCNT,.ACRIVDC,.ACRIVTF)
+10 IF '$DATA(ACRDT)
Begin DoDot:1
+11 DO KILL
+12 KILL ACRQUIT
End DoDot:1
GOTO DISC
+13 KILL ACRQUIT
+14 QUIT
+15 ;
DTSEL ;EP;SELECT TERMS APPLICABLE TO THIS PAYMENT
+1 SET ACRTYPE="APPLY"
+2 SET DIR(0)="SO^1:Discount Percent;2:Actual Dollar Discount"
+3 SET DIR(0)=DIR(0)_";3:No Discounts;4:Discount Adjustments Complete"
+4 SET DIR("A")="Discount Method"
+5 DO DIR^ACRFDIC
+6 IF '$GET(Y)
SET ACRQUIT=""
QUIT
+7 ;UPDATE/SELECT VENDOR DISCOUNT TERMS
IF Y=1
Begin DoDot:1
+8 DO DT^ACRFDT
+9 ;I $D(ACRQUIT)!$G(ACRDTDA)']"" D Q ;ACR*2.1*17.09 IM17312
+10 ;ACR*2.1*17.09 IM17312
IF $DATA(ACRQUIT)!($GET(ACRDTDA)']"")
Begin DoDot:2
+11 WRITE !!,"No DISCOUNT TERMS selected for this PAYMENT"
+12 DO KILL
End DoDot:2
QUIT
+13 ;Discount Days
SET $PIECE(ACRTERMS,U)=$PIECE(ACRDTDA,U)
+14 ;Discount % Rate
SET $PIECE(ACRTERMS,U,3)=$PIECE(ACRDTDA,U,2)
+15 ;Discount w/percentage
SET ACRT=1
End DoDot:1
SET Y=1
+16 ;
+17 IF Y=2
DO DAMT
+18 IF $GET(ACRTERMS)=""
QUIT
+19 ;Discount transaction code
SET $PIECE(ACRTERMS,U,8)="05025"
+20 ;Invoice total
SET $PIECE(ACRTERMS,U,12)=ACRIVTF
+21 ;Type int/dsc (0 or 1)
SET $PIECE(ACRTERMS,U,14)=ACRT
+22 ;
+23 IF Y=3
Begin DoDot:1
+24 DO KILL
+25 SET ACRQUIT=""
End DoDot:1
+26 QUIT
DAMT ;SELECT DISCOUNT DOLLAR AMOUNT
+1 SET DIR(0)="NOA^0:99999:2"
+2 SET DIR("A")="Discount Dollar Amount: "
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACRQUIT)!$GET(ACRDTDA)']""
Begin DoDot:1
+6 WRITE !!,"No DISCOUNT TERMS selected for this PAYMENT"
KILL ACRTERMS
End DoDot:1
QUIT
+7 ;S $P(ACRTERMS,U,1,2)="D"_U_Y
+8 SET $PIECE(ACRTERMS,U,2)=Y
+9 ;Discount w/dollar amount given
SET ACRT=0
+10 QUIT
DCAN(ACRTERMS,ACRT,ACRIVDIS) ;DETERMINE WHICH OCC/SET SEPARATE DISCOUNT AMOUNTS PER OCC
+1 NEW ACR,ACRA,ACRC,ACRO,ACRJ,ACRDCNT,ACRPC
+2 SET (ACRC,ACRJ,ACRPCTOT)=0
+3 SET ACRDCNT=$$OBJCNT^ACRFIV43(.ACRIVPAY)
+4 IF 'ACRDCNT
QUIT
+5 FOR
SET ACRC=$ORDER(ACRIVPAY(ACRC))
IF 'ACRC
QUIT
Begin DoDot:1
+6 SET ACRO=0
+7 FOR
SET ACRO=$ORDER(ACRIVPAY(ACRC,ACRO))
IF 'ACRO
QUIT
Begin DoDot:2
+8 ;ORIGINAL ITEM AMOUNT
SET ACR=ACRIVPAY(ACRC,ACRO)
+9 ;DISCOUNT DOLLAR AMOUNT
SET ACRA=$PIECE(ACRTERMS,U,2)
+10 ;DISCOUNT RATE
SET ACRATE=$PIECE(ACRTERMS,U,3)
+11 ;FULL INVOICE AMOUNT
SET ACRTOT=$PIECE(ACRTERMS,U,12)
+12 SET ACRPC=$$PERCNT(ACR,ACRA,ACRATE,ACRTOT)
+13 SET ACRPCTOT=ACRPCTOT+ACRPC
+14 DO C1(ACR,.ACRIVDIS,ACRC,ACRO,ACRT,ACRPC,ACRPCTOT)
End DoDot:2
End DoDot:1
+15 IF $PIECE(ACRTERMS,U,2)=""
SET $PIECE(ACRTERMS,U,2)=ACRPCTOT
+16 QUIT
+17 ;
C1(ACRORG,ACRIVDIS,ACRCANDA,ACROBJDA,ACRT,ACRPC,ACRP) ;LOCAL ENTRY
+1 ; Sets ACRIVDIS(ACRCANDA,ACROBJDA array using ACRT
+2 ; ACRT >0 = Discount w/percentage
+3 ; ACRT =0 = Discount w/amount given
+4 ; ACRT -1 = Interest penalty amount
+5 ; ACRT -2 = Discount Lost
+6 ; If an interest penalty, uses fixed OCC=4319 = INTEREST-ALL OTHER
+7 ;
+8 ;S ACROBJDA=$S(ACRT>0:1,ACRT=0:1,1:$O(^AUTTOBJC("C",4319,0)))
+9 ;DISCOUNT TAKEN FLAG
IF ACRT=1!(ACRT=0)
Begin DoDot:1
+10 ;-DISCOUNT AMOUNT
SET ACRIVDIS(ACRCANDA,ACROBJDA)=ACRORG-ACRPC
+11 SET ACRIVDIS(ACRCANDA,ACROBJDA,"D")=ACRPC
+12 ;TOTAL DISCOUNT ON INVOICE
SET ACRIVDIS(ACRCANDA,"D")=ACRP
End DoDot:1
+13 ; Changes below by Linda to test Interest display on individual items
+14 ;I ACRT<0 D ;INTEREST PENALTY
+15 ;LSL (Discount Lost)
IF ACRT=-2
Begin DoDot:1
+16 ;PENALTY AMOUNT
SET ACRIVDIS(ACRCANDA,ACROBJDA)=ACRP
+17 SET ACRIVDIS(ACRCANDA,ACROBJDA,"P")=ACRP
+18 SET ACRIVDIS(ACRCANDA,"P")=ACRP
End DoDot:1
+19 ;LSL (Interest)
IF ACRT=-1
Begin DoDot:1
+20 ;PENALTY AMOUNT
SET ACRIVDIS(ACRCANDA,ACROBJDA)=ACRPC
+21 SET ACRIVDIS(ACRCANDA,ACROBJDA,"P")=ACRPC
+22 SET ACRIVDIS(ACRCANDA,"P")=ACRPC
End DoDot:1
+23 QUIT
PERCNT(ACRAMT,ACRA,ACRATE,ACRTOT) ;EXTRINSIC FUNCTION TO CALCULATE PERCENTAGE
+1 ; ENTERS WITH ACRAMT: ORIGINAL AMOUNT DUE FOR ITEM
+2 ; ACRA : DOLLAR AMOUNT TO BE DISCOUNTED, IF THERE or
+3 ; ACRATE: PERCENTAGE TO BE DISCOUNTED, IF THERE
+4 ; ACRTOT: TOTAL AMOUNT OF INVOICE
+5 ; RETURNS AMOUNT OF DISCOUNT
+6 ;
+7 NEW ACR
+8 IF ACRA]""
Begin DoDot:1
+9 ;CREATE PERCENTAGE
SET ACRATE=ACRA/ACRTOT
End DoDot:1
+10 IF ACRATE'["."
SET ACRATE=ACRATE/100
+11 SET ACR=ACRATE*ACRAMT
+12 SET ACR=$JUSTIFY(ACR,"P",2)
+13 IF ACR<0
SET ACR=0
+14 QUIT ACR
KILL ; KILL VARIABLES IF NOT CORRECT
+1 KILL ACRTERMS
+2 KILL ACRIVDIS
+3 KILL ACRQUIT
+4 SET ACRT=""
+5 QUIT
