BARBLOS ; IHS/SD/LSL - REPORT ALL OUTSTANDING BILLS AS OF DATE REQUESTED - JAN 14,1996 ;08/20/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
;;
; IHS/SD/LSL - 12/12/02 - V1.6 Patch 4 - NHA-0601-180049
; Tribal sites still use this report. Removed 3pb search as
; it's not needed and the code does it wrong.
;
; IHS/SD/LSL - 09/04/03 - V1.7 Patch 4 - IM11410
; Resolved <UNDEF>TRANCAL+5^BARBLOS
; MODIFIED TO CHANGE XTMP($J,"BARBLOS" TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
; *********************************************************************
;
D ASK^BARBLOS0
S BARDATE=$$DIR^XBDIR("D","Enter the ending date","SEP 30, 1997",,"Enter the ending date of the fiscal year to be reported","^D HELP^XBHELP(""HELP"",""BARBLOS"")")
Q:'Y
W " ("_$$MDT2^BARDUTL(BARDATE)_")"
;
HELP ;
;;In Jan, 1997, auditors from the Inspector General (OIG) requested
;;a one-time report from all RPMS A/R implementations.
;;Specifically, the information needed by the IG is the amount of
;;monies that were outstanding of the end of a fiscal year (ie.
;;September 30, 1996).
;;
;;The results should be faxed to:
;;Carl Fitzpatrick OAM,HQW at 301-443-9157
;;
;;Also fax a copy to your Area Office
;;###
;
S XBRC="EN^BARBLOS"
S XBRP="PRINT^BARBLOS"
S XBNS="BAR"
S XBRX="EXIT^BARBLOS"
W *7,!!,">> This report takes a while and will be automatically queued! <<",!
D ^XBDBQUE
Q
; *********************************************************************
;
EN ;EP
K ^XTMP("BARBLOS",$J)
D INIT^BARUTL
S BARX="39^40^43^49^108"
S (BARBLDA,BARBLDT,BARDACT,BAR3PNF)=0
F S BARBLDT=$O(^BARBL(DUZ(2),"AG",BARBLDT)) Q:BARBLDT'>0 Q:$E(BARBLDT,1,7)>BARDATE D
. S BARBLDA=0
. F S BARBLDA=$O(^BARBL(DUZ(2),"AG",BARBLDT,BARBLDA)) Q:BARBLDA'>0 D
.. S BARDACT=BARDACT+1 I $E(IOST)="C",IOT["TRM" W "."
.. D SRCHTPB
. Q
S (%DT,X1)=DT
S X="N"
S X2=7
D ^%DT
S Y=X
S:$D(^XTMP("BARBLOS",$J)) ^XTMP("BARBLOS",$J,0)=Y_"^"_DT_"^"_"IG REPORTING DATA"
K X,Y
D HOME^%ZIS
;
ENEXIT ;
Q
; *********************************************************************
;
SRCHTPB ;
D SRCHTRNS
;
SRCHTPBE ;
Q
; *********************************************************************
;
SRCHTRNS ;
; Search the ^BARTR global for type of transaction records for this A/R bill
S (BARDTTM,BARCR,BARDB,BARQUIT,BARACCT,BARCNT,BARXOVR)=0
F S BARDTTM=$O(^BARTR(DUZ(2),"AC",BARBLDA,BARDTTM)) Q:BARDTTM'>0 Q:BARQUIT D
. Q:$P($G(^BARTR(DUZ(2),BARDTTM,0)),U)=""
. S BARCNT=BARCNT+1
. I '$D(^BARTR(DUZ(2),BARDTTM,1)) Q
. D TRANCAL
I BARCNT=0 Q
I '$D(BAR(49,0,0,"DB")) D
. S BAR(49,0,0,"DB")=$$GET1^DIQ(90050.01,BARBLDA,13,"I")
. S:BARACCT=0 BARACCT=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
. S ^XTMP("BARBLOS",$J,"NO49REC",BARBLDA)=""
D CALIT
I BARDB-BARCR<.01 S BARQUIT=1
I '$D(^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")) S ^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")=0
S ^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")=^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")+BARCR
I BARGRP>0 D
. I '$D(^XTMP("BARBLOS",$J,BARACCT,"GROUPER")) S ^XTMP("BARBLOS",$J,BARACCT,"GROUPER")=0
. S ^XTMP("BARBLOS",$J,BARACCT,"GROUPER")=^XTMP("BARBLOS",$J,BARACCT,"GROUPER")+BARGRP
Q
; *********************************************************************
;
PRINT ;
; roll through the ^XTMP("BARBLOS",$J) and report on these records
S BARDATE=BARDATE
D PRINT^BARBLOS1
D TRAN^BARBLOS0
K ^XTMP("BARBLOS",$J)
Q
; *********************************************************************
;
TRANCAL ;
; Determine what type of transaction it is
K BARTEMP
I BARX'[$P(^BARTR(DUZ(2),BARDTTM,1),"^") Q
I BARACCT>0 D
. I BARACCT'=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6) D
.. S BARTEMP=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6)
.. S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP)) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP)=0
.. S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP)=^XTMP("BARBLOS",$J,BARACCT,BARTEMP)+1
.. S BARXOVR=BARXOVR+1
.. D XOVER
I $P(^BARTR(DUZ(2),BARDTTM,1),"^")=49 D
. S BARACCT=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6)
. I '$D(^XTMP("BARBLOS",$J,BARACCT,"BILLED")) S ^XTMP("BARBLOS",$J,BARACCT,"BILLED")=0
. S ^XTMP("BARBLOS",$J,BARACCT,"BILLED")=^XTMP("BARBLOS",$J,BARACCT,"BILLED")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
S BARTTYP=$P(^BARTR(DUZ(2),BARDTTM,1),"^")
S BARTCAT=$P(^BARTR(DUZ(2),BARDTTM,1),"^",2)
S BARTREA=$P(^BARTR(DUZ(2),BARDTTM,1),"^",3)
S:BARTCAT="" BARTCAT=0
S:BARTREA="" BARTREA=0
I $P(^BARTR(DUZ(2),BARDTTM,0),"^",3)'="" D
. S:'$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BAR(BARTTYP,BARTCAT,BARTREA,"DB")=0
. S BAR(BARTTYP,BARTCAT,BARTREA,"DB")=BAR(BARTTYP,BARTCAT,BARTREA,"DB")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
I $P(^BARTR(DUZ(2),BARDTTM,0),"^",2)'="" D
. S:'$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BAR(BARTTYP,BARTCAT,BARTREA,"CR")=0
. S BAR(BARTTYP,BARTCAT,BARTREA,"CR")=BAR(BARTTYP,BARTCAT,BARTREA,"CR")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",2)
Q
; *********************************************************************
;
CALIT ;Calculate the Debits and Credits
S (BARDB,BARCR,BARGRP)=0
S BARTTYP=38
F S BARTTYP=$O(BAR(BARTTYP)) Q:BARTTYP="" D
. S BARTCAT=""
. F S BARTCAT=$O(BAR(BARTTYP,BARTCAT)) Q:BARTCAT="" D
.. S BARTREA=""
.. F S BARTREA=$O(BAR(BARTTYP,BARTCAT,BARTREA)) Q:BARTREA="" D
... I BARTTYP=49 D
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARDB=BARDB+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARDB=BARDB-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
... I BARTTYP'=49 D
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARCR=BARCR-BAR(BARTTYP,BARTCAT,BARTREA,"DB")
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARCR=BARCR+BAR(BARTTYP,BARTCAT,BARTREA,"CR")
... I BARTCAT=16 D
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARGRP=BARGRP+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
.... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARGRP=BARGRP-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
... K BAR(BARTTYP,BARTCAT,BARTREA)
Q
; *********************************************************************
;
XOVER ;
; Accumulate cross over dollars, ie-dollars billed to one insurer and paid by another insurer
I BARXOVR=1 D
. S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")=0
. S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")+BAR(49,0,0,"DB")
I $P(^BARTR(DUZ(2),BARDTTM,0),"^",3)'="" D
. S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")=0
. S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
I $P(^BARTR(DUZ(2),BARDTTM,0),"^",2)'="" D
. S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")=0
. S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",2)
Q
; *********************************************************************
;
EXIT ; Exit routine
Q
BARBLOS ; IHS/SD/LSL - REPORT ALL OUTSTANDING BILLS AS OF DATE REQUESTED - JAN 14,1996 ;08/20/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
+2 ;;
+3 ; IHS/SD/LSL - 12/12/02 - V1.6 Patch 4 - NHA-0601-180049
+4 ; Tribal sites still use this report. Removed 3pb search as
+5 ; it's not needed and the code does it wrong.
+6 ;
+7 ; IHS/SD/LSL - 09/04/03 - V1.7 Patch 4 - IM11410
+8 ; Resolved <UNDEF>TRANCAL+5^BARBLOS
+9 ; MODIFIED TO CHANGE XTMP($J,"BARBLOS" TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
+10 ; *********************************************************************
+11 ;
+12 DO ASK^BARBLOS0
+13 SET BARDATE=$$DIR^XBDIR("D","Enter the ending date","SEP 30, 1997",,"Enter the ending date of the fiscal year to be reported","^D HELP^XBHELP(""HELP"",""BARBLOS"")")
+14 IF 'Y
QUIT
+15 WRITE " ("_$$MDT2^BARDUTL(BARDATE)_")"
+16 ;
HELP ;
+1 ;;In Jan, 1997, auditors from the Inspector General (OIG) requested
+2 ;;a one-time report from all RPMS A/R implementations.
+3 ;;Specifically, the information needed by the IG is the amount of
+4 ;;monies that were outstanding of the end of a fiscal year (ie.
+5 ;;September 30, 1996).
+6 ;;
+7 ;;The results should be faxed to:
+8 ;;Carl Fitzpatrick OAM,HQW at 301-443-9157
+9 ;;
+10 ;;Also fax a copy to your Area Office
+11 ;;###
+12 ;
+13 SET XBRC="EN^BARBLOS"
+14 SET XBRP="PRINT^BARBLOS"
+15 SET XBNS="BAR"
+16 SET XBRX="EXIT^BARBLOS"
+17 WRITE *7,!!,">> This report takes a while and will be automatically queued! <<",!
+18 DO ^XBDBQUE
+19 QUIT
+20 ; *********************************************************************
+21 ;
EN ;EP
+1 KILL ^XTMP("BARBLOS",$JOB)
+2 DO INIT^BARUTL
+3 SET BARX="39^40^43^49^108"
+4 SET (BARBLDA,BARBLDT,BARDACT,BAR3PNF)=0
+5 FOR
SET BARBLDT=$ORDER(^BARBL(DUZ(2),"AG",BARBLDT))
IF BARBLDT'>0
QUIT
IF $EXTRACT(BARBLDT,1,7)>BARDATE
QUIT
Begin DoDot:1
+6 SET BARBLDA=0
+7 FOR
SET BARBLDA=$ORDER(^BARBL(DUZ(2),"AG",BARBLDT,BARBLDA))
IF BARBLDA'>0
QUIT
Begin DoDot:2
+8 SET BARDACT=BARDACT+1
IF $EXTRACT(IOST)="C"
IF IOT["TRM"
WRITE "."
+9 DO SRCHTPB
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET (%DT,X1)=DT
+12 SET X="N"
+13 SET X2=7
+14 DO ^%DT
+15 SET Y=X
+16 IF $DATA(^XTMP("BARBLOS",$JOB))
SET ^XTMP("BARBLOS",$JOB,0)=Y_"^"_DT_"^"_"IG REPORTING DATA"
+17 KILL X,Y
+18 DO HOME^%ZIS
+19 ;
ENEXIT ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
SRCHTPB ;
+1 DO SRCHTRNS
+2 ;
SRCHTPBE ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
SRCHTRNS ;
+1 ; Search the ^BARTR global for type of transaction records for this A/R bill
+2 SET (BARDTTM,BARCR,BARDB,BARQUIT,BARACCT,BARCNT,BARXOVR)=0
+3 FOR
SET BARDTTM=$ORDER(^BARTR(DUZ(2),"AC",BARBLDA,BARDTTM))
IF BARDTTM'>0
QUIT
IF BARQUIT
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^BARTR(DUZ(2),BARDTTM,0)),U)=""
QUIT
+5 SET BARCNT=BARCNT+1
+6 IF '$DATA(^BARTR(DUZ(2),BARDTTM,1))
QUIT
+7 DO TRANCAL
End DoDot:1
+8 IF BARCNT=0
QUIT
+9 IF '$DATA(BAR(49,0,0,"DB"))
Begin DoDot:1
+10 SET BAR(49,0,0,"DB")=$$GET1^DIQ(90050.01,BARBLDA,13,"I")
+11 IF BARACCT=0
SET BARACCT=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
+12 SET ^XTMP("BARBLOS",$JOB,"NO49REC",BARBLDA)=""
End DoDot:1
+13 DO CALIT
+14 IF BARDB-BARCR<.01
SET BARQUIT=1
+15 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,"COLLECTED"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,"COLLECTED")=0
+16 SET ^XTMP("BARBLOS",$JOB,BARACCT,"COLLECTED")=^XTMP("BARBLOS",$JOB,BARACCT,"COLLECTED")+BARCR
+17 IF BARGRP>0
Begin DoDot:1
+18 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,"GROUPER"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,"GROUPER")=0
+19 SET ^XTMP("BARBLOS",$JOB,BARACCT,"GROUPER")=^XTMP("BARBLOS",$JOB,BARACCT,"GROUPER")+BARGRP
End DoDot:1
+20 QUIT
+21 ; *********************************************************************
+22 ;
PRINT ;
+1 ; roll through the ^XTMP("BARBLOS",$J) and report on these records
+2 SET BARDATE=BARDATE
+3 DO PRINT^BARBLOS1
+4 DO TRAN^BARBLOS0
+5 KILL ^XTMP("BARBLOS",$JOB)
+6 QUIT
+7 ; *********************************************************************
+8 ;
TRANCAL ;
+1 ; Determine what type of transaction it is
+2 KILL BARTEMP
+3 IF BARX'[$PIECE(^BARTR(DUZ(2),BARDTTM,1),"^")
QUIT
+4 IF BARACCT>0
Begin DoDot:1
+5 IF BARACCT'=$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",6)
Begin DoDot:2
+6 SET BARTEMP=$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",6)
+7 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP))
SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP)=0
+8 SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP)=^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP)+1
+9 SET BARXOVR=BARXOVR+1
+10 DO XOVER
End DoDot:2
End DoDot:1
+11 IF $PIECE(^BARTR(DUZ(2),BARDTTM,1),"^")=49
Begin DoDot:1
+12 SET BARACCT=$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",6)
+13 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,"BILLED"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,"BILLED")=0
+14 SET ^XTMP("BARBLOS",$JOB,BARACCT,"BILLED")=^XTMP("BARBLOS",$JOB,BARACCT,"BILLED")+$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",3)
End DoDot:1
+15 SET BARTTYP=$PIECE(^BARTR(DUZ(2),BARDTTM,1),"^")
+16 SET BARTCAT=$PIECE(^BARTR(DUZ(2),BARDTTM,1),"^",2)
+17 SET BARTREA=$PIECE(^BARTR(DUZ(2),BARDTTM,1),"^",3)
+18 IF BARTCAT=""
SET BARTCAT=0
+19 IF BARTREA=""
SET BARTREA=0
+20 IF $PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",3)'=""
Begin DoDot:1
+21 IF '$DATA(BAR(BARTTYP,BARTCAT,BARTREA,"DB"))
SET BAR(BARTTYP,BARTCAT,BARTREA,"DB")=0
+22 SET BAR(BARTTYP,BARTCAT,BARTREA,"DB")=BAR(BARTTYP,BARTCAT,BARTREA,"DB")+$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",3)
End DoDot:1
+23 IF $PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",2)'=""
Begin DoDot:1
+24 IF '$DATA(BAR(BARTTYP,BARTCAT,BARTREA,"CR"))
SET BAR(BARTTYP,BARTCAT,BARTREA,"CR")=0
+25 SET BAR(BARTTYP,BARTCAT,BARTREA,"CR")=BAR(BARTTYP,BARTCAT,BARTREA,"CR")+$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",2)
End DoDot:1
+26 QUIT
+27 ; *********************************************************************
+28 ;
CALIT ;Calculate the Debits and Credits
+1 SET (BARDB,BARCR,BARGRP)=0
+2 SET BARTTYP=38
+3 FOR
SET BARTTYP=$ORDER(BAR(BARTTYP))
IF BARTTYP=""
QUIT
Begin DoDot:1
+4 SET BARTCAT=""
+5 FOR
SET BARTCAT=$ORDER(BAR(BARTTYP,BARTCAT))
IF BARTCAT=""
QUIT
Begin DoDot:2
+6 SET BARTREA=""
+7 FOR
SET BARTREA=$ORDER(BAR(BARTTYP,BARTCAT,BARTREA))
IF BARTREA=""
QUIT
Begin DoDot:3
+8 IF BARTTYP=49
Begin DoDot:4
+9 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"DB"))
SET BARDB=BARDB+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
+10 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"CR"))
SET BARDB=BARDB-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
End DoDot:4
+11 IF BARTTYP'=49
Begin DoDot:4
+12 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"DB"))
SET BARCR=BARCR-BAR(BARTTYP,BARTCAT,BARTREA,"DB")
+13 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"CR"))
SET BARCR=BARCR+BAR(BARTTYP,BARTCAT,BARTREA,"CR")
End DoDot:4
+14 IF BARTCAT=16
Begin DoDot:4
+15 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"DB"))
SET BARGRP=BARGRP+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
+16 IF $DATA(BAR(BARTTYP,BARTCAT,BARTREA,"CR"))
SET BARGRP=BARGRP-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
End DoDot:4
+17 KILL BAR(BARTTYP,BARTCAT,BARTREA)
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ; *********************************************************************
+20 ;
XOVER ;
+1 ; Accumulate cross over dollars, ie-dollars billed to one insurer and paid by another insurer
+2 IF BARXOVR=1
Begin DoDot:1
+3 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"BILL"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"BILL")=0
+4 SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"BILL")=^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"BILL")+BAR(49,0,0,"DB")
End DoDot:1
+5 IF $PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",3)'=""
Begin DoDot:1
+6 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"DB"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"DB")=0
+7 SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"DB")=^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"DB")+$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",3)
End DoDot:1
+8 IF $PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",2)'=""
Begin DoDot:1
+9 IF '$DATA(^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"CR"))
SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"CR")=0
+10 SET ^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"CR")=^XTMP("BARBLOS",$JOB,BARACCT,BARTEMP,"CR")+$PIECE(^BARTR(DUZ(2),BARDTTM,0),"^",2)
End DoDot:1
+11 QUIT
+12 ; *********************************************************************
+13 ;
EXIT ; Exit routine
+1 QUIT
