ACRFIV41.m

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