Routine: BARROLL

BARROLL ; IHS/SD/LSL - ROLLOVER AFTER POSTING - DEC 4,1996 ; [ 02/15/2006  5:57 PM ]

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**20**;OCT 26, 2005

;;

 ; IHS/ASDS/LSL - 06/21/2001 - V1.5 Patch 1 - NOIS NDA-0601-180067

 ;     Allow rollback to function properly

 ; IHS/ASDS/LSL - 11/26/2001 - V1.6 Patch 1 - NOIS BXX-0501-150094

 ;     Resolve <UNDEF>INS2+16^ABMDLCK1

 ; IHS/ASDS/LSL - 12/04/2001 - V1.6 Patch 1 - NOIS NEA-1201-180002

 ;     Find the proper 3PB bill if 3P bill IEN matches but not bill

 ;     name or DOS.

 ; IHS/SD/LSL - 04/04/2002 - V1.6 Patch 2 - NOIS XJG-0302-16095

 ;     Modified to look all possible locations in 3P for bill during

 ;     the rollback process.

 ; IHS/SD/LSL - 09/22/03 - V1.7 Patch 4 - IM11532

 ;      Resolve UNDEF error when rollback occurs at time of posting

 ;      when more than 50 bills have been flagged.  This error should

 ;      not ocur when rolling back from ROL.

 ; *********************************************************************

EN ;EP - rollover posted bills

 S BARQUIT=0

 S BARBLDA=0

 F  S BARBLDA=$O(BARROLL(BARBLDA)) Q:'BARBLDA  D

 .N X S X=$$VAL^XBDIQ1(90050.01,BARBLDA,15) Q:X'=0

 .D SET

 .Q:'$G(BAR3PDA)

 .Q:'$G(BARRAYGO)

 .D BILL

 K BARROLL,BARBLDA,BAR3PNM,BAR3PDA,BARCNT

 ; *********************************************************************

SET ;set rollback status

 K BAR3PDA

 S DIE="^BARBL(DUZ(2),"

 S DA=BARBLDA

 S DR="208////P"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 S BAR3PNM=$$GET1^DIQ(90050.01,BARBLDA,.01)

 S BAR3PNM=$P(BAR3PNM,"-")

 S BAR("3P BILL LOC")=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)

 I BAR("3P BILL LOC")="" D  Q

 . D SETBLRL

 . W *7," ",BAR3PNM," not found in the 3P System"

 . D EOP^BARUTL(0)

 S BAR3PDA=$$GET1^DIQ(90050.01,BARBLDA,17,"I")

 I $P(BAR("3P BILL LOC"),U,2)'=BAR3PDA D

 .S DIE="^BARBL(DUZ(2),"

 .S DA=BARBLDA

 .S DR="17////^S X=$P(BAR(""3P BILL LOC""),"","",2)"

 .S DR=";22////^S X=$P(BAR(""3P BILL LOC""),"","")"

 .S DIDEL=90050

 .D ^DIE

 .K DIDEL

SETE ;

 ; *********************************************************************

 ;** MENU ENTRY -------------------

MENU ;** EP FOR MENU ROLLOVER TO 3-PARTY

 S BARBLDA=""

 S BARQUIT=0,BARCNT=0

 F  S BARBLDA=$O(^BARBL(DUZ(2),"AF","P",BARBLDA)) Q:'BARBLDA  D BILL Q:BARQUIT

 I $G(BARCNT)<1 W !!!!!?14,"*** There are no bills to process for rollover. ***",!!!!!

 K BARCNT

 ; *********************************************************************

BILL ;

 ; needs BARBLDA  builds tr amounts by category

 S BARCNT=+$G(BARCNT)+1

 I '(BARCNT#50) D  Q:BARQUIT

 .W !!,BARCNT,?10,"Bills have been processed for Rollover",!

 .D EOP^BARUTL(0)

 .S:'$G(Y) BARQUIT=1

 K BARBL

 D ENP^XBDIQ1(90050.01,BARBLDA,".01;3;15;17;101;114;108;205;206;207;214","BARBL(","I")

 W !,"CHECKING A/R BILL ",BARBL(.01)

 I $L(BARBL(214)) D  Q

 . W !,"This bill was already rolled over by ",BARBL(214)

 . D SETBLRL

 S BAR3PDA=BARBL(17)

 I BAR3PDA'>0 D  Q

 . W !,BARBL(.01),"   NOT 3P BILL"

 . D EOP^BARUTL(0)

 . K ^TMP($J,"BARRL",BARBLDA)

 . D SETBLRL

 I BARBL(15) D  Q

 .;amt not zero rm P status

 .S DIE=$$DIC^XBDIQ1(90050.01)

 .S DA=BARBLDA

 .S DR="208///@"

 .S DIDEL=90050

 .D ^DIE

 .K DIDEL

 W $$EN^BARVDF("IOF"),!,"Reviewing Bill ",BARBL(.01),?70,BARBLDA

 K BART,BARTM,BARTOT

 D SETVAR

 D DSP Q:$G(BARQUIT)

 D ROLL

 ; *********************************************************************

SETVAR ; EP

 ; ** PAY = PAY - GROUPER + WRITE OFF - REFUND

LOOP ;

 K BARTOT,BARTM

 S BARTRDA=""

 F  S BARTRDA=$O(^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA)) Q:BARTRDA'>0  D TOTAL^BARTR(BARTRDA)

 I '$D(BARBL) D ENP^XBDIQ1(90050.01,BARBLDA,".01;3;15;17;101;108;114;205;206;207;214;17.2","BARBL(","I")

 S BARBILL=$$GET1^DIQ(90050.01,BARBLDA,13)

 ;array rollback to 3P

 S (BARBIL,BARSUM("AMT"))=$G(BARTOT("T49"))

 S (BARPAY,BARSUM("PAY"))=$G(BARTOT("T40"))

 S (BAR3PCR,BARSUM("3P"))=$G(BARTOT("T108"))

 S (BARWO,BARSUM("WO"))=$G(BARTOT("A3"))

 S (BARNP,BARSUM("NP"))=$G(BARTOT("A4"))

 S (BARDED,BARSUM("DED"))=$G(BARTOT("A13"))

 S (BARCOP,BARSUM("COP"))=$G(BARTOT("A14"))

 S (BARPEN,BARSUM("PEN"))=$G(BARTOT("A15"))

 S (BARGRP,BARSUM("GRP"))=$G(BARTOT("A16"))

 S (BARRF,BARSUM("RF"))=$G(BARTOT("A19"))

 S (BARPCR,BARSUM("PCR"))=$G(BARTOT("A20"))

 ;  IHS/SD/PKD 1.8*20 3/11/11 Sent to Collections "A25"

 S (BARSTC,BARSUM("STC"))=$G(BARTOT("A25"))

 ;pay calculated = payments + grouper + refunds + 3p credits + write off + credits

 S BARPCAL=BARPAY+BARGRP+BARRF+BAR3PCR+BARWO+BARPCR

 S BARSUM=BARPCAL

 ; array rollback to 3P

 ; IHS/SD/PKD 1.8*20 Include Sent to Collection in ADJUSTMENTS

 ;adjustments= Non-Pay + Deductable + Co-Pay + Penalty

 ;S BARADJ=BARNP+BARDED+BARCOP+BARPEN

 S BARADJ=BARNP+BARDED+BARCOP+BARPEN+BARSTC

 S BARROLL=BARBILL-BARPCAL

 S BARCBAL=BARBILL-BARPCAL-BARADJ

 ; *********************************************************************

DSP ;

 S BAR3PNM=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 W !,"BILL",?10,$J(BAR3PNM,10)

 W ?25,">PAYMENTS<",?50,">ADJUSTMENTS<"

 W !,"BILLED",?10,$J(BARBILL,10,2)

 W ?25,"3-P CRD",?35,$J(BAR3PCR,10,2),?50,"NON-PAY",?60,$J(BARNP,10,2)

 W !,"PAY TOT",?10,$J(BARPCAL,10,2)

 W ?25,"PAYMENTS",?35,$J(BARPAY,10,2),?50,"DED",?60,$J(BARDED,10,2)

 W !,"ADJ TOT",?10,$J(BARADJ,10,2)

 W ?25,"PAY CRD",?35,$J(BARPCR,10,2)

 W ?50,"CO-PAY",?60,$J(BARCOP,10,2)

 W !,?25,"WR OFFS",?35,$J(BARWO,10,2),?50,"PENALTY",?60,$J(BARPEN,10,2)

 ;IHS/SD/PKD 1.8*20 Print STC in ADJ column, move TOTAL ADJ down 1 line

 ;W !,?25,"GROUPER",?35,$J(BARGRP,10,2),?50,"TOTAL ADJ*",?60,$J(BARADJ,10,2)

 ;W !,?25,"REFUND",?35,$J(BARRF,10,2)

 W !,?25,"GROUPER",?35,$J(BARGRP,10,2),?50,"STC",?60,$J(BARSTC,10,2)

 W !,?25,"REFUND",?35,$J(BARRF,10,2),?50,"TOTAL ADJ*",?60,$J(BARADJ,10,2)

 ;END 1.8*20

 W !,"ROLLOVER",?10,$J(BARROLL,10,2)

 W ?25,"TOTAL PAY*",?35,$J(BARPCAL,10,2),!

 W !,"Pat:",?10,BARBL(101),?40,"Visit Type.: "_$G(BARBL(114))

 W !,?40,"Bill Status: "_$G(BARBL(17.2))

 W !!,?2,"Original bill approved with the following:"

 W !!,?5,"P: ",BARBL(205),!,?5,"S: ",BARBL(206),!,?5,"T: ",BARBL(207)

 I $L(BARBL(214)) W !!,"This bill was already rolled over by ",BARBL(214)

 I $G(BARRAYGO) D EOP^BARUTL(1)

 W !!

DSPE ;

 ; *********************************************************************

ROLL ;** ROLL

 K DIE,DA,DR

 S BAR3PNM=BARBL(.01)

 S:(BAR3PNM["-") BAR3PNM=$P(BAR3PNM,"-")

 S Y=+BAR3PDA

 S DIC=$$DIC^XBDIQ1(9002274.4)

 S DUZO2=DUZ(2)

 S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,0)),U,22)

 S:DUZ(2)="" DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)

 S Y=Y_"^"_DUZ(2)

 S BARGBL=DIC_+Y_")"

 I '$D(@BARGBL) S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,0)),U,8)  ; Parent

 I $D(@BARGBL) D

 . S BARTMP1=$P($G(^ABMDBILL(DUZ(2),+Y,0)),U)    ; 3P bill

 . S BARTMP2=$P($G(^ABMDBILL(DUZ(2),+Y,7)),U)    ; 3P Service date from

 . S BARDOS=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,2)  ; A/R bill DOS Begin

 . I BARTMP1'=BAR3PNM!(BARTMP2'=BARDOS) D

 . . S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)  ; Use parent

 I $D(@BARGBL) D EN^XBNEW("START^ABMAROLL(Y,.BARSUM,BAR3PNM)","Y,BARPCAL,BAR3PNM,BARSUM")

 ; array rollback to 3P

 S DUZ(2)=DUZO2

 D SETBLRL

 ; *********************************************************************

SETBLRL ; EP **set bill as rolled

 K DIC,DR,DA

 S DIE=$$DIC^XBDIQ1(90050.01)

 S DA=BARBLDA

 S DR="208////R;210///NOW;214////^S X=DUZ;209///^S X=+$G(BARROLL)"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 ; *********************************************************************

SUM(BARBLDA)       ;EP display bill summary

 D SETVAR,DSP

BARROLL   ; IHS/SD/LSL - ROLLOVER AFTER POSTING - DEC 4,1996 ; [ 02/15/2006  5:57 PM ]

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**20**;OCT 26, 2005

 +2       ;;

 +3       ; IHS/ASDS/LSL - 06/21/2001 - V1.5 Patch 1 - NOIS NDA-0601-180067

 +4       ;     Allow rollback to function properly

 +5       ;

 +6       ; IHS/ASDS/LSL - 11/26/2001 - V1.6 Patch 1 - NOIS BXX-0501-150094

 +7       ;     Resolve <UNDEF>INS2+16^ABMDLCK1

 +8       ;

 +9       ; IHS/ASDS/LSL - 12/04/2001 - V1.6 Patch 1 - NOIS NEA-1201-180002

 +10      ;     Find the proper 3PB bill if 3P bill IEN matches but not bill

 +11      ;     name or DOS.

 +12      ;

 +13      ; IHS/SD/LSL - 04/04/2002 - V1.6 Patch 2 - NOIS XJG-0302-16095

 +14      ;     Modified to look all possible locations in 3P for bill during

 +15      ;     the rollback process.

 +16      ;

 +17      ; IHS/SD/LSL - 09/22/03 - V1.7 Patch 4 - IM11532

 +18      ;      Resolve UNDEF error when rollback occurs at time of posting

 +19      ;      when more than 50 bills have been flagged.  This error should

 +20      ;      not ocur when rolling back from ROL.

 +21      ;

 +22      ; *********************************************************************

 +23       QUIT

 +24      ;

EN        ;EP - rollover posted bills

 +1        SET BARQUIT=0

 +2        SET BARBLDA=0

 +3        FOR

               SET BARBLDA=$ORDER(BARROLL(BARBLDA))

               IF 'BARBLDA

                   QUIT

               Begin DoDot:1

 +4                NEW X

                   SET X=$$VAL^XBDIQ1(90050.01,BARBLDA,15)

                   IF X'=0

                       QUIT

 +5                DO SET

 +6                IF '$GET(BAR3PDA)

                       QUIT

 +7                IF '$GET(BARRAYGO)

                       QUIT

 +8                DO BILL

               End DoDot:1

 +9        KILL BARROLL,BARBLDA,BAR3PNM,BAR3PDA,BARCNT

 +10       QUIT

 +11      ; *********************************************************************

 +12      ;

SET       ;set rollback status

 +1        KILL BAR3PDA

 +2        SET DIE="^BARBL(DUZ(2),"

 +3        SET DA=BARBLDA

 +4        SET DR="208////P"

 +5        SET DIDEL=90050

 +6        DO ^DIE

 +7        KILL DIDEL

 +8        SET BAR3PNM=$$GET1^DIQ(90050.01,BARBLDA,.01)

 +9        SET BAR3PNM=$PIECE(BAR3PNM,"-")

 +10       SET BAR("3P BILL LOC")=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)

 +11       IF BAR("3P BILL LOC")=""

               Begin DoDot:1

 +12               DO SETBLRL

 +13               WRITE *7," ",BAR3PNM," not found in the 3P System"

 +14               DO EOP^BARUTL(0)

               End DoDot:1

               QUIT

 +15       SET BAR3PDA=$$GET1^DIQ(90050.01,BARBLDA,17,"I")

 +16       IF $PIECE(BAR("3P BILL LOC"),U,2)'=BAR3PDA

               Begin DoDot:1

 +17               SET DIE="^BARBL(DUZ(2),"

 +18               SET DA=BARBLDA

 +19               SET DR="17////^S X=$P(BAR(""3P BILL LOC""),"","",2)"

 +20               SET DR=";22////^S X=$P(BAR(""3P BILL LOC""),"","")"

 +21               SET DIDEL=90050

 +22               DO ^DIE

 +23               KILL DIDEL

               End DoDot:1

 +24      ;

SETE      ;

 +1        QUIT

 +2       ; *********************************************************************

 +3       ;

 +4       ;** MENU ENTRY -------------------

MENU      ;** EP FOR MENU ROLLOVER TO 3-PARTY

 +1        SET BARBLDA=""

 +2        SET BARQUIT=0

           SET BARCNT=0

 +3        FOR

               SET BARBLDA=$ORDER(^BARBL(DUZ(2),"AF","P",BARBLDA))

               IF 'BARBLDA

                   QUIT

               DO BILL

               IF BARQUIT

                   QUIT

 +4        IF $GET(BARCNT)<1

               WRITE !!!!!?14,"*** There are no bills to process for rollover. ***",!!!!!

 +5        KILL BARCNT

 +6        QUIT

 +7       ; *********************************************************************

 +8       ;

BILL      ;

 +1       ; needs BARBLDA  builds tr amounts by category

 +2        SET BARCNT=+$GET(BARCNT)+1

 +3        IF '(BARCNT#50)

               Begin DoDot:1

 +4                WRITE !!,BARCNT,?10,"Bills have been processed for Rollover",!

 +5                DO EOP^BARUTL(0)

 +6                IF '$GET(Y)

                       SET BARQUIT=1

               End DoDot:1

               IF BARQUIT

                   QUIT

 +7        KILL BARBL

 +8        DO ENP^XBDIQ1(90050.01,BARBLDA,".01;3;15;17;101;114;108;205;206;207;214","BARBL(","I")

 +9        WRITE !,"CHECKING A/R BILL ",BARBL(.01)

 +10      ;

 +11       IF $LENGTH(BARBL(214))

               Begin DoDot:1

 +12               WRITE !,"This bill was already rolled over by ",BARBL(214)

 +13               DO SETBLRL

               End DoDot:1

               QUIT

 +14      ;

 +15       SET BAR3PDA=BARBL(17)

 +16       IF BAR3PDA'>0

               Begin DoDot:1

 +17               WRITE !,BARBL(.01),"   NOT 3P BILL"

 +18               DO EOP^BARUTL(0)

 +19               KILL ^TMP($JOB,"BARRL",BARBLDA)

 +20               DO SETBLRL

               End DoDot:1

               QUIT

 +21      ;

 +22       IF BARBL(15)

               Begin DoDot:1

 +23      ;amt not zero rm P status

 +24               SET DIE=$$DIC^XBDIQ1(90050.01)

 +25               SET DA=BARBLDA

 +26               SET DR="208///@"

 +27               SET DIDEL=90050

 +28               DO ^DIE

 +29               KILL DIDEL

               End DoDot:1

               QUIT

 +30       WRITE $$EN^BARVDF("IOF"),!,"Reviewing Bill ",BARBL(.01),?70,BARBLDA

 +31       KILL BART,BARTM,BARTOT

 +32       DO SETVAR

 +33       DO DSP

           IF $GET(BARQUIT)

               QUIT

 +34       DO ROLL

 +35       QUIT

 +36      ; *********************************************************************

 +37      ;

SETVAR    ; EP

 +1       ; ** PAY = PAY - GROUPER + WRITE OFF - REFUND

LOOP      ;

 +1        KILL BARTOT,BARTM

 +2        SET BARTRDA=""

 +3        FOR

               SET BARTRDA=$ORDER(^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA))

               IF BARTRDA'>0

                   QUIT

               DO TOTAL^BARTR(BARTRDA)

 +4        IF '$DATA(BARBL)

               DO ENP^XBDIQ1(90050.01,BARBLDA,".01;3;15;17;101;108;114;205;206;207;214;17.2","BARBL(","I")

 +5        SET BARBILL=$$GET1^DIQ(90050.01,BARBLDA,13)

 +6       ;array rollback to 3P

 +7        SET (BARBIL,BARSUM("AMT"))=$GET(BARTOT("T49"))

 +8        SET (BARPAY,BARSUM("PAY"))=$GET(BARTOT("T40"))

 +9        SET (BAR3PCR,BARSUM("3P"))=$GET(BARTOT("T108"))

 +10       SET (BARWO,BARSUM("WO"))=$GET(BARTOT("A3"))

 +11       SET (BARNP,BARSUM("NP"))=$GET(BARTOT("A4"))

 +12       SET (BARDED,BARSUM("DED"))=$GET(BARTOT("A13"))

 +13       SET (BARCOP,BARSUM("COP"))=$GET(BARTOT("A14"))

 +14       SET (BARPEN,BARSUM("PEN"))=$GET(BARTOT("A15"))

 +15       SET (BARGRP,BARSUM("GRP"))=$GET(BARTOT("A16"))

 +16       SET (BARRF,BARSUM("RF"))=$GET(BARTOT("A19"))

 +17       SET (BARPCR,BARSUM("PCR"))=$GET(BARTOT("A20"))

 +18      ;  IHS/SD/PKD 1.8*20 3/11/11 Sent to Collections "A25"

 +19       SET (BARSTC,BARSUM("STC"))=$GET(BARTOT("A25"))

 +20      ;pay calculated = payments + grouper + refunds + 3p credits + write off + credits

 +21       SET BARPCAL=BARPAY+BARGRP+BARRF+BAR3PCR+BARWO+BARPCR

 +22       SET BARSUM=BARPCAL

 +23      ;

 +24      ; array rollback to 3P

 +25      ; IHS/SD/PKD 1.8*20 Include Sent to Collection in ADJUSTMENTS

 +26      ;adjustments= Non-Pay + Deductable + Co-Pay + Penalty

 +27      ;S BARADJ=BARNP+BARDED+BARCOP+BARPEN

 +28       SET BARADJ=BARNP+BARDED+BARCOP+BARPEN+BARSTC

 +29       SET BARROLL=BARBILL-BARPCAL

 +30       SET BARCBAL=BARBILL-BARPCAL-BARADJ

 +31       QUIT

 +32      ; *********************************************************************

 +33      ;

DSP       ;

 +1        SET BAR3PNM=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 +2        WRITE !,"BILL",?10,$JUSTIFY(BAR3PNM,10)

 +3        WRITE ?25,">PAYMENTS<",?50,">ADJUSTMENTS<"

 +4        WRITE !,"BILLED",?10,$JUSTIFY(BARBILL,10,2)

 +5        WRITE ?25,"3-P CRD",?35,$JUSTIFY(BAR3PCR,10,2),?50,"NON-PAY",?60,$JUSTIFY(BARNP,10,2)

 +6        WRITE !,"PAY TOT",?10,$JUSTIFY(BARPCAL,10,2)

 +7        WRITE ?25,"PAYMENTS",?35,$JUSTIFY(BARPAY,10,2),?50,"DED",?60,$JUSTIFY(BARDED,10,2)

 +8        WRITE !,"ADJ TOT",?10,$JUSTIFY(BARADJ,10,2)

 +9        WRITE ?25,"PAY CRD",?35,$JUSTIFY(BARPCR,10,2)

 +10       WRITE ?50,"CO-PAY",?60,$JUSTIFY(BARCOP,10,2)

 +11       WRITE !,?25,"WR OFFS",?35,$JUSTIFY(BARWO,10,2),?50,"PENALTY",?60,$JUSTIFY(BARPEN,10,2)

 +12      ;IHS/SD/PKD 1.8*20 Print STC in ADJ column, move TOTAL ADJ down 1 line

 +13      ;W !,?25,"GROUPER",?35,$J(BARGRP,10,2),?50,"TOTAL ADJ*",?60,$J(BARADJ,10,2)

 +14      ;W !,?25,"REFUND",?35,$J(BARRF,10,2)

 +15       WRITE !,?25,"GROUPER",?35,$JUSTIFY(BARGRP,10,2),?50,"STC",?60,$JUSTIFY(BARSTC,10,2)

 +16       WRITE !,?25,"REFUND",?35,$JUSTIFY(BARRF,10,2),?50,"TOTAL ADJ*",?60,$JUSTIFY(BARADJ,10,2)

 +17      ;END 1.8*20

 +18       WRITE !,"ROLLOVER",?10,$JUSTIFY(BARROLL,10,2)

 +19       WRITE ?25,"TOTAL PAY*",?35,$JUSTIFY(BARPCAL,10,2),!

 +20       WRITE !,"Pat:",?10,BARBL(101),?40,"Visit Type.: "_$GET(BARBL(114))

 +21       WRITE !,?40,"Bill Status: "_$GET(BARBL(17.2))

 +22       WRITE !!,?2,"Original bill approved with the following:"

 +23       WRITE !!,?5,"P: ",BARBL(205),!,?5,"S: ",BARBL(206),!,?5,"T: ",BARBL(207)

 +24       IF $LENGTH(BARBL(214))

               WRITE !!,"This bill was already rolled over by ",BARBL(214)

 +25       IF $GET(BARRAYGO)

               DO EOP^BARUTL(1)

 +26       WRITE !!

 +27      ;

DSPE      ;

 +1        QUIT

 +2       ; *********************************************************************

 +3       ;

ROLL      ;** ROLL

 +1        KILL DIE,DA,DR

 +2        SET BAR3PNM=BARBL(.01)

 +3        IF (BAR3PNM["-")

               SET BAR3PNM=$PIECE(BAR3PNM,"-")

 +4        SET Y=+BAR3PDA

 +5        SET DIC=$$DIC^XBDIQ1(9002274.4)

 +6        SET DUZO2=DUZ(2)

 +7        SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,0)),U,22)

 +8        IF DUZ(2)=""

               SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,8)

 +9        SET Y=Y_"^"_DUZ(2)

 +10       SET BARGBL=DIC_+Y_")"

 +11      ; Parent

           IF '$DATA(@BARGBL)

               SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,0)),U,8)

 +12       IF $DATA(@BARGBL)

               Begin DoDot:1

 +13      ; 3P bill

                   SET BARTMP1=$PIECE($GET(^ABMDBILL(DUZ(2),+Y,0)),U)

 +14      ; 3P Service date from

                   SET BARTMP2=$PIECE($GET(^ABMDBILL(DUZ(2),+Y,7)),U)

 +15      ; A/R bill DOS Begin

                   SET BARDOS=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,2)

 +16               IF BARTMP1'=BAR3PNM!(BARTMP2'=BARDOS)

                       Begin DoDot:2

 +17      ; Use parent

                           SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,8)

                       End DoDot:2

               End DoDot:1

 +18       IF $DATA(@BARGBL)

               DO EN^XBNEW("START^ABMAROLL(Y,.BARSUM,BAR3PNM)","Y,BARPCAL,BAR3PNM,BARSUM")

 +19      ; array rollback to 3P

 +20       SET DUZ(2)=DUZO2

 +21       DO SETBLRL

 +22       QUIT

 +23      ; *********************************************************************

 +24      ;

SETBLRL   ; EP **set bill as rolled

 +1        KILL DIC,DR,DA

 +2        SET DIE=$$DIC^XBDIQ1(90050.01)

 +3        SET DA=BARBLDA

 +4        SET DR="208////R;210///NOW;214////^S X=DUZ;209///^S X=+$G(BARROLL)"

 +5        SET DIDEL=90050

 +6        DO ^DIE

 +7        KILL DIDEL

 +8        QUIT

 +9       ; *********************************************************************

 +10      ;

SUM(BARBLDA) ;EP display bill summary

 +1        DO SETVAR

           DO DSP

 +2        QUIT

BARROLL.m