BARPUC4 ; IHS/SD/LSL - UNALLOCATED POSTING CONTINUED ; 08/22/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,7**;OCT 26, 2005
;
; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
; Allow new adjustment categories 21 and 22
;
; IHS/SD/LSL - 06/23/03 - V1.7 Patch 2 - IM10402
; Insert press return to continue if exceed limits message
;
; *********************************************************************
;
EN ;EP - editing of temporary buffer
I '$D(BARTR(BARLIN)) D G ASKCOM^BARPUC3
.W *7,!!,"No transactions to Edit."
.D EOP^BARUTL(1)
N BARSEL
S (BARSEL,BARJ)=0
S BARSEL=$$DSPLY(BARLIN)
W !
S DIR(0)="N^1:"_BARSEL
D ^DIR
I $D(DUOUT) G ASKCOM^BARPUC3
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^BARPUCU(X) ;MRS:BAR*1.8*6 DD 4.2.5
S X=$$AMT^BARPUCU(X,0,BARTX(2)) ;MRS:BAR*1.8*6 DD 4.2.5
I X="^" G ASKCOM^BARPUC3
I X="?" W *7," Must be a valid number!" G ASKAMT
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 ;grouper
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) ;BAR*1.8*4 DD 4.1.7.2
D SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;BAR*1.8*4 DD 4.1.7.2
G ASKCOM^BARPUC3
; *********************************************************************
;
SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;HEAVILY MODIFIED;BAR*1.8*4 DD 4.1.7.2
K BARFLG("BARWARN")
S BARSTOP=0
S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
; -------------------------------
B1 ;
S BARZZZZ=1 ;MRS:BAR*1.8*6 DD 4.2.6
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^BARPST4(BARBBAL,BAROAMT,BARAMT) ;CHECK FOR NEGATIVE BALANCES
Q:BARSTOP
I BARTYP="P" D
.Q:BAROAMT=BARAMT ;AMOUNT NOT CHANGED;MRS:BAR*1.8*7 IM30227
.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
.Q:BAROAMT=BARAMT ;AMOUNT NOT CHANGED;MRS:BAR*1.8*7 IM30227
.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
S BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
K BAROAMT,BARBBAL
Q
; *********************************************************************
;
DSPLY(BARLIN) ;EP
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
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 !!,"Trans",?8,"Type",?15,"Amount",?25,"Category",?50,"Adj. Type"
S BARDSH=""
S $P(BARDSH,"-",IOM)=""
W !,BARDSH
Q
SETTMP0(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ; ORIGINAL CODE ;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^BARPST3A(1)
.I (BARITV(19)-(BARPMT+BARAMT-BAROAMT))<0 D WARN^BARPST3A(2)
.I +$G(BAREOB),(BAREOV(4)-(BARPMT+BARAMT-BAROAMT))<0 D WARN^BARPST3A(3)
.I $G(BARFLG("BARWARN")) D Q:BARSTOP
..K BARFLG("BARWARN")
..W *7,!!,"Sorry - Exceeding Limits Not Allowed",!!
.. D PAZ^BARRUTL
..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,BARBBAL
Q
BARPUC4 ; IHS/SD/LSL - UNALLOCATED POSTING CONTINUED ; 08/22/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,7**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
+4 ; Allow new adjustment categories 21 and 22
+5 ;
+6 ; IHS/SD/LSL - 06/23/03 - V1.7 Patch 2 - IM10402
+7 ; Insert press return to continue if exceed limits message
+8 ;
+9 ; *********************************************************************
+10 ;
EN ;EP - editing of temporary buffer
+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^BARPUC3
+4 NEW BARSEL
+5 SET (BARSEL,BARJ)=0
+6 SET BARSEL=$$DSPLY(BARLIN)
+7 WRITE !
+8 SET DIR(0)="N^1:"_BARSEL
+9 DO ^DIR
+10 IF $DATA(DUOUT)
GOTO ASKCOM^BARPUC3
+11 SET BARSEL=Y
+12 ; -------------------------------
+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 ;S X=$$AMT^BARPUCU(X) ;MRS:BAR*1.8*6 DD 4.2.5
+5 ;MRS:BAR*1.8*6 DD 4.2.5
SET X=$$AMT^BARPUCU(X,0,BARTX(2))
+6 IF X="^"
GOTO ASKCOM^BARPUC3
+7 IF X="?"
WRITE *7," Must be a valid number!"
GOTO ASKAMT
+8 SET BARAMT=X
+9 IF BARTYP="P"
GOTO S1
+10 ; -------------------------------
+11 ;
+12 ;** adjustment category/type dialog
+13 SET DIC("B")=BARCAT
+14 SET DIC=90052.01
+15 SET DIC(0)="AEMNQZ"
+16 SET DIC("A")="Adjustment Category: "
+17 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
+18 KILL DD,DO
+19 DO ^DIC
+20 KILL DIC
+21 IF +Y<0
WRITE *7
WRITE !!
GOTO ASKAMT
+22 SET BARCAT=+Y
+23 ;grouper
IF BARCAT=16
SET BARAMT=-BARAMT
+24 SET BARX=0
SET BARJ=0
+25 KILL BARK
+26 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+27 SET BARJ=BARJ+1
+28 IF BARJ>1
QUIT
+29 SET BARK=BARX
End DoDot:1
IF BARJ>1
QUIT
+30 IF BARJ=1
IF $GET(BARK)
SET BARATYP=BARK
GOTO S1
+31 SET DIC("B")=BARATYP
+32 SET DIC=90052.02
+33 SET DIC(0)="AEMNQZ"
+34 SET DIC("A")="Adjustment Type: "
+35 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+36 KILL DD,DO
+37 DO ^DIC
+38 KILL DIC
+39 IF +Y<0
WRITE *7,!!
GOTO ASKAMT
+40 SET BARATYP=+Y
+41 ; -------------------------------
+42 ;
S1 ;
+1 ;D SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;BAR*1.8*4 DD 4.1.7.2
+2 ;BAR*1.8*4 DD 4.1.7.2
DO SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT)
+3 GOTO ASKCOM^BARPUC3
+4 ; *********************************************************************
+5 ;
SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;HEAVILY MODIFIED;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,""))
+4 ; -------------------------------
B1 ;
+1 ;MRS:BAR*1.8*6 DD 4.2.6
SET BARZZZZ=1
+2 SET BARBBAL=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)
+3 IF BARCAT'=21&(BARCAT'=22)
Begin DoDot:1
+4 ;ADD BACK TO BAL IF NOT PENDING/GENERAL INFO
SET BARBBAL=BARBBAL+BAROAMT
+5 ;CHECK FOR NEGATIVE BALANCES
DO CKNEG^BARPST4(BARBBAL,BAROAMT,BARAMT)
End DoDot:1
+6 IF BARSTOP
QUIT
+7 IF BARTYP="P"
Begin DoDot:1
+8 ;AMOUNT NOT CHANGED;MRS:BAR*1.8*7 IM30227
IF BAROAMT=BARAMT
QUIT
+9 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT-BAROAMT
+10 SET BARPMT=BARPMT+BARAMT-BAROAMT
End DoDot:1
+11 IF BARTYP="A"
Begin DoDot:1
+12 ;AMOUNT NOT CHANGED;MRS:BAR*1.8*7 IM30227
IF BAROAMT=BARAMT
QUIT
+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 IF BARCAT'=21&(BARCAT'=22)
Begin DoDot:1
+16 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT+BAROAMT
End DoDot:1
+17 SET BARTR(BARLIN,BARV)=BARTYP_U_BARAMT_U_BARCAT_U_BARATYP
+18 KILL BAROAMT,BARBBAL
+19 QUIT
+20 ; *********************************************************************
+21 ;
DSPLY(BARLIN) ;EP
+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)=""
+15 QUIT
End DoDot:1
+16 QUIT BARSEL
+17 ; *********************************************************************
+18 ;
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 !!,"Trans",?8,"Type",?15,"Amount",?25,"Category",?50,"Adj. Type"
+6 SET BARDSH=""
+7 SET $PIECE(BARDSH,"-",IOM)=""
+8 WRITE !,BARDSH
+9 QUIT
SETTMP0(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ; ORIGINAL CODE ;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,""))
+4 ; -------------------------------
B1O ;
+1 IF BARTYP="P"
Begin DoDot:1
+2 IF (BARCLV(17)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN^BARPST3A(1)
+3 IF (BARITV(19)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN^BARPST3A(2)
+4 IF +$GET(BAREOB)
IF (BAREOV(4)-(BARPMT+BARAMT-BAROAMT))<0
DO WARN^BARPST3A(3)
+5 IF $GET(BARFLG("BARWARN"))
Begin DoDot:2
+6 KILL BARFLG("BARWARN")
+7 WRITE *7,!!,"Sorry - Exceeding Limits Not Allowed",!!
+8 DO PAZ^BARRUTL
+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,BARBBAL
+18 QUIT
