- 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