BARBAD4 ; IHS/SD/LSL - POSTING AND ADJUSTMENTS CONTINUED ; 12/29/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,10,19,23**;OCT 26, 2005
;
; *********************************************************************
Q
EN ;EP
I '$D(BARTR(BARLIN)) D G ASKCOM^BARBAD3
.W *7,!!,"No transactions to Edit."
.D EOP^BARUTL(1)
N BARSEL
S (BARSEL,BARJ)=0
S BARSEL=$$DSPLY(BARLIN)
W !
K DIR
S DIR(0)="N^1:"_BARSEL
D ^DIR
I $D(DUOUT)!$D(DTOUT) G ASKCOM^BARBAD3 ;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
K DIR
S DIR(0)="NAO^::2"
S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
S DIR("A")=BARASK_$J(BARAMT,0,2)_"// "
S DIR("T")=DTIME
D ^DIR
K DIR
I X="" S X=BARAMT
S X=$$AMT^BARBADU(X)
I X="^" G ASKCOM^BARBAD3
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
;;;I BARTYP="P",X<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 G ASKAMT ;MRS:BAR*1.8*10 D158-3
S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
S BARCAM=0,BARCOAM=0
S BARCAM=$$GET1^DIQ(90050.01,BARDA,15)
S BARCOAM=$O(^BARBL(DUZ(2),BARDA,9,"AAA"),-1)
S:$G(BARCOAM) BARCOAM=$P(^BARBL(DUZ(2),BARDA,9,BARCOAM,0),U,4)
S:'$G(BARCOAM) BARCOAM=0
S BARAMT=X
I (BARAMT'>0) D G:BARAMT'>0 ASKAMT
. W !,"You must enter a value larger than 0."
. D EOP^BARUTL(1)
. Q
I ($P(BARTR(BARLIN,1),U,5)="S")&(BARAMT>BARCAM) D G:($P(BARTR(BARLIN,1),U,5)="S")&(BARAMT>BARCAM) ASKAMT
. W !,"You can't place more than the current bill amount in collections."
. D EOP^BARUTL(1)
. Q
I ($P(BARTR(BARLIN,1),U,5)="V")&(BARAMT>BARCOAM) D G:($P(BARTR(BARLIN,1),U,5)="V")&(BARAMT>BARCOAM) ASKAMT
. W !,"You can't reverse from collections more than what's in there."
. D EOP^BARUTL(1)
. Q
;
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)!(Y=25)"
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^BARBAD3
; *********************************************************************
;
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
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 BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP_U_$P(BARTR(BARLIN,BARV),U,5)_U_$P(BARTR(BARLIN,BARV),U,6)
K BAROAMT
Q
;
CKNEG(BARBBAL,BAROAMT,BARAMT) ;EP;CHECK FOR NEGATIVE BALANCES;BAR*1.8*4 DD 4.1.7.2
;
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
.;I BARCLV17-BARAMT<0 D WARN(1,(BARCLV17-BARAMT))
I $G(BARITV(19))]"" D ;ITEM BALANCE
.S BARITV19=BARITV(19)+BAROAMT
.;I BARITV19-BARAMT<0 D WARN(2,(BARITV19-BARAMT))
I +$G(BAREOB) D ;VISIT LOCATION BALANCE
.S BAREOV4=BAREOV(4)+BAROAMT
.;I BAREOV4-BARAMT<0 D WARN(3,(BAREOV4-BARAMT))
Q
;
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 BARBAD3A ;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
I '$G(BARFLG("BARWARN")) W !
W *7,!,"Warning - Posted amount exceeds the "
;W $S(BARLVL=1:"batch",BARLVL=2:"item",1:"location")_" balance." ;BAR*1.8*4 DD 4.1.7.2
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
BARBAD4 ; IHS/SD/LSL - POSTING AND ADJUSTMENTS CONTINUED ; 12/29/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,10,19,23**;OCT 26, 2005
+2 ;
+3 ; *********************************************************************
+4 QUIT
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^BARBAD3
+4 NEW BARSEL
+5 SET (BARSEL,BARJ)=0
+6 SET BARSEL=$$DSPLY(BARLIN)
+7 WRITE !
+8 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^BARBAD3
+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 ;S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+2 ;W !!,BARASK_$J(BARAMT,0,2)_"// " R X:DTIME
+3 KILL DIR
+4 SET DIR(0)="NAO^::2"
+5 SET BARASK=$SELECT(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+6 SET DIR("A")=BARASK_$JUSTIFY(BARAMT,0,2)_"// "
+7 SET DIR("T")=DTIME
+8 DO ^DIR
+9 KILL DIR
+10 IF X=""
SET X=BARAMT
+11 SET X=$$AMT^BARBADU(X)
+12 IF X="^"
GOTO ASKCOM^BARBAD3
+13 IF X="?"
WRITE *7," Must be a valid number!"
GOTO ASKAMT
+14 ;MRS:BAR*1.8*10 D158-3
IF BARTYP="P"
IF X<0
IF $$IHS^BARUFUT(DUZ(2))
DO STOP^BARFPST1
GOTO ASKAMT
+15 ;;;I BARTYP="P",X<0,$$IHSERA^BARUFUT(DUZ(2)) D STOP^BARFPST1 G ASKAMT ;MRS:BAR*1.8*10 D158-3
+16 SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+17 SET BARCAM=0
SET BARCOAM=0
+18 SET BARCAM=$$GET1^DIQ(90050.01,BARDA,15)
+19 SET BARCOAM=$ORDER(^BARBL(DUZ(2),BARDA,9,"AAA"),-1)
+20 IF $GET(BARCOAM)
SET BARCOAM=$PIECE(^BARBL(DUZ(2),BARDA,9,BARCOAM,0),U,4)
+21 IF '$GET(BARCOAM)
SET BARCOAM=0
+22 SET BARAMT=X
+23 IF (BARAMT'>0)
Begin DoDot:1
+24 WRITE !,"You must enter a value larger than 0."
+25 DO EOP^BARUTL(1)
+26 QUIT
End DoDot:1
IF BARAMT'>0
GOTO ASKAMT
+27 IF ($PIECE(BARTR(BARLIN,1),U,5)="S")&(BARAMT>BARCAM)
Begin DoDot:1
+28 WRITE !,"You can't place more than the current bill amount in collections."
+29 DO EOP^BARUTL(1)
+30 QUIT
End DoDot:1
IF ($PIECE(BARTR(BARLIN,1),U,5)="S")&(BARAMT>BARCAM)
GOTO ASKAMT
+31 IF ($PIECE(BARTR(BARLIN,1),U,5)="V")&(BARAMT>BARCOAM)
Begin DoDot:1
+32 WRITE !,"You can't reverse from collections more than what's in there."
+33 DO EOP^BARUTL(1)
+34 QUIT
End DoDot:1
IF ($PIECE(BARTR(BARLIN,1),U,5)="V")&(BARAMT>BARCOAM)
GOTO ASKAMT
+35 ;
+36 IF BARTYP="P"
GOTO S1
+37 ;
+38 ;** adjustment category/type dialog
+39 SET DIC("B")=BARCAT
+40 SET DIC=90052.01
+41 SET DIC(0)="AEMNQZ"
+42 SET DIC("A")="Adjustment Category: "
+43 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)!(Y=25)"
+44 KILL DD,DO
+45 DO ^DIC
+46 KILL DIC
+47 IF +Y<0
WRITE *7
WRITE !!
GOTO ASKAMT
+48 SET BARCAT=+Y
+49 IF BARCAT=16
SET BARAMT=-BARAMT
+50 SET BARX=0
SET BARJ=0
+51 KILL BARK
+52 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+53 SET BARJ=BARJ+1
+54 IF BARJ>1
QUIT
+55 SET BARK=BARX
End DoDot:1
IF BARJ>1
QUIT
+56 IF BARJ=1
IF $GET(BARK)
SET BARATYP=BARK
GOTO S1
+57 SET DIC("B")=BARATYP
+58 SET DIC=90052.02
+59 SET DIC(0)="AEMNQZ"
+60 SET DIC("A")="Adjustment Type: "
+61 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+62 KILL DD,DO
+63 DO ^DIC
+64 KILL DIC
+65 IF +Y<0
WRITE *7,!!
GOTO ASKAMT
+66 SET BARATYP=+Y
+67 ;--------------------------------
+68 ;
S1 ;
+1 DO SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT)
+2 GOTO ASKCOM^BARBAD3
+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 SET BARBBAL=BARBBAL-BARAMT
+12 IF BARTYP="P"
Begin DoDot:1
+13 IF BAROAMT=BARAMT
QUIT
+14 SET BARPMT=BARPMT+BARAMT-BAROAMT
+15 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=BARPMT
+16 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=BARBBAL
End DoDot:1
+17 ;
+18 IF BARTYP="A"
Begin DoDot:1
+19 IF BAROAMT=BARAMT
QUIT
+20 SET BARADJ=BARADJ+BARAMT-BAROAMT
+21 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=BARADJ
End DoDot:1
+22 ;
+23 SET BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP_U_$PIECE(BARTR(BARLIN,BARV),U,5)_U_$PIECE(BARTR(BARLIN,BARV),U,6)
+24 KILL BAROAMT
+25 QUIT
+26 ;
CKNEG(BARBBAL,BAROAMT,BARAMT) ;EP;CHECK FOR NEGATIVE BALANCES;BAR*1.8*4 DD 4.1.7.2
+1 ;
+2 ;ENTERING FROM PUC;MRS:BAR*1.8*6 DD 4.2.5
IF $GET(BARZZZZ)
QUIT
+3 ;ONLY PAYMENTS CHECK BATCH/ITEM
IF BARTYP'="P"
QUIT
+4 NEW BARCLV17,BARITV19,BAREOV4
+5 ;COLLECTION BATCH BALANCE
IF $GET(BARCLV(17))]""
Begin DoDot:1
+6 SET BARCLV17=BARCLV(17)+BAROAMT
+7 ;I BARCLV17-BARAMT<0 D WARN(1,(BARCLV17-BARAMT))
End DoDot:1
+8 ;ITEM BALANCE
IF $GET(BARITV(19))]""
Begin DoDot:1
+9 SET BARITV19=BARITV(19)+BAROAMT
+10 ;I BARITV19-BARAMT<0 D WARN(2,(BARITV19-BARAMT))
End DoDot:1
+11 ;VISIT LOCATION BALANCE
IF +$GET(BAREOB)
Begin DoDot:1
+12 SET BAREOV4=BAREOV(4)+BAROAMT
+13 ;I BAREOV4-BARAMT<0 D WARN(3,(BAREOV4-BARAMT))
End DoDot:1
+14 QUIT
+15 ;
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 BARBAD3A ;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
+3 IF '$GET(BARFLG("BARWARN"))
WRITE !
+4 WRITE *7,!,"Warning - Posted amount exceeds the "
+5 ;W $S(BARLVL=1:"batch",BARLVL=2:"item",1:"location")_" balance." ;BAR*1.8*4 DD 4.1.7.2
+6 ;BAR*1.8*4 DD 4.1.7.2
WRITE $SELECT(BARLVL=1:"BATCH",BARLVL=2:"ITEM",BARLVL=3:"LOCATION",1:"BILL")_" balance"
+7 ;BAR*1.8*4 DD 4.1.7.2
WRITE " by "_BARDIF_" amount"
+8 SET BARFLG("BARWARN")=1
+9 QUIT
+10 ;
+11 ; *********************************************************************
+12 ;
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
