ACRFIV4 ;IHS/OIRM/DSD/THL,AEF - ARMS TO 1166 PAYMENT INTERFACE; [ 07/21/2005 2:43 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**2,16,17**;JUL 31, 2001
;;
;UTILITY TO EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
; ENTERED FROM THE TOP BY: ACRFRR11, ACRFPAY1
;
EN ;
;S ACRVDA=$S('$G(ACRDOCDA):$G(ACRVDA),$P($G(^ACRDOC(ACRDOCDA,5)),U,5):$P(^(5),U,5),1:$P(^ACRDOC(ACRDOCDA,"PO"),U,5)) ;ACR*2.1*16.06 IM15505
N ACRDOC5,ACRDOCPO ;ACR*2.1*16.06 IM15505
S ACRDOCDA=$G(ACRDOCDA) ;ACR*2.1*16.06 IM15505
S ACRDOC5=$P($G(^ACRDOC(+ACRDOCDA,5)),U,5) ;ACR*2.1*16.06 IM15505
S ACRDOCPO=$P($G(^ACRDOC(+ACRDOCDA,"PO")),U,5) ;ACR*2.1*16.06 IM15505
S ACRVDA=$S('$G(ACRDOCDA):$G(ACRVDA),ACRDOC5]"":ACRDOC5,1:ACRDOCPO) ;ACR*2.1*16.06 IM15505
I 'ACRVDA D Q
.W !!,"No VENDOR has been selected for this order."
.D PAUSE^ACRFWARN
D PAYDATE^ACRFIV41
Q:$D(ACROUT)!($G(ACRPEN)="")
S ACRBTYP="V"
D SCHT ;Commented out in ;ACR*2.1*16.06 IM15505; restored in ACR*2.1*17.07 IM17139
;D SCHT(.ACRACHX,.ACRACH,ACRBTYP,ACRVDA,.ACRDUZ,.ACRQUIT) ;Added in ACR*2.1*16.06 IM15505; Commented out in ACR*2.1*17.07 IM17139
Q:$D(ACROUT)!($G(ACRPEN)="")
S ACRBTYP="V"
Q:$D(ACROUT)
D WHICH
Q:$D(ACROUT)
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
K ACRQUIT
D VERIFY:$G(ACRDOCDA)&'$D(ACRQUIT)&'$D(ACROUT)
EXIT K ACRPEN,ACRDATE,ACRIVDAT,ACRRRDAT,ACRPAY,ACRDATE,ACRTYPE,ACRDT
Q
EN1 K ACRIV
S ACRIV=""
W @IOF
W !?10,"Payment Processing"
S DIR(0)="SO^1:Reset Payment Date;2:Edit Discounts/Penalties;3:Review Payment Summary;4:Change Vendor Remit to Address"
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)
I +Y=1 D PAYDATE^ACRFIV41 K ACRQUIT Q
I +Y=2 D WHICH K ACRQUIT Q
I +Y=3 D ^ACRFIV41 K ACRQUIT Q
I +Y=4 D VENDOR^ACRFRR K ACRQUIT
Q
DISCOUNT ;EP;DISCOUNT TERMS
;ALL DISCOUNT SUBROUTINES MOVED TO NEW ACRFIV42 ACR*2.1*16.06 IM15505
Q
WHICH ;SELECT TYPE OF ACTION
F D W1 Q:$D(ACRQUIT)!$D(ACROUT)
K ACRQUIT,ACRDT
Q
W1 W @IOF
;D PAY^ACRFIV41 ;ACR*2.1*16.06 IM15505
;S DIR(0)="S^1:Discount Taken;2:Discount Lost;3:Interest Penalty;4:No Discounts (Taken or Lost) No Penalties;5:Discount/Penalty Adjustments Complete" ;ACR*2.1*16.06 IM15505
N ACRTMP ;ACR*2.1*16.06 IM15505
D PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT) ;ACR*2.1*16.06 IM15505
S ACRTMP="S^1:Discount Taken" ;ACR*2.1*16.06 IM15505
S ACRTMP=ACRTMP_";2:Discount Lost **UNAVAILABLE**" ;ACR*2.1*16.06 IM15505
S ACRTMP=ACRTMP_";3:Interest Penalty" ;ACR*2.1*16.06 IM15505
S ACRTMP=ACRTMP_";4:No Discounts (Taken or Lost) No Penalties" ;ACR*2.1*16.06 IM15505
S ACRTMP=ACRTMP_";5:Discount/Penalty Adjustments Complete" ;ACR*2.1*16.06 IM15505
S DIR(0)=ACRTMP ;ACR*2.1*16.06 IM15505
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
I '+Y!$D(ACRQUIT)!$D(ACROUT) Q
S ACRWHICH=+Y
;I Y=1 D DISCOUNT S Y=1 ;ACR*2.1*16.06 IM15505
;I Y=2 D LOST^ACRFIV41 Q ;ACR*2.1*16.06 IM15505
;I Y=3 D INTEREST^ACRFIV41 S Y=3 ;ACR*2.1*16.06 IM15505
;I Y=4 S ACRWHICH=0,ACRQUIT="" K ACRIVDC,ACRP,ACRPCNT,ACRLOST,ACRTERMS,ACRPPEN,ACRTYPE,ACRDT,ACRT Q ;ACR*2.1*16.06 IM15505
;I Y=5 D DCAN:$G(ACRT)]""&($G(ACRIVDC)!$G(ACRP)) S ACRQUIT="" Q ;ACR*2.1*16.06 IM15505
I Y=1 D DISCOUNT^ACRFIV42(.ACRTERMS,.ACRDT,.ACROUT,.ACRQUIT,.ACRIVPAY) S Y=1 ;ACR*2.1*16.06 IM15505
I Y=2 D LOST^ACRFIV42(.ACRTERMS) Q ;ACR*2.1*16.06 IM15505
I Y=3 D INTEREST^ACRFIV41 S Y=3 ;ACR*2.1*16.06 IM15505
I Y=4 D Q ;No Penalties/Discounts(Taken or Lost) ;ACR*2.1*16.06 IM15505
.S ACRWHICH=0,ACRQUIT="" ;ACR*2.1*16.06 IM15505
.K ACRIVDC,ACRP,ACRPCNT,ACRTERMS,ACRPPEN,ACRTYPE,ACRDT,ACRT ;ACR*2.1*16.06 IM15505
;
I Y=5 D Q ;Discount/Penalty Adjustments Complete ;ACR*2.1*16.06 IM15505
.S ACRQUIT="" ;ACR*2.1*16.06 IM15505
;
I $D(ACRQUIT)!$D(ACROUT)!'$D(ACRTERMS) K ACRQUIT Q
Q
SCHT ;EP;DEFINE SCHEDULE TYPE ;Commented out in ACR*2.1*16.06 IM15505; restored in ACR*2.1*17.07 IM17139
I $G(ACRACHX)]"" S ACRACH=ACRACHX K ACRACHX Q
N X
S X=$S(ACRBTYP="V":$G(^AUTTVNDR(ACRVDA,19)),1:$G(^ACRAU(ACRDUZ,19)))
;S DIR(0)="SO^1:ACH-Grouped;2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.1;ACR*2.1*17.13 IM17827
S DIR(0)="SO^2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.01;ACR*2.1*17.13 IM17827
S DIR("A")="Type of Payment"
S:'$D(DIR("B")) DIR("B")="ACH Non-Grouped"
I $P(X,U)=""!($P(X,U,2)="")!($P(X,U,3)="") D I 1
.S DIR("B")="Check"
.W !!,"BANK ACCOUNT information NOT on file."
.S DIR(0)=DIR(0)_";6:Add BANK ACCOUNT information"
E S:'$D(DIR("B")) DIR("B")="ACH Non-Grouped" W !!,"ACCOUNT TYPE: ",$S($E(X)="C":"CHECKING",1:"SAVINGS"),!,"Bank routing and account data on file."
W !
D DIR^ACRFDIC
Q:$D(ACROUT)
I '+Y S ACRQUIT="" Q
S ACRACH=$S(+Y=1:"A",+Y=2:"B",+Y=3:"C",+Y=4:"G",+Y=5:"N",1:"")
I +Y=6 D G SCHT
.S DA=$S(ACRBTYP="V":ACRVDA,1:ACRDUZ)
.S DIE=$S(ACRBTYP="V":"^AUTTVNDR(",1:"^ACRAU(")
.S DR="1901T;1902T;1903T;1904T;1905T"
.W !
.D DIE^ACRFDIC
Q
;NEW SUB-ROUTINE ;Added in ACR*2.1*16.06 IM15505; removed in ACR*2.1*17.07 IM17139
;SCHT(ACRACHX,ACRACH,ACRBTYP,ACRVDA,ACRDUZ,ACRQUIT) ;EP; CALLED BY ACRFPRC5
; LOCAL ENTRY FROM EN
;DEFINE SCHEDULE TYPE
;
;I $G(ACRACHX)]"" S ACRACH=ACRACHX K ACRACHX Q
;N X,ACRTMP
;S X=$S(ACRBTYP="V":$G(^AUTTVNDR(ACRVDA,19)),1:$G(^ACRAU(ACRDUZ,19)))
;S DIR(0)="SO^2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.01
;S DIR(0)="SO^1:ACH-Grouped;2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.01
;S DIR("A")="Type of Payment"
;S:'$D(DIR("B")) DIR("B")="ACH Non-Grouped"
;I $P(X,U)=""!($P(X,U,2)="")!($P(X,U,3)="") D I 1
;.S DIR("B")="Check"
;.W !!,"BANK ACCOUNT information NOT on file."
;.S DIR(0)=DIR(0)_";6:Add BANK ACCOUNT information"
;E I '$D(DIR("B")) D
;.S DIR("B")="ACH Non-Grouped"
;.W !!,"ACCOUNT TYPE: "
;.W $S($E(X)="C":"CHECKING",1:"SAVINGS")
;.W !,"Bank routing and account data on file."
;W !
;D DIR^ACRFDIC
;Q:$D(ACROUT)
;I '+Y S ACRQUIT="" Q
;S ACRACH=$S(+Y=1:"A",+Y=2:"B",+Y=3:"C",+Y=4:"G",+Y=5:"N",1:"")
;I +Y=6 D G SCHT
;.S DA=$S(ACRBTYP="V":ACRVDA,1:ACRDUZ)
;.S DIE=$S(ACRBTYP="V":"^AUTTVNDR(",1:"^ACRAU(")
;.S DR="1901T;1902T;1903T;1904T;1905T"
;.W !
;.D DIE^ACRFDIC
;Q
VERIFY ;VERIFY THAT ALL DATA IS CORRECT
;D PAY^ACRFIV41 ;ACR*2.1*16.06 IM15505
D PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT) ;ACR*2.1*16.06 IM15505
S DIR(0)="Y"
S DIR("A")="Record this payment now"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:$D(ACROUT)
I '+Y S ACRQUIT="" K ACRTERMS,ACRP,ACRIVDC Q
I +Y=1 S ACRPAYME="" K ACRQUIT,ACROUT
Q
DOC() ;EP;TO PRINT DOCUMENT NO
Q:'$D(ACRDOCDA)
S X=$S($P(^ACRDOC(ACRDOCDA,0),U,2)]"":$P(^(0),U,2),1:$P(^(0),U))
Q X
OBL ;EP;TO PRINT AMOUNT OBLIGATED
Q:'$D(ACRDOCDA)
D SETDOC^ACRFEA1
S ACRREFX=$S($D(ACRRRNO):499,1:ACRREF)
S ACRPAY=""
D ^ACRFPSS
K ACRREFX
Q
CAN() ;EP;TO PRINT CAN
S X="CAN NUMBER"
Q X
OBJ() ;EP;TO PRINT AMOUNT OBLIGATED
S X="OBJC"
Q X
;
;Rewrote and moved SUB-ROUTINE DCAN to ACRFIV42 ;ACR*2.1*16.06 IM15505
DCAN ;DETERMINE WHICH CAN SHOULD BE USED FOR THE DISCOUNT OR PENALTY
;N ACR,ACRJ
;S (ACR,ACRJ)=0
;F S ACR=$O(ACRIVPAY(ACR)) Q:'ACR D
;.S ACRJ=$G(ACRJ)+1
;.S ACR(ACRJ)=ACR
;I ACRJ=1 S Y=1 D C1 Q
;W !!?10,"Select the CAN for DISCOUNT or INTEREST PENALTY"
;W !!?10,"---",?15,"-------"
;S (ACR,ACRJ)=0
;F S ACR=$O(ACRIVPAY(ACR)) Q:'ACR D
;.S ACRJ=$G(ACRJ)+1
;.W !?10,ACRJ,?15,$P(^AUTTCAN(ACR,0),U)
;S DIR(0)="N^1:"_ACRJ
;S DIR("A")=$S(ACRT>0:"Deduct DISCOUNT from",1:"Charge INTEREST PENALTYTO")_" which CAN: "
;W !
;D DIR^ACRFDIC
;I '+Y K ACRQUIT Q
C1 ;S ACRCANDA=ACR(Y)
;S ACROBJDA=$S(ACRT>0:1,ACRT=0:1,1:$O(^AUTTOBJC("C",4319,0)))
;Q:'ACRCANDA!'ACROBJDA
;S ACRIVDIS(ACRCANDA,ACROBJDA)=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
;S ACRIVDIS(ACRCANDA,ACROBJDA,$S(ACRT>0!(ACRT=0):"D",1:"P"))=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
;S ACRIVDIS(ACRCANDA,$S(ACRT>0!(ACRT=0):"D",1:"P"))=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
;Q
;End of old DCAN sub-routine ;ACR*2.1*16.06 IM15505
ACRFIV4 ;IHS/OIRM/DSD/THL,AEF - ARMS TO 1166 PAYMENT INTERFACE; [ 07/21/2005 2:43 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**2,16,17**;JUL 31, 2001
+2 ;;
+3 ;UTILITY TO EDIT PAYMENT DATA AFTER INVOICE AUDIT COMPLETED
+4 ; ENTERED FROM THE TOP BY: ACRFRR11, ACRFPAY1
+5 ;
EN ;
+1 ;S ACRVDA=$S('$G(ACRDOCDA):$G(ACRVDA),$P($G(^ACRDOC(ACRDOCDA,5)),U,5):$P(^(5),U,5),1:$P(^ACRDOC(ACRDOCDA,"PO"),U,5)) ;ACR*2.1*16.06 IM15505
+2 ;ACR*2.1*16.06 IM15505
NEW ACRDOC5,ACRDOCPO
+3 ;ACR*2.1*16.06 IM15505
SET ACRDOCDA=$GET(ACRDOCDA)
+4 ;ACR*2.1*16.06 IM15505
SET ACRDOC5=$PIECE($GET(^ACRDOC(+ACRDOCDA,5)),U,5)
+5 ;ACR*2.1*16.06 IM15505
SET ACRDOCPO=$PIECE($GET(^ACRDOC(+ACRDOCDA,"PO")),U,5)
+6 ;ACR*2.1*16.06 IM15505
SET ACRVDA=$SELECT('$GET(ACRDOCDA):$GET(ACRVDA),ACRDOC5]"":ACRDOC5,1:ACRDOCPO)
+7 IF 'ACRVDA
Begin DoDot:1
+8 WRITE !!,"No VENDOR has been selected for this order."
+9 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+10 DO PAYDATE^ACRFIV41
+11 IF $DATA(ACROUT)!($GET(ACRPEN)="")
QUIT
+12 SET ACRBTYP="V"
+13 ;Commented out in ;ACR*2.1*16.06 IM15505; restored in ACR*2.1*17.07 IM17139
DO SCHT
+14 ;D SCHT(.ACRACHX,.ACRACH,ACRBTYP,ACRVDA,.ACRDUZ,.ACRQUIT) ;Added in ACR*2.1*16.06 IM15505; Commented out in ACR*2.1*17.07 IM17139
+15 IF $DATA(ACROUT)!($GET(ACRPEN)="")
QUIT
+16 SET ACRBTYP="V"
+17 IF $DATA(ACROUT)
QUIT
+18 DO WHICH
+19 IF $DATA(ACROUT)
QUIT
+20 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+21 KILL ACRQUIT
+22 IF $GET(ACRDOCDA)&'$DATA(ACRQUIT)&'$DATA(ACROUT)
DO VERIFY
EXIT KILL ACRPEN,ACRDATE,ACRIVDAT,ACRRRDAT,ACRPAY,ACRDATE,ACRTYPE,ACRDT
+1 QUIT
EN1 KILL ACRIV
+1 SET ACRIV=""
+2 WRITE @IOF
+3 WRITE !?10,"Payment Processing"
+4 SET DIR(0)="SO^1:Reset Payment Date;2:Edit Discounts/Penalties;3:Review Payment Summary;4:Change Vendor Remit to Address"
+5 SET DIR("A")="Which one"
+6 WRITE !
+7 DO DIR^ACRFDIC
+8 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+9 IF +Y=1
DO PAYDATE^ACRFIV41
KILL ACRQUIT
QUIT
+10 IF +Y=2
DO WHICH
KILL ACRQUIT
QUIT
+11 IF +Y=3
DO ^ACRFIV41
KILL ACRQUIT
QUIT
+12 IF +Y=4
DO VENDOR^ACRFRR
KILL ACRQUIT
+13 QUIT
DISCOUNT ;EP;DISCOUNT TERMS
+1 ;ALL DISCOUNT SUBROUTINES MOVED TO NEW ACRFIV42 ACR*2.1*16.06 IM15505
+2 QUIT
WHICH ;SELECT TYPE OF ACTION
+1 FOR
DO W1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+2 KILL ACRQUIT,ACRDT
+3 QUIT
W1 WRITE @IOF
+1 ;D PAY^ACRFIV41 ;ACR*2.1*16.06 IM15505
+2 ;S DIR(0)="S^1:Discount Taken;2:Discount Lost;3:Interest Penalty;4:No Discounts (Taken or Lost) No Penalties;5:Discount/Penalty Adjustments Complete" ;ACR*2.1*16.06 IM15505
+3 ;ACR*2.1*16.06 IM15505
NEW ACRTMP
+4 ;ACR*2.1*16.06 IM15505
DO PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
+5 ;ACR*2.1*16.06 IM15505
SET ACRTMP="S^1:Discount Taken"
+6 ;ACR*2.1*16.06 IM15505
SET ACRTMP=ACRTMP_";2:Discount Lost **UNAVAILABLE**"
+7 ;ACR*2.1*16.06 IM15505
SET ACRTMP=ACRTMP_";3:Interest Penalty"
+8 ;ACR*2.1*16.06 IM15505
SET ACRTMP=ACRTMP_";4:No Discounts (Taken or Lost) No Penalties"
+9 ;ACR*2.1*16.06 IM15505
SET ACRTMP=ACRTMP_";5:Discount/Penalty Adjustments Complete"
+10 ;ACR*2.1*16.06 IM15505
SET DIR(0)=ACRTMP
+11 SET DIR("A")="Which one"
+12 WRITE !
+13 DO DIR^ACRFDIC
+14 IF '+Y!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+15 SET ACRWHICH=+Y
+16 ;I Y=1 D DISCOUNT S Y=1 ;ACR*2.1*16.06 IM15505
+17 ;I Y=2 D LOST^ACRFIV41 Q ;ACR*2.1*16.06 IM15505
+18 ;I Y=3 D INTEREST^ACRFIV41 S Y=3 ;ACR*2.1*16.06 IM15505
+19 ;I Y=4 S ACRWHICH=0,ACRQUIT="" K ACRIVDC,ACRP,ACRPCNT,ACRLOST,ACRTERMS,ACRPPEN,ACRTYPE,ACRDT,ACRT Q ;ACR*2.1*16.06 IM15505
+20 ;I Y=5 D DCAN:$G(ACRT)]""&($G(ACRIVDC)!$G(ACRP)) S ACRQUIT="" Q ;ACR*2.1*16.06 IM15505
+21 ;ACR*2.1*16.06 IM15505
IF Y=1
DO DISCOUNT^ACRFIV42(.ACRTERMS,.ACRDT,.ACROUT,.ACRQUIT,.ACRIVPAY)
SET Y=1
+22 ;ACR*2.1*16.06 IM15505
IF Y=2
DO LOST^ACRFIV42(.ACRTERMS)
QUIT
+23 ;ACR*2.1*16.06 IM15505
IF Y=3
DO INTEREST^ACRFIV41
SET Y=3
+24 ;No Penalties/Discounts(Taken or Lost) ;ACR*2.1*16.06 IM15505
IF Y=4
Begin DoDot:1
+25 ;ACR*2.1*16.06 IM15505
SET ACRWHICH=0
SET ACRQUIT=""
+26 ;ACR*2.1*16.06 IM15505
KILL ACRIVDC,ACRP,ACRPCNT,ACRTERMS,ACRPPEN,ACRTYPE,ACRDT,ACRT
End DoDot:1
QUIT
+27 ;
+28 ;Discount/Penalty Adjustments Complete ;ACR*2.1*16.06 IM15505
IF Y=5
Begin DoDot:1
+29 ;ACR*2.1*16.06 IM15505
SET ACRQUIT=""
End DoDot:1
QUIT
+30 ;
+31 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(ACRTERMS)
KILL ACRQUIT
QUIT
+32 QUIT
SCHT ;EP;DEFINE SCHEDULE TYPE ;Commented out in ACR*2.1*16.06 IM15505; restored in ACR*2.1*17.07 IM17139
+1 IF $GET(ACRACHX)]""
SET ACRACH=ACRACHX
KILL ACRACHX
QUIT
+2 NEW X
+3 SET X=$SELECT(ACRBTYP="V":$GET(^AUTTVNDR(ACRVDA,19)),1:$GET(^ACRAU(ACRDUZ,19)))
+4 ;S DIR(0)="SO^1:ACH-Grouped;2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.1;ACR*2.1*17.13 IM17827
+5 ;ACR*2.1*2.01;ACR*2.1*17.13 IM17827
SET DIR(0)="SO^2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped"
+6 SET DIR("A")="Type of Payment"
+7 IF '$DATA(DIR("B"))
SET DIR("B")="ACH Non-Grouped"
+8 IF $PIECE(X,U)=""!($PIECE(X,U,2)="")!($PIECE(X,U,3)="")
Begin DoDot:1
+9 SET DIR("B")="Check"
+10 WRITE !!,"BANK ACCOUNT information NOT on file."
+11 SET DIR(0)=DIR(0)_";6:Add BANK ACCOUNT information"
End DoDot:1
IF 1
+12 IF '$TEST
IF '$DATA(DIR("B"))
SET DIR("B")="ACH Non-Grouped"
WRITE !!,"ACCOUNT TYPE: ",$SELECT($EXTRACT(X)="C":"CHECKING",1:"SAVINGS"),!,"Bank routing and account data on file."
+13 WRITE !
+14 DO DIR^ACRFDIC
+15 IF $DATA(ACROUT)
QUIT
+16 IF '+Y
SET ACRQUIT=""
QUIT
+17 SET ACRACH=$SELECT(+Y=1:"A",+Y=2:"B",+Y=3:"C",+Y=4:"G",+Y=5:"N",1:"")
+18 IF +Y=6
Begin DoDot:1
+19 SET DA=$SELECT(ACRBTYP="V":ACRVDA,1:ACRDUZ)
+20 SET DIE=$SELECT(ACRBTYP="V":"^AUTTVNDR(",1:"^ACRAU(")
+21 SET DR="1901T;1902T;1903T;1904T;1905T"
+22 WRITE !
+23 DO DIE^ACRFDIC
End DoDot:1
GOTO SCHT
+24 QUIT
+25 ;NEW SUB-ROUTINE ;Added in ACR*2.1*16.06 IM15505; removed in ACR*2.1*17.07 IM17139
+26 ;SCHT(ACRACHX,ACRACH,ACRBTYP,ACRVDA,ACRDUZ,ACRQUIT) ;EP; CALLED BY ACRFPRC5
+27 ; LOCAL ENTRY FROM EN
+28 ;DEFINE SCHEDULE TYPE
+29 ;
+30 ;I $G(ACRACHX)]"" S ACRACH=ACRACHX K ACRACHX Q
+31 ;N X,ACRTMP
+32 ;S X=$S(ACRBTYP="V":$G(^AUTTVNDR(ACRVDA,19)),1:$G(^ACRAU(ACRDUZ,19)))
+33 ;S DIR(0)="SO^2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.01
+34 ;S DIR(0)="SO^1:ACH-Grouped;2:ACH Non-Grouped;3:Check-Grouped;4:NO-Check;5:Check-Not Grouped" ;ACR*2.1*2.01
+35 ;S DIR("A")="Type of Payment"
+36 ;S:'$D(DIR("B")) DIR("B")="ACH Non-Grouped"
+37 ;I $P(X,U)=""!($P(X,U,2)="")!($P(X,U,3)="") D I 1
+38 ;.S DIR("B")="Check"
+39 ;.W !!,"BANK ACCOUNT information NOT on file."
+40 ;.S DIR(0)=DIR(0)_";6:Add BANK ACCOUNT information"
+41 ;E I '$D(DIR("B")) D
+42 ;.S DIR("B")="ACH Non-Grouped"
+43 ;.W !!,"ACCOUNT TYPE: "
+44 ;.W $S($E(X)="C":"CHECKING",1:"SAVINGS")
+45 ;.W !,"Bank routing and account data on file."
+46 ;W !
+47 ;D DIR^ACRFDIC
+48 ;Q:$D(ACROUT)
+49 ;I '+Y S ACRQUIT="" Q
+50 ;S ACRACH=$S(+Y=1:"A",+Y=2:"B",+Y=3:"C",+Y=4:"G",+Y=5:"N",1:"")
+51 ;I +Y=6 D G SCHT
+52 ;.S DA=$S(ACRBTYP="V":ACRVDA,1:ACRDUZ)
+53 ;.S DIE=$S(ACRBTYP="V":"^AUTTVNDR(",1:"^ACRAU(")
+54 ;.S DR="1901T;1902T;1903T;1904T;1905T"
+55 ;.W !
+56 ;.D DIE^ACRFDIC
+57 ;Q
VERIFY ;VERIFY THAT ALL DATA IS CORRECT
+1 ;D PAY^ACRFIV41 ;ACR*2.1*16.06 IM15505
+2 ;ACR*2.1*16.06 IM15505
DO PAY^ACRFIV43(.ACRIVPAY,.ACRIVT,.ACRTERMS,.ACRT)
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Record this payment now"
+5 SET DIR("B")="NO"
+6 WRITE !
+7 DO DIR^ACRFDIC
+8 IF $DATA(ACROUT)
QUIT
+9 IF '+Y
SET ACRQUIT=""
KILL ACRTERMS,ACRP,ACRIVDC
QUIT
+10 IF +Y=1
SET ACRPAYME=""
KILL ACRQUIT,ACROUT
+11 QUIT
DOC() ;EP;TO PRINT DOCUMENT NO
+1 IF '$DATA(ACRDOCDA)
QUIT
+2 SET X=$SELECT($PIECE(^ACRDOC(ACRDOCDA,0),U,2)]"":$PIECE(^(0),U,2),1:$PIECE(^(0),U))
+3 QUIT X
OBL ;EP;TO PRINT AMOUNT OBLIGATED
+1 IF '$DATA(ACRDOCDA)
QUIT
+2 DO SETDOC^ACRFEA1
+3 SET ACRREFX=$SELECT($DATA(ACRRRNO):499,1:ACRREF)
+4 SET ACRPAY=""
+5 DO ^ACRFPSS
+6 KILL ACRREFX
+7 QUIT
CAN() ;EP;TO PRINT CAN
+1 SET X="CAN NUMBER"
+2 QUIT X
OBJ() ;EP;TO PRINT AMOUNT OBLIGATED
+1 SET X="OBJC"
+2 QUIT X
+3 ;
+4 ;Rewrote and moved SUB-ROUTINE DCAN to ACRFIV42 ;ACR*2.1*16.06 IM15505
DCAN ;DETERMINE WHICH CAN SHOULD BE USED FOR THE DISCOUNT OR PENALTY
+1 ;N ACR,ACRJ
+2 ;S (ACR,ACRJ)=0
+3 ;F S ACR=$O(ACRIVPAY(ACR)) Q:'ACR D
+4 ;.S ACRJ=$G(ACRJ)+1
+5 ;.S ACR(ACRJ)=ACR
+6 ;I ACRJ=1 S Y=1 D C1 Q
+7 ;W !!?10,"Select the CAN for DISCOUNT or INTEREST PENALTY"
+8 ;W !!?10,"---",?15,"-------"
+9 ;S (ACR,ACRJ)=0
+10 ;F S ACR=$O(ACRIVPAY(ACR)) Q:'ACR D
+11 ;.S ACRJ=$G(ACRJ)+1
+12 ;.W !?10,ACRJ,?15,$P(^AUTTCAN(ACR,0),U)
+13 ;S DIR(0)="N^1:"_ACRJ
+14 ;S DIR("A")=$S(ACRT>0:"Deduct DISCOUNT from",1:"Charge INTEREST PENALTYTO")_" which CAN: "
+15 ;W !
+16 ;D DIR^ACRFDIC
+17 ;I '+Y K ACRQUIT Q
C1 ;S ACRCANDA=ACR(Y)
+1 ;S ACROBJDA=$S(ACRT>0:1,ACRT=0:1,1:$O(^AUTTOBJC("C",4319,0)))
+2 ;Q:'ACRCANDA!'ACROBJDA
+3 ;S ACRIVDIS(ACRCANDA,ACROBJDA)=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
+4 ;S ACRIVDIS(ACRCANDA,ACROBJDA,$S(ACRT>0!(ACRT=0):"D",1:"P"))=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
+5 ;S ACRIVDIS(ACRCANDA,$S(ACRT>0!(ACRT=0):"D",1:"P"))=$S(ACRT>0!(ACRT=0):ACRIVDC,1:ACRP)
+6 ;Q
+7 ;End of old DCAN sub-routine ;ACR*2.1*16.06 IM15505
