Routine: BARRERL

BARRERL ; IHS/SD/LSL - Bill File Error Checker ; 07/2/2010

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

 ; IHS/ASDS/LSL - 09/11/01 - Version 1.5 Patch 2 - NOIS CGA-0701-110093

 ;     Modified to set 0 node of A/R Bill Error File if it doesn't

 ;     already exist.  This allows the BES to work for all facilities on

 ;     one machine.

 ; IHS/SD/LSL - 12/06/02 - Version 1.7 - NOIS NHA-0601-180049

 ;     Modified to look for 3P bill properly.

 ; JUNE 2013 P.OTT MODIFIED TO ACCOMODATE NEW INSURER TYPE FILE (^AUTTINTY)

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

 W !!,"This option will scan the A/R Bill file for problems and must be"

 W !,"run before printing any of the synchronization reports",!

 I $G(^BARBLER(DUZ(2),"LASTRUN")) D  Q:Y'=1

 .W !,"A/R Bill File error check was last run on "

 .W $$MDT^BARDUTL(^BARBLER(DUZ(2),"LASTRUN")),".",!

 .K DIR

 .S DIR(0)="Y"

 .S DIR("A")="Re-run"

 .S DIR("B")="NO"

 .D ^DIR

 .K DIR

 I '$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),"^",14) D

 .W !!,"Enter Small Balance Amount."

 .S DIE="^BAR(90052.06,DUZ(2),"

 .S DA=DUZ(2)

 .S DR="14//5.00"

 .D ^DIE

 ; -------------------------------

ADT ;ask for date range

 W !!,"Select A/R Bills by DOS Date Range."

 F  D  Q:$G(BARDTOK)

 .K BARSDT,BAREDT,BARDTOK

 .S BARSDT=$$DATE^BARDUTL(1)

 .I BARSDT'>0 S BARDTOK=-1 Q

 .S BAREDT=$$DATE^BARDUTL(2)+.9

 .I BAREDT'>0 S BARDTOK=-1 Q

 .I BAREDT>BARSDT S BARDTOK=1 Q

 .W " ??",*7

 I BARDTOK'>0 K BARSDT,BAREDT,BARDTOK Q

 ; -------------------------------

QUE ;que to taskman

 S ZTRTN="EN^BARRERL"

 S ZTSAVE("BARSDT")=""

 S ZTSAVE("BAREDT")=""

 S ZTDESC="A/R Re-Roll"

 S ZTIO=""

 D ^%ZTLOAD

 W:$G(ZTSK) !,"Task# ",ZTSK," queued.",!

 D EOP^BARUTL(1)

 K BAREDT,BARSDT,BARDTOK

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

EN ;EP - looking for A/R Bills that have problems

 D KILL

 D LOOP

 S ^BARBLER(DUZ(2),"LASTRUN")=DT

 K ^BARBLER(DUZ(2),"RUNNING")

 K BARSDT,BAREDT,BARIDT

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

KILL ;delete existing entries

 S DIK="^BARBLER(DUZ(2),"

 S DA=0

 F  S DA=$O(^BARBLER(DUZ(2),DA)) Q:'DA  D ^DIK

 K ^BARBLER(DUZ(2),"LASTRUN")

 I '$D(^BARBLER(DUZ(2),0)) S ^BARBLER(DUZ(2),0)="A/R BILL ERROR^90050.04P"

 S ^BARBLER(DUZ(2),"RUNNING")=1

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

LOOP ; go thru A/R Bill file

 S BARIDT=BARSDT-.1

 F  S BARIDT=$O(^BARBL(DUZ(2),"E",BARIDT)) Q:'BARIDT!(BARIDT>BAREDT)  D

 .S BARBLDA=0

 .F  S BARBLDA=$O(^BARBL(DUZ(2),"E",BARIDT,BARBLDA)) Q:'BARBLDA  D ONE

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

ONE ;examine one a/r bill for errors

 K BARNO3P

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

N I

 F I=0,1,2 S BAR(I)=$G(^BARBL(DUZ(2),BARBLDA,I))

 S BAR3PNM=$P(BAR(0),"^",1)

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

 S BARBAL=$P(BAR(0),"^",15)

 D SBL

 D NEG

 S BARDOS=$P(BAR(1),U,2)

 S BARPAT=$P(BAR(1),U)

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

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

 . S DA=BARBLDA

 . S DR=".05///1"

 . D ^DIE

 S BAR3PDUZ=$P(BAR("3P LOC"),",")

 S BAR3PDA=$P(BAR("3P LOC"),",",2)

 S BARDUZ2=BAR3PDUZ

 S DA=BARBLDA

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

 S DIQ="BAR("

 S DIQ(0)="IE"

 S DR="3;101"

 D EN^DIQ1

 D MM

 D RR

 K BAR,BAR3P,BARDUZ2,BAR3PNM,BAR3PNMB,BARMM,BARNO3P,BAR3PDA

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

FIXIEN ;attempt to find missing 3p bill

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

MM ;check for 3p/ar mis-matches

N I

 F I=0,2,7 S BAR3P(I)=$G(^ABMDBILL(BARDUZ2,BAR3PDA,I))

 S BAR3PNMB=$P(BAR3P(0),"^",1)

 K BARMM

 S:BAR3PNM'=BAR3PNMB BARMM=1                         ;bill names

 S:$P(BAR3P(0),"^",5)'=$P(BAR(1),"^",1) BARMM=1      ;patient

 S:(($P(BAR3P(2),"^",1)+.005)\.01/100)'=(($P(BAR(0),"^",13)+.005)\.01/100) BARMM=1     ;amt billed

 S:$P(BAR3P(7),"^",1)'=$P(BAR(1),"^",2) BARMM=1      ;dos from

 ;insurer

 ;;;S BARITYP=$P($G(^AUTNINS(+$P(BAR3P(0),"^",8),2)),"^",1)

 S BARINAME=$P($G(^AUTNINS(+$P(BAR3P(0),U,8),0)),"^",1)

 S BARITYPX=$P($G(^AUTNINS(+$P(BAR3P(0),U,8),3)),"^",1) ;PTR TO ^AUTTINTY (.211)

 S BARITYP=$P($G(^AUTTINTY(BARITYPX,0)),U,2) ;P.OTT

 ;I DUZ=838 W !,"BARITYP= ",BARITYP,"  ",$ZR R ASD QUIT  ;------------------>

 I BARITYP'="N" D

 .Q:BARINAME=$G(BAR(90050.01,BARBLDA,3,"E"))

 .S BARMM=1

 I BARITYP="N" D

 .Q:$P(^BARAC(DUZ(2),BAR(90050.01,BARBLDA,3,"I"),0),U)'["DPT("

 .Q:BAR(90050.01,BARBLDA,3,"E")=BAR(90050.01,BARBLDA,101,"E")

 .S BARMM=1

 Q:'$G(BARMM)

 D ADD

 S DR=".04///1"

 D ^DIE

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

SBL ;check for small balance

 Q:BARBAL'>0

 S BARSBL=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),"^",14)

 S:'BARSBL BARSBL=5

 Q:BARBAL>BARSBL

 D ADD

 S DR=".03///1"

 D ^DIE

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

NEG ;check for negative balance

 Q:BARBAL'<0

 D ADD

 S DR=".02///1"

 D ^DIE

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

RR ;check if re-roll is needed

 Q:BARBAL'=0

 Q:$P(BAR3P(0),"^",4)="C"

 Q:$P(BAR3P(0),"^",4)="X"

 Q:$P(BAR(2),"^",8)'="R"

 Q:'+$P(BAR(0),"^",13)

 Q:$G(BARMM)

 D ADD

 S DR=".06///1"

 D ^DIE

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

ADD ;add to a/r bill error file

 S DA=BARBLDA

 Q:+$G(^BARBLER(DUZ(2),DA,0))

 S DIC="^BARBLER(DUZ(2),"

 S DIC(0)="LX"

 S X="`"_DA

 K DD,DO

 D ^DIC

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

DEV ;select device

 S %ZIS="NQ"

 D ^%ZIS

 Q:POP

 I IO'=IO(0) D QUE,HOME^%ZIS Q

 I $D(IO("S")) D

 .S IOP=ION

 .D ^%ZIS

BARRERL   ; IHS/SD/LSL - Bill File Error Checker ; 07/2/2010

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

 +2       ;

 +3       ; IHS/ASDS/LSL - 09/11/01 - Version 1.5 Patch 2 - NOIS CGA-0701-110093

 +4       ;     Modified to set 0 node of A/R Bill Error File if it doesn't

 +5       ;     already exist.  This allows the BES to work for all facilities on

 +6       ;     one machine.

 +7       ;

 +8       ; IHS/SD/LSL - 12/06/02 - Version 1.7 - NOIS NHA-0601-180049

 +9       ;     Modified to look for 3P bill properly.

 +10      ;

 +11      ; JUNE 2013 P.OTT MODIFIED TO ACCOMODATE NEW INSURER TYPE FILE (^AUTTINTY)

 +12      ;

 +13      ; ***********************************************************************

 +14      ;

 +15       WRITE !!,"This option will scan the A/R Bill file for problems and must be"

 +16       WRITE !,"run before printing any of the synchronization reports",!

 +17       IF $GET(^BARBLER(DUZ(2),"LASTRUN"))

               Begin DoDot:1

 +18               WRITE !,"A/R Bill File error check was last run on "

 +19               WRITE $$MDT^BARDUTL(^BARBLER(DUZ(2),"LASTRUN")),".",!

 +20               KILL DIR

 +21               SET DIR(0)="Y"

 +22               SET DIR("A")="Re-run"

 +23               SET DIR("B")="NO"

 +24               DO ^DIR

 +25               KILL DIR

               End DoDot:1

               IF Y'=1

                   QUIT

 +26       IF '$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),"^",14)

               Begin DoDot:1

 +27               WRITE !!,"Enter Small Balance Amount."

 +28               SET DIE="^BAR(90052.06,DUZ(2),"

 +29               SET DA=DUZ(2)

 +30               SET DR="14//5.00"

 +31               DO ^DIE

               End DoDot:1

 +32      ; -------------------------------

 +33      ;

ADT       ;ask for date range

 +1        WRITE !!,"Select A/R Bills by DOS Date Range."

 +2        FOR

               Begin DoDot:1

 +3                KILL BARSDT,BAREDT,BARDTOK

 +4                SET BARSDT=$$DATE^BARDUTL(1)

 +5                IF BARSDT'>0

                       SET BARDTOK=-1

                       QUIT

 +6                SET BAREDT=$$DATE^BARDUTL(2)+.9

 +7                IF BAREDT'>0

                       SET BARDTOK=-1

                       QUIT

 +8                IF BAREDT>BARSDT

                       SET BARDTOK=1

                       QUIT

 +9                WRITE " ??",*7

               End DoDot:1

               IF $GET(BARDTOK)

                   QUIT

 +10       IF BARDTOK'>0

               KILL BARSDT,BAREDT,BARDTOK

               QUIT

 +11      ; -------------------------------

 +12      ;

QUE       ;que to taskman

 +1        SET ZTRTN="EN^BARRERL"

 +2        SET ZTSAVE("BARSDT")=""

 +3        SET ZTSAVE("BAREDT")=""

 +4        SET ZTDESC="A/R Re-Roll"

 +5        SET ZTIO=""

 +6        DO ^%ZTLOAD

 +7        IF $GET(ZTSK)

               WRITE !,"Task# ",ZTSK," queued.",!

 +8        DO EOP^BARUTL(1)

 +9        KILL BAREDT,BARSDT,BARDTOK

 +10       QUIT

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

 +12      ;

EN        ;EP - looking for A/R Bills that have problems

 +1        DO KILL

 +2        DO LOOP

 +3        SET ^BARBLER(DUZ(2),"LASTRUN")=DT

 +4        KILL ^BARBLER(DUZ(2),"RUNNING")

 +5        KILL BARSDT,BAREDT,BARIDT

 +6        QUIT

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

 +8       ;

KILL      ;delete existing entries

 +1        SET DIK="^BARBLER(DUZ(2),"

 +2        SET DA=0

 +3        FOR

               SET DA=$ORDER(^BARBLER(DUZ(2),DA))

               IF 'DA

                   QUIT

               DO ^DIK

 +4        KILL ^BARBLER(DUZ(2),"LASTRUN")

 +5        IF '$DATA(^BARBLER(DUZ(2),0))

               SET ^BARBLER(DUZ(2),0)="A/R BILL ERROR^90050.04P"

 +6        SET ^BARBLER(DUZ(2),"RUNNING")=1

 +7        QUIT

 +8       ; *********************************************************************

 +9       ;

LOOP      ; go thru A/R Bill file

 +1        SET BARIDT=BARSDT-.1

 +2        FOR

               SET BARIDT=$ORDER(^BARBL(DUZ(2),"E",BARIDT))

               IF 'BARIDT!(BARIDT>BAREDT)

                   QUIT

               Begin DoDot:1

 +3                SET BARBLDA=0

 +4                FOR

                       SET BARBLDA=$ORDER(^BARBL(DUZ(2),"E",BARIDT,BARBLDA))

                       IF 'BARBLDA

                           QUIT

                       DO ONE

               End DoDot:1

 +5        QUIT

 +6       ; *********************************************************************

 +7       ;

ONE       ;examine one a/r bill for errors

 +1        KILL BARNO3P

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

 +3        NEW I

 +4        FOR I=0,1,2

               SET BAR(I)=$GET(^BARBL(DUZ(2),BARBLDA,I))

 +5        SET BAR3PNM=$PIECE(BAR(0),"^",1)

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

 +7        SET BARBAL=$PIECE(BAR(0),"^",15)

 +8        DO SBL

 +9        DO NEG

 +10       SET BARDOS=$PIECE(BAR(1),U,2)

 +11       SET BARPAT=$PIECE(BAR(1),U)

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

 +13       IF BAR("3P LOC")=""

               Begin DoDot:1

 +14               SET DA=BARBLDA

 +15               SET DR=".05///1"

 +16               DO ^DIE

               End DoDot:1

               QUIT

 +17       SET BAR3PDUZ=$PIECE(BAR("3P LOC"),",")

 +18       SET BAR3PDA=$PIECE(BAR("3P LOC"),",",2)

 +19       SET BARDUZ2=BAR3PDUZ

 +20       SET DA=BARBLDA

 +21       SET DIC="^BARBL(DUZ(2),"

 +22       SET DIQ="BAR("

 +23       SET DIQ(0)="IE"

 +24       SET DR="3;101"

 +25       DO EN^DIQ1

 +26       DO MM

 +27       DO RR

 +28       KILL BAR,BAR3P,BARDUZ2,BAR3PNM,BAR3PNMB,BARMM,BARNO3P,BAR3PDA

 +29       QUIT

 +30      ; *********************************************************************

 +31      ;

FIXIEN    ;attempt to find missing 3p bill

 +1        QUIT

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

 +3       ;

MM        ;check for 3p/ar mis-matches

 +1        NEW I

 +2        FOR I=0,2,7

               SET BAR3P(I)=$GET(^ABMDBILL(BARDUZ2,BAR3PDA,I))

 +3        SET BAR3PNMB=$PIECE(BAR3P(0),"^",1)

 +4        KILL BARMM

 +5       ;bill names

           IF BAR3PNM'=BAR3PNMB

               SET BARMM=1

 +6       ;patient

           IF $PIECE(BAR3P(0),"^",5)'=$PIECE(BAR(1),"^",1)

               SET BARMM=1

 +7       ;amt billed

           IF (($PIECE(BAR3P(2),"^",1)+.005)\.01/100)'=(($PIECE(BAR(0),"^",13)+.005)\.01/100)

               SET BARMM=1

 +8       ;dos from

           IF $PIECE(BAR3P(7),"^",1)'=$PIECE(BAR(1),"^",2)

               SET BARMM=1

 +9       ;insurer

 +10      ;;;S BARITYP=$P($G(^AUTNINS(+$P(BAR3P(0),"^",8),2)),"^",1)

 +11       SET BARINAME=$PIECE($GET(^AUTNINS(+$PIECE(BAR3P(0),U,8),0)),"^",1)

 +12      ;PTR TO ^AUTTINTY (.211)

           SET BARITYPX=$PIECE($GET(^AUTNINS(+$PIECE(BAR3P(0),U,8),3)),"^",1)

 +13      ;P.OTT

           SET BARITYP=$PIECE($GET(^AUTTINTY(BARITYPX,0)),U,2)

 +14      ;I DUZ=838 W !,"BARITYP= ",BARITYP,"  ",$ZR R ASD QUIT  ;------------------>

 +15       IF BARITYP'="N"

               Begin DoDot:1

 +16               IF BARINAME=$GET(BAR(90050.01,BARBLDA,3,"E"))

                       QUIT

 +17               SET BARMM=1

               End DoDot:1

 +18       IF BARITYP="N"

               Begin DoDot:1

 +19               IF $PIECE(^BARAC(DUZ(2),BAR(90050.01,BARBLDA,3,"I"),0),U)'["DPT("

                       QUIT

 +20               IF BAR(90050.01,BARBLDA,3,"E")=BAR(90050.01,BARBLDA,101,"E")

                       QUIT

 +21               SET BARMM=1

               End DoDot:1

 +22       IF '$GET(BARMM)

               QUIT

 +23       DO ADD

 +24       SET DR=".04///1"

 +25       DO ^DIE

 +26       QUIT

 +27      ; *********************************************************************

 +28      ;

SBL       ;check for small balance

 +1        IF BARBAL'>0

               QUIT

 +2        SET BARSBL=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),"^",14)

 +3        IF 'BARSBL

               SET BARSBL=5

 +4        IF BARBAL>BARSBL

               QUIT

 +5        DO ADD

 +6        SET DR=".03///1"

 +7        DO ^DIE

 +8        QUIT

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

 +10      ;

NEG       ;check for negative balance

 +1        IF BARBAL'<0

               QUIT

 +2        DO ADD

 +3        SET DR=".02///1"

 +4        DO ^DIE

 +5        QUIT

 +6       ; *********************************************************************

 +7       ;

RR        ;check if re-roll is needed

 +1        IF BARBAL'=0

               QUIT

 +2        IF $PIECE(BAR3P(0),"^",4)="C"

               QUIT

 +3        IF $PIECE(BAR3P(0),"^",4)="X"

               QUIT

 +4        IF $PIECE(BAR(2),"^",8)'="R"

               QUIT

 +5        IF '+$PIECE(BAR(0),"^",13)

               QUIT

 +6        IF $GET(BARMM)

               QUIT

 +7        DO ADD

 +8        SET DR=".06///1"

 +9        DO ^DIE

 +10       QUIT

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

 +12      ;

ADD       ;add to a/r bill error file

 +1        SET DA=BARBLDA

 +2        IF +$GET(^BARBLER(DUZ(2),DA,0))

               QUIT

 +3        SET DIC="^BARBLER(DUZ(2),"

 +4        SET DIC(0)="LX"

 +5        SET X="`"_DA

 +6        KILL DD,DO

 +7        DO ^DIC

 +8        QUIT

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

 +10      ;

DEV       ;select device

 +1        SET %ZIS="NQ"

 +2        DO ^%ZIS

 +3        IF POP

               QUIT

 +4        IF IO'=IO(0)

               DO QUE

               DO HOME^%ZIS

               QUIT

 +5        IF $DATA(IO("S"))

               Begin DoDot:1

 +6                SET IOP=ION

 +7                DO ^%ZIS

               End DoDot:1

 +8        QUIT

BARRERL.m