BARPST4 ; IHS/SD/LSL - POSTING AND ADJUSTMENTS CONTINUED ; 12/29/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,10,20,23**;OCT 26, 2005
;
; *********************************************************************
;
EN ;EP
I '$D(BARTR(BARLIN)) D G ASKCOM^BARPST3
.W *7,!!,"No transactions to Edit."
.D EOP^BARUTL(1)
N BARSEL
S (BARSEL,BARJ)=0
S BARSEL=$$DSPLY(BARLIN)
W !
K DIR ;IHS/SD/TPF BAR*1.8*3 FOUND DURING BETA TESTING
S DIR(0)="N^1:"_BARSEL
D ^DIR
I $D(DUOUT)!$D(DTOUT) G ASKCOM^BARPST3 ;IHS/SD/TPF BAR*1.8*3 FOUND DURING BETA TESTING
S BARSEL=Y
; -------------------------------
PARSE ;
S BARLIN=$O(BARSEL(BARSEL,""))
Q:'BARLIN
S BARV=$O(BARSEL(BARSEL,BARLIN,""))
Q:'BARV
N BARREC
S BARREC=BARTR(BARLIN,BARV)
S BARTYP=$P(BARREC,U,1)
S (BAROAMT,BARAMT)=$P(BARREC,U,2)
S BARCAT=$P(BARREC,U,3)
S BARATYP=$P(BARREC,U,4)
; -------------------------------
;
ASKAMT ;
S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
W !!,BARASK_$J(BARAMT,0,2)_"// " R X:DTIME
I X="" S X=BARAMT
S X=$$AMT^BARPSTU(X)
I X="^" G ASKCOM^BARPST3
I X="?" W *7," Must be a valid number!" G ASKAMT
I BARTYP="P",X<0,$$IHS^BARUFUT(DUZ(2)) D STOP^BARFPST1 G ASKAMT ;MRS:BAR*1.8*10 D158-3 OTT
;;;I BARTYP="P",X<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 G ASKAMT ;MRS:BAR*1.8*10 D158-3 OTT
S BARAMT=X
;
I BARTYP="P" G S1
;
;** adjustment category/type dialog
S DIC("B")=BARCAT
S DIC=90052.01
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Category: "
S DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
K DD,DO
D ^DIC
K DIC
I +Y<0 W *7 W !! G ASKAMT
S BARCAT=+Y
S:BARCAT=16 BARAMT=-BARAMT
S BARX=0,BARJ=0
K BARK
F S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX D Q:BARJ>1
.S BARJ=BARJ+1
.Q:BARJ>1
.S BARK=BARX
I BARJ=1,$G(BARK) S BARATYP=BARK G S1
S DIC("B")=BARATYP
S DIC=90052.02
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Type: "
S DIC("S")="I $P(^(0),U,2)=BARCAT"
K DD,DO
D ^DIC
K DIC
I +Y<0 W *7,!! G ASKAMT
S BARATYP=+Y
;--------------------------------
;
S1 ;
D SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT)
G ASKCOM^BARPST3
; *********************************************************************
;
SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;HEAVILY MODIFIED; BAR*1.8*4 DD 4.1.7.2
;SEE SETTMPO BELOW FOR ORIGINAL CODING
N BARBBAL,BARCLV17,BARITV19,BAREOV4
K BARFLG("BARWARN")
S BARSTOP=0
S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
S BARBBAL=$P(^BARTMP($J,BARDA,BARLIN),U,5)
I BARCAT'=21&(BARCAT'=22) D
.S BARBBAL=BARBBAL+BAROAMT ;ADD BACK TO BAL IF NOT PENDING/GENERAL INFO
.D CKNEG(BARBBAL,BAROAMT,BARAMT) ;CHECK FOR NEGATIVE BALANCES
Q:BARSTOP
;Begin old code;MRS:BAR*1.8*6 IM28960
;I BARTYP="P" D Q:BARSTOP
;.S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT-BAROAMT
;.S BARPMT=BARPMT+BARAMT-BAROAMT
;I BARTYP="A" D
;.S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT-BAROAMT
;.S BARADJ=BARADJ+BARAMT-BAROAMT
;I BARCAT'=21&(BARCAT'=22) D
;.S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT+BAROAMT
;Begin new code;MRS:BAR*1.8*6 IM28960
S BARBBAL=BARBBAL-BARAMT
I BARTYP="P" D
.Q:BAROAMT=BARAMT
.S BARPMT=BARPMT+BARAMT-BAROAMT
.S $P(^BARTMP($J,BARDA,BARLIN),U,6)=BARPMT
.S $P(^BARTMP($J,BARDA,BARLIN),U,5)=BARBBAL
;
I BARTYP="A" D
.Q:BAROAMT=BARAMT
.S BARADJ=BARADJ+BARAMT-BAROAMT
.S $P(^BARTMP($J,BARDA,BARLIN),U,7)=BARADJ
.S:BARCAT'=21&(BARCAT'=22) $P(^BARTMP($J,BARDA,BARLIN),U,5)=BARBBAL
;End changes;MRS:BAR*1.8*6 IM28960
;
S BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
K BAROAMT
Q
;
CKNEG(BARBBAL,BAROAMT,BARAMT) ;EP;CHECK FOR NEGATIVE BALANCES;BAR*1.8*4 DD 4.1.7.2
;
I BARBBAL-BARAMT<0 D I BARTYP'="P" D SURE Q ;BILL BALANCE
.D WARN(4,(BARBBAL-BARAMT))
.I $G(BARZZZZ) D SURE Q ;ENTERING FROM PUC;MRS:BAR*1.8*6 DD 4.2.5
Q:$G(BARZZZZ) ;ENTERING FROM PUC;MRS:BAR*1.8*6 DD 4.2.5
Q:BARTYP'="P" ;ONLY PAYMENTS CHECK BATCH/ITEM
N BARCLV17,BARITV19,BAREOV4
I $G(BARCLV(17))]"" D ;COLLECTION BATCH BALANCE
.;S BARCLV17=BARCLV(17)+BAROAMT
.;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
.S BARCLV17=BARCLV(17)+BAROAMT-BARPMT
.I BARCLV17-BARAMT<0 D WARN(1,(BARCLV17-BARAMT))
I $G(BARITV(19))]"" D ;ITEM BALANCE
.;S BARITV19=BARITV(19)+BAROAMT
.;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
.S BARITV19=BARITV(19)+BAROAMT-BARPMT
.I BARITV19-BARAMT<0 D WARN(2,(BARITV19-BARAMT))
I +$G(BAREOB) D ;VISIT LOCATION BALANCE
.;S BAREOV4=BAREOV(4)+BAROAMT
.;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
.S BAREOV4=BAREOV(4)+BAROAMT-BARPMT
.I BAREOV4-BARAMT<0 D WARN(3,(BAREOV4-BARAMT))
;
SURE ;EP; WARNING MESSAGE
Q:$G(BARZZZZ)="P" ;CHECK CALLED FROM PUC ;BAR*1.8*6 DD 4.2.5
Q:'$G(BARFLG("BARWARN"))
W !
K BARFLG("BARWARN")
K DIR
S DIR(0)="Y"
S DIR("A")="ARE YOU SURE"
S DIR("B")="NO"
D ^DIR
K DIR
I Y'=1 S BARSTOP=1
Q
;
; *********************************************************************
WARN(BARLVL,BARDIF) ;EP - warner MOVED FROM BARPST3A ;BAR*1.8*4 DD 4.1.7.2
I BARLVL=4,'$$IHS^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2
;;;I BARLVL=4,'$$IHSERA^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2 OTT
I '$G(BARFLG("BARWARN")) W !
W *7,!,"Warning - Posted amount exceeds the "
W $S(BARLVL=1:"BATCH",BARLVL=2:"ITEM",BARLVL=3:"LOCATION",1:"BILL")_" balance" ;BAR*1.8*4 DD 4.1.7.2
W " by "_BARDIF_" amount" ;BAR*1.8*4 DD 4.1.7.2
S BARFLG("BARWARN")=1
Q
;
; *********************************************************************
;
DSPLY(BARLIN) ;EP - display temporary buffer
N BARPG,BARJ
S BARPG=0
D HEAD
S (BARJ,BARSEL)=0
F S BARJ=$O(BARTR(BARLIN,BARJ)) Q:'BARJ D
.S BARSEL=BARSEL+1
.W !,?1,BARSEL_"."
.W ?8,$P(BARTR(BARLIN,BARJ),U,1)
.W ?13,$J($P(BARTR(BARLIN,BARJ),U,2),8,2)
.S Y=$P(BARTR(BARLIN,BARJ),U,3)
.I Y W ?25,$E($P(^BAR(90052.01,Y,0),U,1),1,23)
.S Y=$P(BARTR(BARLIN,BARJ),U,4)
.I Y W ?50,$E($P(^BARTBL(Y,0),U,1),1,28)
.S BARSEL(BARSEL,BARLIN,BARJ)=""
Q BARSEL
; *********************************************************************
;
HEAD ;
W $$EN^BARVDF("IOF"),!
S BARPG=BARPG+1
W "Transactions for "_$P(^DPT(+BARPASS,0),U,1)_" from "_$$SDT^BARDUTL($P(BARPASS,U,2))_" to "_$$SDT^BARDUTL($P(BARPASS,U,3))
W ?(IOM-15),"Page: "_BARPG
W !!
W "Trans",?8,"Type",?15,"Amount",?25,"Category",?50,"Adj. Type"
S BARDSH=""
S $P(BARDSH,"-",IOM)=""
W !,BARDSH
Q
;
SETTMPO(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;OLD SETTMP; BAR*1.8*4 DD 4.1.7.2
K BARFLG("BARWARN")
S BARSTOP=0
S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
B1O ;
I BARTYP="P" D Q:BARSTOP
.I (BARCLV(17)-(BARPMT+BARAMT-BAROAMT))<0 D WARN(1)
.I (BARITV(19)-(BARPMT+BARAMT-BAROAMT))<0 D WARN(2)
.I +$G(BAREOB),(BAREOV(4)-(BARPMT+BARAMT-BAROAMT))<0 D WARN(3)
.I $G(BARFLG("BARWARN")) D Q:BARSTOP
..K BARFLG("BARWARN")
..W *7,!!,"Sorry - Exceeding Limits Not Allowed",!!
..D EOP^BARUTL(1)
..S BARSTOP=1
.S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT-BAROAMT
.S BARPMT=BARPMT+BARAMT-BAROAMT
I BARTYP="A" D
.S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT-BAROAMT
.S BARADJ=BARADJ+BARAMT-BAROAMT
S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT+BAROAMT
S BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
K BAROAMT
Q
BARPST4 ; IHS/SD/LSL - POSTING AND ADJUSTMENTS CONTINUED ; 12/29/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,10,20,23**;OCT 26, 2005
+2 ;
+3 ; *********************************************************************
+4 ;
EN ;EP
+1 IF '$DATA(BARTR(BARLIN))
Begin DoDot:1
+2 WRITE *7,!!,"No transactions to Edit."
+3 DO EOP^BARUTL(1)
End DoDot:1
GOTO ASKCOM^BARPST3
+4 NEW BARSEL
+5 SET (BARSEL,BARJ)=0
+6 SET BARSEL=$$DSPLY(BARLIN)
+7 WRITE !
+8 ;IHS/SD/TPF BAR*1.8*3 FOUND DURING BETA TESTING
KILL DIR
+9 SET DIR(0)="N^1:"_BARSEL
+10 DO ^DIR
+11 ;IHS/SD/TPF BAR*1.8*3 FOUND DURING BETA TESTING
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO ASKCOM^BARPST3
+12 SET BARSEL=Y
+13 ; -------------------------------
PARSE ;
+1 SET BARLIN=$ORDER(BARSEL(BARSEL,""))
+2 IF 'BARLIN
QUIT
+3 SET BARV=$ORDER(BARSEL(BARSEL,BARLIN,""))
+4 IF 'BARV
QUIT
+5 NEW BARREC
+6 SET BARREC=BARTR(BARLIN,BARV)
+7 SET BARTYP=$PIECE(BARREC,U,1)
+8 SET (BAROAMT,BARAMT)=$PIECE(BARREC,U,2)
+9 SET BARCAT=$PIECE(BARREC,U,3)
+10 SET BARATYP=$PIECE(BARREC,U,4)
+11 ; -------------------------------
+12 ;
ASKAMT ;
+1 SET BARASK=$SELECT(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+2 WRITE !!,BARASK_$JUSTIFY(BARAMT,0,2)_"// "
READ X:DTIME
+3 IF X=""
SET X=BARAMT
+4 SET X=$$AMT^BARPSTU(X)
+5 IF X="^"
GOTO ASKCOM^BARPST3
+6 IF X="?"
WRITE *7," Must be a valid number!"
GOTO ASKAMT
+7 ;MRS:BAR*1.8*10 D158-3 OTT
IF BARTYP="P"
IF X<0
IF $$IHS^BARUFUT(DUZ(2))
DO STOP^BARFPST1
GOTO ASKAMT
+8 ;;;I BARTYP="P",X<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 G ASKAMT ;MRS:BAR*1.8*10 D158-3 OTT
+9 SET BARAMT=X
+10 ;
+11 IF BARTYP="P"
GOTO S1
+12 ;
+13 ;** adjustment category/type dialog
+14 SET DIC("B")=BARCAT
+15 SET DIC=90052.01
+16 SET DIC(0)="AEMNQZ"
+17 SET DIC("A")="Adjustment Category: "
+18 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
+19 KILL DD,DO
+20 DO ^DIC
+21 KILL DIC
+22 IF +Y<0
WRITE *7
WRITE !!
GOTO ASKAMT
+23 SET BARCAT=+Y
+24 IF BARCAT=16
SET BARAMT=-BARAMT
+25 SET BARX=0
SET BARJ=0
+26 KILL BARK
+27 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+28 SET BARJ=BARJ+1
+29 IF BARJ>1
QUIT
+30 SET BARK=BARX
End DoDot:1
IF BARJ>1
QUIT
+31 IF BARJ=1
IF $GET(BARK)
SET BARATYP=BARK
GOTO S1
+32 SET DIC("B")=BARATYP
+33 SET DIC=90052.02
+34 SET DIC(0)="AEMNQZ"
+35 SET DIC("A")="Adjustment Type: "
+36 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+37 KILL DD,DO
+38 DO ^DIC
+39 KILL DIC
+40 IF +Y<0
WRITE *7,!!
GOTO ASKAMT
+41 SET BARATYP=+Y
+42 ;--------------------------------
+43 ;
S1 ;
+1 DO SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT)
+2 GOTO ASKCOM^BARPST3
+3 ; *********************************************************************
+4 ;
SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;HEAVILY MODIFIED; BAR*1.8*4 DD 4.1.7.2
+1 ;SEE SETTMPO BELOW FOR ORIGINAL CODING
+2 NEW BARBBAL,BARCLV17,BARITV19,BAREOV4
+3 KILL BARFLG("BARWARN")
+4 SET BARSTOP=0
+5 SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+6 SET BARBBAL=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)
+7 IF BARCAT'=21&(BARCAT'=22)
Begin DoDot:1
+8 ;ADD BACK TO BAL IF NOT PENDING/GENERAL INFO
SET BARBBAL=BARBBAL+BAROAMT
+9 ;CHECK FOR NEGATIVE BALANCES
DO CKNEG(BARBBAL,BAROAMT,BARAMT)
End DoDot:1
+10 IF BARSTOP
QUIT
+11 ;Begin old code;MRS:BAR*1.8*6 IM28960
+12 ;I BARTYP="P" D Q:BARSTOP
+13 ;.S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT-BAROAMT
+14 ;.S BARPMT=BARPMT+BARAMT-BAROAMT
+15 ;I BARTYP="A" D
+16 ;.S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT-BAROAMT
+17 ;.S BARADJ=BARADJ+BARAMT-BAROAMT
+18 ;I BARCAT'=21&(BARCAT'=22) D
+19 ;.S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT+BAROAMT
+20 ;Begin new code;MRS:BAR*1.8*6 IM28960
+21 SET BARBBAL=BARBBAL-BARAMT
+22 IF BARTYP="P"
Begin DoDot:1
+23 IF BAROAMT=BARAMT
QUIT
+24 SET BARPMT=BARPMT+BARAMT-BAROAMT
+25 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=BARPMT
+26 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=BARBBAL
End DoDot:1
+27 ;
+28 IF BARTYP="A"
Begin DoDot:1
+29 IF BAROAMT=BARAMT
QUIT
+30 SET BARADJ=BARADJ+BARAMT-BAROAMT
+31 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=BARADJ
+32 IF BARCAT'=21&(BARCAT'=22)
SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=BARBBAL
End DoDot:1
+33 ;End changes;MRS:BAR*1.8*6 IM28960
+34 ;
+35 SET BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
+36 KILL BAROAMT
+37 QUIT
+38 ;
CKNEG(BARBBAL,BAROAMT,BARAMT) ;EP;CHECK FOR NEGATIVE BALANCES;BAR*1.8*4 DD 4.1.7.2
+1 ;
+2 ;BILL BALANCE
IF BARBBAL-BARAMT<0
Begin DoDot:1
+3 DO WARN(4,(BARBBAL-BARAMT))
+4 ;ENTERING FROM PUC;MRS:BAR*1.8*6 DD 4.2.5
IF $GET(BARZZZZ)
DO SURE
QUIT
End DoDot:1
IF BARTYP'="P"
DO SURE
QUIT
+5 ;ENTERING FROM PUC;MRS:BAR*1.8*6 DD 4.2.5
IF $GET(BARZZZZ)
QUIT
+6 ;ONLY PAYMENTS CHECK BATCH/ITEM
IF BARTYP'="P"
QUIT
+7 NEW BARCLV17,BARITV19,BAREOV4
+8 ;COLLECTION BATCH BALANCE
IF $GET(BARCLV(17))]""
Begin DoDot:1
+9 ;S BARCLV17=BARCLV(17)+BAROAMT
+10 ;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
+11 SET BARCLV17=BARCLV(17)+BAROAMT-BARPMT
+12 IF BARCLV17-BARAMT<0
DO WARN(1,(BARCLV17-BARAMT))
End DoDot:1
+13 ;ITEM BALANCE
IF $GET(BARITV(19))]""
Begin DoDot:1
+14 ;S BARITV19=BARITV(19)+BAROAMT
+15 ;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
+16 SET BARITV19=BARITV(19)+BAROAMT-BARPMT
+17 IF BARITV19-BARAMT<0
DO WARN(2,(BARITV19-BARAMT))
End DoDot:1
+18 ;VISIT LOCATION BALANCE
IF +$GET(BAREOB)
Begin DoDot:1
+19 ;S BAREOV4=BAREOV(4)+BAROAMT
+20 ;IHS/OIT/CASSevern/Pieran ran 01/21/2011 bar*1.8*20 BARPMT tracks payments made this session but not posted
+21 SET BAREOV4=BAREOV(4)+BAROAMT-BARPMT
+22 IF BAREOV4-BARAMT<0
DO WARN(3,(BAREOV4-BARAMT))
End DoDot:1
+23 ;
SURE ;EP; WARNING MESSAGE
+1 ;CHECK CALLED FROM PUC ;BAR*1.8*6 DD 4.2.5
IF $GET(BARZZZZ)="P"
QUIT
+2 IF '$GET(BARFLG("BARWARN"))
QUIT
+3 WRITE !
+4 KILL BARFLG("BARWARN")
+5 KILL DIR
+6 SET DIR(0)="Y"
+7 SET DIR("A")="ARE YOU SURE"
+8 SET DIR("B")="NO"
+9 DO ^DIR
+10 KILL DIR
+11 IF Y'=1
SET BARSTOP=1
+12 QUIT
+13 ;
+14 ; *********************************************************************
WARN(BARLVL,BARDIF) ;EP - warner MOVED FROM BARPST3A ;BAR*1.8*4 DD 4.1.7.2
+1 ;BAR*1.8*4 DD 4.1.7.2
IF BARLVL=4
IF '$$IHS^BARUFUT(DUZ(2))
KILL BARFLG("BARWARN")
QUIT
+2 ;;;I BARLVL=4,'$$IHSERA^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2 OTT
+3 IF '$GET(BARFLG("BARWARN"))
WRITE !
+4 WRITE *7,!,"Warning - Posted amount exceeds the "
+5 ;BAR*1.8*4 DD 4.1.7.2
WRITE $SELECT(BARLVL=1:"BATCH",BARLVL=2:"ITEM",BARLVL=3:"LOCATION",1:"BILL")_" balance"
+6 ;BAR*1.8*4 DD 4.1.7.2
WRITE " by "_BARDIF_" amount"
+7 SET BARFLG("BARWARN")=1
+8 QUIT
+9 ;
+10 ; *********************************************************************
+11 ;
DSPLY(BARLIN) ;EP - display temporary buffer
+1 NEW BARPG,BARJ
+2 SET BARPG=0
+3 DO HEAD
+4 SET (BARJ,BARSEL)=0
+5 FOR
SET BARJ=$ORDER(BARTR(BARLIN,BARJ))
IF 'BARJ
QUIT
Begin DoDot:1
+6 SET BARSEL=BARSEL+1
+7 WRITE !,?1,BARSEL_"."
+8 WRITE ?8,$PIECE(BARTR(BARLIN,BARJ),U,1)
+9 WRITE ?13,$JUSTIFY($PIECE(BARTR(BARLIN,BARJ),U,2),8,2)
+10 SET Y=$PIECE(BARTR(BARLIN,BARJ),U,3)
+11 IF Y
WRITE ?25,$EXTRACT($PIECE(^BAR(90052.01,Y,0),U,1),1,23)
+12 SET Y=$PIECE(BARTR(BARLIN,BARJ),U,4)
+13 IF Y
WRITE ?50,$EXTRACT($PIECE(^BARTBL(Y,0),U,1),1,28)
+14 SET BARSEL(BARSEL,BARLIN,BARJ)=""
End DoDot:1
+15 QUIT BARSEL
+16 ; *********************************************************************
+17 ;
HEAD ;
+1 WRITE $$EN^BARVDF("IOF"),!
+2 SET BARPG=BARPG+1
+3 WRITE "Transactions for "_$PIECE(^DPT(+BARPASS,0),U,1)_" from "_$$SDT^BARDUTL($PIECE(BARPASS,U,2))_" to "_$$SDT^BARDUTL($PIECE(BARPASS,U,3))
+4 WRITE ?(IOM-15),"Page: "_BARPG
+5 WRITE !!
+6 WRITE "Trans",?8,"Type",?15,"Amount",?25,"Category",?50,"Adj. Type"
+7 SET BARDSH=""
+8 SET $PIECE(BARDSH,"-",IOM)=""
+9 WRITE !,BARDSH
+10 QUIT
+11 ;
SETTMPO(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;OLD SETTMP; BAR*1.8*4 DD 4.1.7.2
+1 KILL BARFLG("BARWARN")
+2 SET BARSTOP=0
+3 SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
B1O ;
+1 IF BARTYP="P"
Begin DoDot:1
+2 IF (BARCLV(17)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN(1)
+3 IF (BARITV(19)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN(2)
+4 IF +$GET(BAREOB)
IF (BAREOV(4)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN(3)
+5 IF $GET(BARFLG("BARWARN"))
Begin DoDot:2
+6 KILL BARFLG("BARWARN")
+7 WRITE *7,!!,"Sorry - Exceeding Limits Not Allowed",!!
+8 DO EOP^BARUTL(1)
+9 SET BARSTOP=1
End DoDot:2
IF BARSTOP
QUIT
+10 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT-BAROAMT
+11 SET BARPMT=BARPMT+BARAMT-BAROAMT
End DoDot:1
IF BARSTOP
QUIT
+12 IF BARTYP="A"
Begin DoDot:1
+13 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT-BAROAMT
+14 SET BARADJ=BARADJ+BARAMT-BAROAMT
End DoDot:1
+15 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT+BAROAMT
+16 SET BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
+17 KILL BAROAMT
+18 QUIT
