ACRFIV42.m

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