Routine: ACRFIV4

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

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

DISCOUNT ;EP;DISCOUNT TERMS

 ;ALL DISCOUNT SUBROUTINES MOVED TO NEW ACRFIV42  ACR*2.1*16.06 IM15505

WHICH ;SELECT TYPE OF ACTION

 F  D W1 Q:$D(ACRQUIT)!$D(ACROUT)

 K ACRQUIT,ACRDT

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

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

 ;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

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

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

ACRFIV4.m