- 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