BARFPST1 ; IHS/SD/LSL - FLAT RATE POSTING (CONT) ; 12/22/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**6,10,21,23**;OCT 26, 2005
;; P.OTT Aug 2013 HEAT#126384 FIXED <undef> @ FDIH
;
Q
; *********************************************************************
PAYADJD ; EP
; EP - Display payment/adjustment in FRP file
S BARACNT=0 ; Adjustment array counter
I $D(BARIEN) D ; If existing Flat Rate Posting entry
. S BARPAY=$$VAL^XBDIQ1(90054.01,BARIEN,.09) ; Payment
. D PAYADJA ; Build Adjustment Array
. D PAYADJQ ; Display array
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
Q
; *********************************************************************
PAYADJA ;
; Build Adjustment array from FRP file
N BARTMP
F S BARACNT=$O(^BARFRP(DUZ(2),BARIEN,1,BARACNT)) Q:'+BARACNT D
. S BARTMP=BARACNT
. S BARFR0=$G(^BARFRP(DUZ(2),BARIEN,1,BARACNT,0))
. S $P(BARADJ(BARACNT),U)=$P(BARFR0,U,3) ; Adjustment amount
. S $P(BARADJ(BARACNT),U,2)=$P(BARFR0,U) ; IEN to A/R TABLE TYPE/IHS
. ; Adjustment Category
. S $P(BARADJ(BARACNT),U,3)=$$VAL^XBDIQ1(90052.01,$P(BARFR0,U),.01)
. S $P(BARADJ(BARACNT),U,4)=$P(BARFR0,U,2) ; IEN to A/R TABLE ENTRY/IHS
. ; Adjustment Type
. S $P(BARADJ(BARACNT),U,5)=$$VAL^XBDIQ1(90052.02,$P(BARFR0,U,2),.01)
S BARACNT=$G(BARTMP) ; Last entry in array
Q
; *********************************************************************
PAYADJQ ;
; Display Payments and Adjustments
S BARADJT=0
I $D(BARPAY) W !!?4,"PAYMENT:",?15,BARPAY
E W !!,"No Payments entered."
I $D(BARADJ) D
. W !!,"ADJUSTMENTS:"
. S J=0
. F S J=$O(BARADJ(J)) Q:'+J D
. . W ?15,+BARADJ(J),?30,$P(BARADJ(J),U,3),?50,$P(BARADJ(J),U,5),!
. . S BARADJT=BARADJT+$P(BARADJ(J),U)
E W !!,"No Adjustments entered."
Q
; *********************************************************************
PAYADJ ; EP
; EP - Ask user for Payment and/or Adjustments.
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
K BARSCAT,BARSCAT2,BARSAMT,BARSTYP,BARSTYP2
D PACOM ; Select Command
I '+BARCOM W !!,"This is a required response.",! G PAYADJ
D:BARPA="Q" PAYADJQ ; Q from "Select Command: P/A/Q"
I BARPA="P" D PAYMNT Q:'+BARPY ; Enter payment amount
I BARPA="A" D Q:'+BARAD Q:'+BARACAT Q:'+BARATYP ; Enter adjustments
. F D Q:'+BARAD Q:'+BARACAT Q:'+BARATYP
. . K BARSAMT,BARSCAT,BARSCAT2,BARSTYP,BARSTYP2
. . D ADJAMT Q:'+BARAD ; Ask Adjustment Amount
. . D ADJCAT Q:'+BARACAT ; Ask Adjustment Category
. . ; If only one type for this category, don't ask TYPE
. . S (BARX,BARJ)=0
. . F S BARX=$O(^BARTBL("D",BARSCAT,BARX)) Q:'+BARX D Q:BARJ>1
. . . S BARJ=BARJ+1
. . . Q:BARJ>1
. . . S BARATYP=1 ; Adjustment Type Entry Flag
. . . S BARSTYP=BARX ; IEN to A/R TABLE ENTRY/IHS
. . . S BARSTYP2=$P($G(^BARTBL(BARSTYP,0)),U) ; Adjustment Type P.OTT HEAT#126384
. . I BARJ>1 D ADJTYP Q:'+BARATYP ; Ask Adjustment Type
. . S BARTMP=BARSCAT_BARSTYP ; Adj cat and typ used for dup chk
. . ; Check to make sure category and type doesn't already exist
. . S I=0
. . F S I=$O(BARADJ(I)) Q:'+I D
. . . S BARTMP2=$P(BARADJ(I),U,2)_$P(BARADJ(I),U,4)
. . . I BARTMP=BARTMP2 D Q
. . . . W !?+5,$J($P(BARADJ(I),U),9,2),?20,$P(BARADJ(I),U,3),?40,$P(BARADJ(I),U,5)_" already exists."
. . . . K DIR
. . . . S DIR(0)="Y"
. . . . S DIR("A")="Replace"
. . . . S DIR("B")="No"
. . . . D ^DIR
. . . . Q:Y'=1
. . . . K BARADJ(I)
. . ; Enter category and type in array
. . S BARACNT=BARACNT+1 ; Counter for entry into Adj array
. . S BARADJ(BARACNT)=BARSAMT_U_BARSCAT_U_BARSCAT2_U_BARSTYP_U_BARSTYP2
Q
; *********************************************************************
PACOM ;
; Select Command for Payment and/or Adjustments.
W !
S BARCOM=1 ; "Select Command: P/A/Q" Entry Flag
K DIR
S DIR(0)="F^1:1"
S DIR("A")="Select Command (P/A/Q)"
S DIR("?")="^D PACOMHLP^BARFPST1"
S DIR("??")="^D PACOMHLP^BARFPST1"
D ^DIR
K DIR
I $D(DUOUT)!(Y="") S BARCOM=0 Q ; "Select Command: P/A/Q" Entry Flag
S BARPA=$S(Y=1:"P",Y="P":"P",Y="p":"P",Y=2:"A",Y="A":"A",Y="y":"Y",Y=3:"Q",Y="Q":"Q",Y="q":"Q",1:"") ; User response to prompt
I BARPA="" D Q ; Invalid user response
. W !
. D PACOMHLP ; Help routine for payment/adjust
. S BARCOM=0 ; "Select Command: P/A/Q" Entry Flag
Q
; *********************************************************************
PACOMHLP ;
; Help for "Select command (P/A/Q)"
W !,"Enter a code from the list."
W !!?5,"Select one of the following:"
W !!?10,"P or 1",?20,"PAYMENT"
W !?10,"A or 2",?20,"ADJUSTMENT"
W !?10,"Q or 3",?20,"QUIT"
Q
; *********************************************************************
PAYMNT ;
; Enter Flat Rate Posting Payment
S BARPY=1
W !
K DIR
S DIR(0)="NAO^-999999999:999999999:2"
S DIR("A")="PAYMENT AMOUNT: "
S:$D(BARPAY) DIR("B")=BARPAY
D ^DIR
K DIR
I $D(DUOUT)!(Y="") S BARPY=0 Q
I Y<0,$$IHS^BARUFUT(DUZ(2)) D STOP S BARPY=0 Q ;MRS:BAR*1.8*10 D158-3
;;;I Y<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP S BARPY=0 Q ;MRS:BAR*1.8*10 D158-3 P.OTT
S BARNPAY=+Y
I '$D(BARIEN) D ;MRS:BAR*1.8*6 DD 4.2.5 Check balance when creating
.I BARNPAY>BARCLIT(19) D WARN("ITEM") Q
.I BARNPAY>BARCL(17) D WARN("BATCH")
I $D(BARIEN) D PAYGNEG ; Check for negative balance
I '$D(BARNPAY) G PAYMNT
S BARPAY=BARNPAY ; Canonic value of payment
Q
; *********************************************************************
PAYGNEG ;
; Check to see that changing payment won't result in negative balance
N BARAPST,BARBAL,BARPAMT
Q:'+$D(^BARFRP(DUZ(2),BARIEN,2,"B",BAREOB)) ; No data
S BARFACT=$O(^BARFRP(DUZ(2),BARIEN,2,"B",BAREOB,""))
S (J,BARBIEN)=0
F S BARBIEN=$O(^BARFRP(DUZ(2),BARIEN,2,BARFACT,3,BARBIEN)) Q:'+BARBIEN S J=J+1
S BARPAMT=$$VAL^XBDIQ1(90054.01,BARIEN,.1)
S:J=0 J=1 ;NO BILLS;MRS:BAR*1.8*6 DD 4.2.5
S BARAPST=J*BARNPAY
S BARBAL=BARPAMT-BARAPST
I BARBAL<0 D WARN("ITEM") ;MRS:BAR*1.8*6 DD 4.2.5
;W !,"Changing the PAYMENT will cause a negative balance for this FRP batch."
;K BARNPAY
Q
; ********************************************************************
ADJAMT ;
; Enter Flat Rate Posting Adjustments
S BARAD=1 ; Adjustment Amount Entry Flag
W !
K DIR
S DIR(0)="NAO^-999999999:999999999:2"
S DIR("A")="ADJUSTMENT AMOUNT: "
; If ??, display Adjustment array w/ Category and Type.
S DIR("??")="^D ADJLIST^BARFPST1"
D ^DIR
K DIR
I $D(DUOUT)!(Y="") S BARAD=0 Q ; Adjustment Amount Entry Flag
S BARSAMT=Y ; Canonic value of Adjustment
Q
; *********************************************************************
ADJLIST ;
; Help for "ADJUSTMENT AMOUNT:"
; List Adjustment array of Amount, Category, Type
I '$D(BARADJ) W !,"No adjustments entered, Please enter a dollar amount." Q
W !,"Adjustments already entered follows: ",!
S J=0
F S J=$O(BARADJ(J)) Q:'+J D
. W !?5,+BARADJ(J),?20,$P(BARADJ(J),U,3),?40,$P(BARADJ(J),U,5)
W !!,"Please enter a dollar amount."
Q
; *********************************************************************
ADJCAT ;
; Select Adjustment Category from 90052.01
N I
S BARACAT=1 ; Adjustment Category Entry Flag
K DIC
S DIC=90052.01 ; A/R TABLE TYPE /IHS File
S DIC(0)="AEQMNZ"
S DIC("A")="Adjustment Category: "
; Screen for only those A/R tables related to Adjustments
S DIC("S")="I "",3,4,13,14,15,16,20,21,22""[("",""_Y_"","")"
D ^DIC
K DIC
I +Y<0 D Q
. W *7
. S BARACAT=0 ; Adjustment Category Entry Flag
. K BARSCAT,BARSCAT2
S BARSCAT=+Y ; IEN to A/R TABLE TYPE
S BARSCAT2=$P(Y,U,2) ; Adjustment Category
Q
; *********************************************************************
ADJTYP ;
; Select Adjustment Tye from 90052.02
S BARATYP=1 ; Adjustment Type Entry Flag
N I
K DIC
S DIC=90052.02 ; A/R TABLE ENTRY /IHS File
S DIC(0)="AEQMNZ"
S DIC("A")="Adjustment Type: "
; Screen for entries that have Category selected above
S DIC("S")="I $P(^(0),U,2)=BARSCAT"
D ^DIC
K DIC
I +Y<0 D Q
. W *7
. K BARSTYP,BARSTYP2
. S BARATYP=0 ; Adjustment Type Entry Flag
S BARSTYP=+Y ; IEN to A/R TABLE ENTRY /IHS file
S BARSTYP2=$P(Y,U,2) ; Adjustment type
Q
WARN(MSG) ;EP; NEW NEGATIVE BALANCE MESSAGE ;MRS:BAR*1.8*6 DD 4.2.5
Q:'$$IHS^BARUFUT(DUZ(2))
;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;IS P.OTT NEG PAYMENT OK?
; FALL THRU: ALL IHS FACILITIES
; TRIBAL WITH FLAG SET
W !?10,"WARNING: PAYMENT AMOUNT EXCEEDS "_MSG_" BALANCE AMOUNT"
W !?24,"PLEASE ENTER A VALID VALUE"
K BARNPAY
Q
STOP ;EP;NEW FUNCTIONALITY TO PREVENT PAYMENT REVERSALS ;MRS:BAR*1.8*10 D158-3
;
W !?10,"PAYMENT REVERSALS ARE NO LONGER ALLOWED"
W !?24,"PLEASE USE PAYMENT CREDIT ADJUSTMENTS"
K BARNPAY
Q
BARFPST1 ; IHS/SD/LSL - FLAT RATE POSTING (CONT) ; 12/22/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,10,21,23**;OCT 26, 2005
+2 ;; P.OTT Aug 2013 HEAT#126384 FIXED <undef> @ FDIH
+3 ;
+4 QUIT
+5 ; *********************************************************************
PAYADJD ; EP
+1 ; EP - Display payment/adjustment in FRP file
+2 ; Adjustment array counter
SET BARACNT=0
+3 ; If existing Flat Rate Posting entry
IF $DATA(BARIEN)
Begin DoDot:1
+4 ; Payment
SET BARPAY=$$VAL^XBDIQ1(90054.01,BARIEN,.09)
+5 ; Build Adjustment Array
DO PAYADJA
+6 ; Display array
DO PAYADJQ
End DoDot:1
+7 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+8 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+9 QUIT
+10 ; *********************************************************************
PAYADJA ;
+1 ; Build Adjustment array from FRP file
+2 NEW BARTMP
+3 FOR
SET BARACNT=$ORDER(^BARFRP(DUZ(2),BARIEN,1,BARACNT))
IF '+BARACNT
QUIT
Begin DoDot:1
+4 SET BARTMP=BARACNT
+5 SET BARFR0=$GET(^BARFRP(DUZ(2),BARIEN,1,BARACNT,0))
+6 ; Adjustment amount
SET $PIECE(BARADJ(BARACNT),U)=$PIECE(BARFR0,U,3)
+7 ; IEN to A/R TABLE TYPE/IHS
SET $PIECE(BARADJ(BARACNT),U,2)=$PIECE(BARFR0,U)
+8 ; Adjustment Category
+9 SET $PIECE(BARADJ(BARACNT),U,3)=$$VAL^XBDIQ1(90052.01,$PIECE(BARFR0,U),.01)
+10 ; IEN to A/R TABLE ENTRY/IHS
SET $PIECE(BARADJ(BARACNT),U,4)=$PIECE(BARFR0,U,2)
+11 ; Adjustment Type
+12 SET $PIECE(BARADJ(BARACNT),U,5)=$$VAL^XBDIQ1(90052.02,$PIECE(BARFR0,U,2),.01)
End DoDot:1
+13 ; Last entry in array
SET BARACNT=$GET(BARTMP)
+14 QUIT
+15 ; *********************************************************************
PAYADJQ ;
+1 ; Display Payments and Adjustments
+2 SET BARADJT=0
+3 IF $DATA(BARPAY)
WRITE !!?4,"PAYMENT:",?15,BARPAY
+4 IF '$TEST
WRITE !!,"No Payments entered."
+5 IF $DATA(BARADJ)
Begin DoDot:1
+6 WRITE !!,"ADJUSTMENTS:"
+7 SET J=0
+8 FOR
SET J=$ORDER(BARADJ(J))
IF '+J
QUIT
Begin DoDot:2
+9 WRITE ?15,+BARADJ(J),?30,$PIECE(BARADJ(J),U,3),?50,$PIECE(BARADJ(J),U,5),!
+10 SET BARADJT=BARADJT+$PIECE(BARADJ(J),U)
End DoDot:2
End DoDot:1
+11 IF '$TEST
WRITE !!,"No Adjustments entered."
+12 QUIT
+13 ; *********************************************************************
PAYADJ ; EP
+1 ; EP - Ask user for Payment and/or Adjustments.
+2 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+3 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+4 KILL BARSCAT,BARSCAT2,BARSAMT,BARSTYP,BARSTYP2
+5 ; Select Command
DO PACOM
+6 IF '+BARCOM
WRITE !!,"This is a required response.",!
GOTO PAYADJ
+7 ; Q from "Select Command: P/A/Q"
IF BARPA="Q"
DO PAYADJQ
+8 ; Enter payment amount
IF BARPA="P"
DO PAYMNT
IF '+BARPY
QUIT
+9 ; Enter adjustments
IF BARPA="A"
Begin DoDot:1
+10 FOR
Begin DoDot:2
+11 KILL BARSAMT,BARSCAT,BARSCAT2,BARSTYP,BARSTYP2
+12 ; Ask Adjustment Amount
DO ADJAMT
IF '+BARAD
QUIT
+13 ; Ask Adjustment Category
DO ADJCAT
IF '+BARACAT
QUIT
+14 ; If only one type for this category, don't ask TYPE
+15 SET (BARX,BARJ)=0
+16 FOR
SET BARX=$ORDER(^BARTBL("D",BARSCAT,BARX))
IF '+BARX
QUIT
Begin DoDot:3
+17 SET BARJ=BARJ+1
+18 IF BARJ>1
QUIT
+19 ; Adjustment Type Entry Flag
SET BARATYP=1
+20 ; IEN to A/R TABLE ENTRY/IHS
SET BARSTYP=BARX
+21 ; Adjustment Type P.OTT HEAT#126384
SET BARSTYP2=$PIECE($GET(^BARTBL(BARSTYP,0)),U)
End DoDot:3
IF BARJ>1
QUIT
+22 ; Ask Adjustment Type
IF BARJ>1
DO ADJTYP
IF '+BARATYP
QUIT
+23 ; Adj cat and typ used for dup chk
SET BARTMP=BARSCAT_BARSTYP
+24 ; Check to make sure category and type doesn't already exist
+25 SET I=0
+26 FOR
SET I=$ORDER(BARADJ(I))
IF '+I
QUIT
Begin DoDot:3
+27 SET BARTMP2=$PIECE(BARADJ(I),U,2)_$PIECE(BARADJ(I),U,4)
+28 IF BARTMP=BARTMP2
Begin DoDot:4
+29 WRITE !?+5,$JUSTIFY($PIECE(BARADJ(I),U),9,2),?20,$PIECE(BARADJ(I),U,3),?40,$PIECE(BARADJ(I),U,5)_" already exists."
+30 KILL DIR
+31 SET DIR(0)="Y"
+32 SET DIR("A")="Replace"
+33 SET DIR("B")="No"
+34 DO ^DIR
+35 IF Y'=1
QUIT
+36 KILL BARADJ(I)
End DoDot:4
QUIT
End DoDot:3
+37 ; Enter category and type in array
+38 ; Counter for entry into Adj array
SET BARACNT=BARACNT+1
+39 SET BARADJ(BARACNT)=BARSAMT_U_BARSCAT_U_BARSCAT2_U_BARSTYP_U_BARSTYP2
End DoDot:2
IF '+BARAD
QUIT
IF '+BARACAT
QUIT
IF '+BARATYP
QUIT
End DoDot:1
IF '+BARAD
QUIT
IF '+BARACAT
QUIT
IF '+BARATYP
QUIT
+40 QUIT
+41 ; *********************************************************************
PACOM ;
+1 ; Select Command for Payment and/or Adjustments.
+2 WRITE !
+3 ; "Select Command: P/A/Q" Entry Flag
SET BARCOM=1
+4 KILL DIR
+5 SET DIR(0)="F^1:1"
+6 SET DIR("A")="Select Command (P/A/Q)"
+7 SET DIR("?")="^D PACOMHLP^BARFPST1"
+8 SET DIR("??")="^D PACOMHLP^BARFPST1"
+9 DO ^DIR
+10 KILL DIR
+11 ; "Select Command: P/A/Q" Entry Flag
IF $DATA(DUOUT)!(Y="")
SET BARCOM=0
QUIT
+12 ; User response to prompt
SET BARPA=$SELECT(Y=1:"P",Y="P":"P",Y="p":"P",Y=2:"A",Y="A":"A",Y="y":"Y",Y=3:"Q",Y="Q":"Q",Y="q":"Q",1:"")
+13 ; Invalid user response
IF BARPA=""
Begin DoDot:1
+14 WRITE !
+15 ; Help routine for payment/adjust
DO PACOMHLP
+16 ; "Select Command: P/A/Q" Entry Flag
SET BARCOM=0
End DoDot:1
QUIT
+17 QUIT
+18 ; *********************************************************************
PACOMHLP ;
+1 ; Help for "Select command (P/A/Q)"
+2 WRITE !,"Enter a code from the list."
+3 WRITE !!?5,"Select one of the following:"
+4 WRITE !!?10,"P or 1",?20,"PAYMENT"
+5 WRITE !?10,"A or 2",?20,"ADJUSTMENT"
+6 WRITE !?10,"Q or 3",?20,"QUIT"
+7 QUIT
+8 ; *********************************************************************
PAYMNT ;
+1 ; Enter Flat Rate Posting Payment
+2 SET BARPY=1
+3 WRITE !
+4 KILL DIR
+5 SET DIR(0)="NAO^-999999999:999999999:2"
+6 SET DIR("A")="PAYMENT AMOUNT: "
+7 IF $DATA(BARPAY)
SET DIR("B")=BARPAY
+8 DO ^DIR
+9 KILL DIR
+10 IF $DATA(DUOUT)!(Y="")
SET BARPY=0
QUIT
+11 ;MRS:BAR*1.8*10 D158-3
IF Y<0
IF $$IHS^BARUFUT(DUZ(2))
DO STOP
SET BARPY=0
QUIT
+12 ;;;I Y<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP S BARPY=0 Q ;MRS:BAR*1.8*10 D158-3 P.OTT
+13 SET BARNPAY=+Y
+14 ;MRS:BAR*1.8*6 DD 4.2.5 Check balance when creating
IF '$DATA(BARIEN)
Begin DoDot:1
+15 IF BARNPAY>BARCLIT(19)
DO WARN("ITEM")
QUIT
+16 IF BARNPAY>BARCL(17)
DO WARN("BATCH")
End DoDot:1
+17 ; Check for negative balance
IF $DATA(BARIEN)
DO PAYGNEG
+18 IF '$DATA(BARNPAY)
GOTO PAYMNT
+19 ; Canonic value of payment
SET BARPAY=BARNPAY
+20 QUIT
+21 ; *********************************************************************
PAYGNEG ;
+1 ; Check to see that changing payment won't result in negative balance
+2 NEW BARAPST,BARBAL,BARPAMT
+3 ; No data
IF '+$DATA(^BARFRP(DUZ(2),BARIEN,2,"B",BAREOB))
QUIT
+4 SET BARFACT=$ORDER(^BARFRP(DUZ(2),BARIEN,2,"B",BAREOB,""))
+5 SET (J,BARBIEN)=0
+6 FOR
SET BARBIEN=$ORDER(^BARFRP(DUZ(2),BARIEN,2,BARFACT,3,BARBIEN))
IF '+BARBIEN
QUIT
SET J=J+1
+7 SET BARPAMT=$$VAL^XBDIQ1(90054.01,BARIEN,.1)
+8 ;NO BILLS;MRS:BAR*1.8*6 DD 4.2.5
IF J=0
SET J=1
+9 SET BARAPST=J*BARNPAY
+10 SET BARBAL=BARPAMT-BARAPST
+11 ;MRS:BAR*1.8*6 DD 4.2.5
IF BARBAL<0
DO WARN("ITEM")
+12 ;W !,"Changing the PAYMENT will cause a negative balance for this FRP batch."
+13 ;K BARNPAY
+14 QUIT
+15 ; ********************************************************************
ADJAMT ;
+1 ; Enter Flat Rate Posting Adjustments
+2 ; Adjustment Amount Entry Flag
SET BARAD=1
+3 WRITE !
+4 KILL DIR
+5 SET DIR(0)="NAO^-999999999:999999999:2"
+6 SET DIR("A")="ADJUSTMENT AMOUNT: "
+7 ; If ??, display Adjustment array w/ Category and Type.
+8 SET DIR("??")="^D ADJLIST^BARFPST1"
+9 DO ^DIR
+10 KILL DIR
+11 ; Adjustment Amount Entry Flag
IF $DATA(DUOUT)!(Y="")
SET BARAD=0
QUIT
+12 ; Canonic value of Adjustment
SET BARSAMT=Y
+13 QUIT
+14 ; *********************************************************************
ADJLIST ;
+1 ; Help for "ADJUSTMENT AMOUNT:"
+2 ; List Adjustment array of Amount, Category, Type
+3 IF '$DATA(BARADJ)
WRITE !,"No adjustments entered, Please enter a dollar amount."
QUIT
+4 WRITE !,"Adjustments already entered follows: ",!
+5 SET J=0
+6 FOR
SET J=$ORDER(BARADJ(J))
IF '+J
QUIT
Begin DoDot:1
+7 WRITE !?5,+BARADJ(J),?20,$PIECE(BARADJ(J),U,3),?40,$PIECE(BARADJ(J),U,5)
End DoDot:1
+8 WRITE !!,"Please enter a dollar amount."
+9 QUIT
+10 ; *********************************************************************
ADJCAT ;
+1 ; Select Adjustment Category from 90052.01
+2 NEW I
+3 ; Adjustment Category Entry Flag
SET BARACAT=1
+4 KILL DIC
+5 ; A/R TABLE TYPE /IHS File
SET DIC=90052.01
+6 SET DIC(0)="AEQMNZ"
+7 SET DIC("A")="Adjustment Category: "
+8 ; Screen for only those A/R tables related to Adjustments
+9 SET DIC("S")="I "",3,4,13,14,15,16,20,21,22""[("",""_Y_"","")"
+10 DO ^DIC
+11 KILL DIC
+12 IF +Y<0
Begin DoDot:1
+13 WRITE *7
+14 ; Adjustment Category Entry Flag
SET BARACAT=0
+15 KILL BARSCAT,BARSCAT2
End DoDot:1
QUIT
+16 ; IEN to A/R TABLE TYPE
SET BARSCAT=+Y
+17 ; Adjustment Category
SET BARSCAT2=$PIECE(Y,U,2)
+18 QUIT
+19 ; *********************************************************************
ADJTYP ;
+1 ; Select Adjustment Tye from 90052.02
+2 ; Adjustment Type Entry Flag
SET BARATYP=1
+3 NEW I
+4 KILL DIC
+5 ; A/R TABLE ENTRY /IHS File
SET DIC=90052.02
+6 SET DIC(0)="AEQMNZ"
+7 SET DIC("A")="Adjustment Type: "
+8 ; Screen for entries that have Category selected above
+9 SET DIC("S")="I $P(^(0),U,2)=BARSCAT"
+10 DO ^DIC
+11 KILL DIC
+12 IF +Y<0
Begin DoDot:1
+13 WRITE *7
+14 KILL BARSTYP,BARSTYP2
+15 ; Adjustment Type Entry Flag
SET BARATYP=0
End DoDot:1
QUIT
+16 ; IEN to A/R TABLE ENTRY /IHS file
SET BARSTYP=+Y
+17 ; Adjustment type
SET BARSTYP2=$PIECE(Y,U,2)
+18 QUIT
WARN(MSG) ;EP; NEW NEGATIVE BALANCE MESSAGE ;MRS:BAR*1.8*6 DD 4.2.5
+1 IF '$$IHS^BARUFUT(DUZ(2))
QUIT
+2 ;;;Q:'$$IHSERA^BARUFUT(DUZ(2)) ;IS P.OTT NEG PAYMENT OK?
+3 ; FALL THRU: ALL IHS FACILITIES
+4 ; TRIBAL WITH FLAG SET
+5 WRITE !?10,"WARNING: PAYMENT AMOUNT EXCEEDS "_MSG_" BALANCE AMOUNT"
+6 WRITE !?24,"PLEASE ENTER A VALID VALUE"
+7 KILL BARNPAY
+8 QUIT
STOP ;EP;NEW FUNCTIONALITY TO PREVENT PAYMENT REVERSALS ;MRS:BAR*1.8*10 D158-3
+1 ;
+2 WRITE !?10,"PAYMENT REVERSALS ARE NO LONGER ALLOWED"
+3 WRITE !?24,"PLEASE USE PAYMENT CREDIT ADJUSTMENTS"
+4 KILL BARNPAY
+5 QUIT
