Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARFPST1

BARFPST1.m

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