Routine: IBCEMSR

IBCEMSR ;WOIFO/AAT - MRA STATISTICS REPORT ;09/03/04

 ;;2.0;INTEGRATED BILLING;**155,288,294,349,447**;21-MAR-94;Build 80

 ;;Per VHA Directive 2004-038, this routine should not be modified.

EN ;

 N IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR

 W !!,"Report requires 132 Columns"

 S IBQ=0 ; quit flag

 ; Prompts to the user:

 D DIV Q:IBQ  ; Division(s)

 D SUM Q:IBQ  ; Summary only?

 W !!,"Normal processing time for a MRA is 10-12 days.  If you select a date range of"

 W !,"less than 2 weeks, do not expect to have received many MRAs."

 D DTR Q:IBQ  ; From-To date range

 D DEVICE Q:IBQ

 D RUN

DIV N DIC,DIR,DIRUT,Y

 W ! S DIR("B")="ALL",DIR("A")="Run this report for All divisions or Selected Divisions: "

 S DIR(0)="SA^ALL:All divisions;S:Selected divisions" D ^DIR

 I $D(DIRUT) S IBQ=1 Q

 S IBDIV=Y Q:Y="ALL"

 ; Collect divisions

 F  D  Q:Y'>0

 . W ! S DIC("A")="Division: ",DIC=40.8,DIC(0)="AEQM" D ^DIC

 . I $D(DIRUT) S IBQ=1 Q

 . I Y'>0 Q

 . S IBDIV(+Y)=""

 I $O(IBDIV(""))=""  S IBQ=1 Q  ; None selected

DTR ;date range

 N %DT,Y

 S (IBBDT,IBEDT)=DT

 S %DT="AEX"

 S %DT("A")="Start with MRA Request Transmission Date: " ; No default,%DT("B")="TODAY"

 W ! D ^%DT K %DT

 I Y<0 S IBQ=1 Q

 S IBBDT=+Y

 S %DT="AEX"

 S %DT("A")="Go to MRA Request Transmission Date: ",%DT("B")="TODAY"

 D ^%DT K %DT

 I Y<0 S IBQ=1 Q

 S IBEDT=+Y

SUM N DIR,DIRUT,Y

 W ! S DIR("B")="YES",DIR("A")="Do you want to print a summary only? "

 S DIR(0)="YA" D ^DIR

 I $D(DIRUT) S IBQ=1 Q

 S IBSUM=+Y

DEVICE N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP

 K IO("Q")

 S %ZIS="QM"

 W ! D ^%ZIS

 I POP S IBQ=1 Q

 S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)

 I $D(IO("Q")) D  S IBQ=1

 . S ZTRTN="RUN^IBCEMSR"

 . S ZTIO=ION

 . S ZTSAVE("IB*")=""

 . S ZTDESC="IB MRA STATISTICS REPORT"

 . D ^%ZTLOAD

 . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")

 . D HOME^%ZIS

 U IO

RUN N REF

 S REF=$NA(^TMP($J,"IBCEMSR"))

 K @REF

 D COLLECT  ; Collect the data in ^TMP

 U IO

 D REPORT^IBCEMSR1

 I 'IBSCR W !,@IOF

 D ^%ZISC

 K @REF

COLLECT ; Collect Information

 ; Input: IBDIV, IBBDT,IBEDT

 N IBDT,IBBAT,IBTRAN,IBZ,MRAUSR,NUMDIV,IBDV,ALLDIV

 S IBDV=0 F NUMDIV=0:1 S IBDV=$O(IBDIV(IBDV)) Q:'IBDV

 S ALLDIV=" "

 I IBDIV="ALL" S ALLDIV="  *** ALL DIVISIONS ***"

 I NUMDIV>1 S ALLDIV="  *** ALL SELECTED DIVISIONS ***"

 S MRAUSR=$$MRAUSR^IBCEMU1() ;Auto-authorizer

 S IBDT=IBBDT-.000001

 F  S IBDT=$O(^IBA(364.1,"ALT",IBDT)) Q:'IBDT  Q:IBDT\1>IBEDT  D

 . S IBBAT=0 F  S IBBAT=$O(^IBA(364.1,"ALT",IBDT,IBBAT)) Q:'IBBAT  D

 .. S IBTRAN=0 F  S IBTRAN=$O(^IBA(364,"C",IBBAT,IBTRAN)) Q:'IBTRAN  D

 ... S IBZ=$G(^IBA(364,IBTRAN,0)) Q:IBZ=""

 ... N IBIFN,IBSTAT,IBSEQ,IBBILZ,IBBILST,IBFORM,IBCLERK,IBDV,IBDVN,REFX,REFS,REFT,REFTX,MRACNT,IBREJECT

 ... S IBIFN=+IBZ

 ... I '$P($G(^DGCR(399,IBIFN,"S")),U,7) Q  ; no MRA request

 ... S IBSTAT=$P(IBZ,U,3)

 ... S IBSEQ=$P(IBZ,U,8) Q:"T"[IBSEQ

 ... I '$$WNRBILL^IBEFUNC(IBIFN,IBSEQ) Q   ; payer sequence must be Medicare for this transmission

 ... S IBBILZ=$G(^DGCR(399,IBIFN,0))

 ... S IBBILST=$P(IBBILZ,U,13)

 ... S IBFORM=+$P(IBBILZ,U,19)

 ... I IBFORM'=2,IBFORM'=3 Q  ; not 1500 or UB

 ... S IBCLERK=+$P($G(^DGCR(399,IBIFN,"S")),U,8) ; Who requested MRA?

 ... S IBCLERK=$P($G(^VA(200,IBCLERK,0)),U)

 ... S:IBCLERK="" IBCLERK="UNKNOWN"

 ... S IBDV=+$P(IBBILZ,U,22) ; Default division

 ... S IBDVN=$P($G(^DG(40.8,IBDV,0)),U) ; Div name

 ... S:IBDVN="" IBDVN="UNKNOWN"

 ... I IBDIV'="ALL",'$D(IBDIV(IBDV)) Q  ;Division filter

 ... I 'IBSUM S REFX=$NA(@REF@(IBDVN,IBCLERK,IBFORM)) I NUMDIV'=1 S REFTX=$NA(@REF@(ALLDIV,IBCLERK,IBFORM))  ; all divisions detail

 ... S REFS=$NA(@REF@(IBDVN,0,IBFORM)) ; Summary by division

 ... I NUMDIV'=1 S REFT=$NA(@REF@(ALLDIV,0,IBFORM))  ; all divisions

 ... D TXSTS^IBCEMU2(IBIFN,IBTRAN,.IBREJECT) ; rejected?

 ... S MRACNT=$$MRACNT^IBCEMU1(IBIFN) ; how many MRAs?

 ... D INC("ALL") ; total no of requests

 ... I IBSTAT="C" D INC("ALLC") ;cancelled

 ... I IBSTAT="R" D INC("ALLR") ;resubmitted

 ... I '$D(@REFS@("TOT",IBIFN)) S ^(IBIFN)="" D INC("TOT") ;unique requests

 ... ;no response?

 ... I 'IBREJECT,'MRACNT,'$D(@REFS@("NON",IBIFN)) S ^(IBIFN)="" D INC("NON")

 ... ;final reject?

 ... I 'MRACNT,IBREJECT,'$D(@REFS@("REJF",IBIFN)),IBTRAN=$$LAST364^IBCEF4(IBIFN) D

 .... S @REFS@("REJF",IBIFN)="" D INC("REJF")

 .... ; MRA?

 ... I MRACNT,'$D(@REFS@("MRA",IBIFN)) S ^(IBIFN)="" D

 .... D INC("MRA")

 .... I $$DENIED(IBIFN) D INC("MRAD")

 ... ;any secondary claims?

 ... D SECOND

INC(NODE,VALUE) ;Increase the respective value in ^TMP

 I 'IBSUM D

 . S @REFX@(NODE)=$G(@REFX@(NODE))+$G(VALUE,1)

 . I $D(REFTX) S @REFTX@(NODE)=$G(@REFTX@(NODE))+$G(VALUE,1)

. Q

 S @REFS@(NODE)=$G(@REFS@(NODE))+$G(VALUE,1)

 I $D(REFT) S @REFT@(NODE)=$G(@REFT@(NODE))+$G(VALUE,1)

DENIED(IBIFN) ;MRA requests denied?

 ; 361.1 for this bill#

 ; if at least one request is 'processed' - MRA is NOT DENIED

 N IBDEN,IEN,IBZ

 S IBDEN=1

 S IEN=0 F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D  Q:'IBDEN

 . S IBZ=$G(^IBM(361.1,IEN,0))

 . I $P(IBZ,U,4)'=1 Q  ; only MEDICARE

 . I $P(IBZ,U,13)=1 S IBDEN=0

 Q IBDEN

SECOND ;Secondary claims

 N IBAUT,IBTX,IBCBPS,IBNEXT,IBBILS,IBTOT,IBUNR,IB2ND,IBNODE,IBGRPN,IBTYPLN,IBPRP

 I $D(@REFS@("SEC",IBIFN)) Q  ; Already included

 S IBCBPS=$P(IBBILZ,U,21) ; current bill sequence

 S IBNEXT=$S(IBSEQ="S":"T",1:"S") ;Next (after MRA) sequence

 I IBCBPS'=IBNEXT Q

 ; Number of unique sec claims

 S @REFS@("SEC",IBIFN)=""

 D INC("SEC")

 S IBBILS=$G(^DGCR(399,IBIFN,"S")) Q:'$P(IBBILS,U,10)  ; Not even authorized

 ; Authorized but not yet printed?

 I $P(IBBILS,U,10),'$P(IBBILS,U,13) D  Q

 . I +$$TXMT^IBCEF4(IBIFN)'=1 D INC("AUT") ; Exclude transmittable

 ; Check the field 'AUTHORIZER'

 S IBAUT=($P(IBBILS,U,11)=MRAUSR) ; Auto-authorized?

 S IBTX=$$TRANSM(IBIFN,IBNEXT) ; Transmitted? (present in 364?)

 I IBAUT,IBTX S IBNODE="AT"   ; Auto-gen Tx

 I 'IBAUT,IBTX S IBNODE="MT"  ; Manually Tx

 I IBAUT,'IBTX S IBNODE="AP"  ; Auto-gen Prn

 I 'IBAUT,'IBTX S IBNODE="MP" ; Manually Prn

 ;Calculate amounts

 S IBTOT=+$G(^DGCR(399,IBIFN,"U1"))

 S IBUNR=$P($G(^PRCA(430,IBIFN,13)),U,2) ; Medicare Unreimbursable

 ; IB*2.0*447 calculate differently for claims w/Medicare supplemental, need plan type now and prior payments

 ;S IB2ND=$$PREOBTOT^IBCEU0(IBIFN)

 S IBGRPN=+$P($G(^DGCR(399,IBIFN,"I"_$S(IBCBPS="S":2,IBCBPS="T":3,1:1))),U,18),IBTYPLN=$P($G(^IBA(355.3,IBGRPN,0)),U,9)

 S IBPRP=$P($G(^DGCR(399,IBIFN,"U2")),U,4) S:IBCBPS="T" IBPRP=IBPRP+$P($G(^DGCR(399,IBIFN,"U2")),U,5)

 ; if current payer is primary, or prior payments are a negative amt., set prior payments to 0

 I IBCBPS="P"!(IBPRP<0) S IBPRP=0

 ; if plan type does NOT have any special calculations, just calculate the old way (PR only)

 S IB2ND=$S($$MSEDT^IBCEMU4(IBIFN,IBTYPLN)'="":IBTOT-IBPRP,1:$$PREOBTOT^IBCEU0(IBIFN))

 D INC(IBNODE)

 D INC(IBNODE_"1",IBTOT)

 D INC(IBNODE_"2",IBUNR)

 D INC(IBNODE_"3",IB2ND)

TRANSM(IBIFN,IBSEQ) ;was the claim ever transmitted?

 ; Does the claim present in 364?

 N RES,IBI

 S RES=0

 S IBI="" F  S IBI=$O(^IBA(364,"B",IBIFN,IBI),-1) Q:IBI=""  D  Q:RES

 . I $P($G(^IBA(364,IBI,0)),U,8)=IBSEQ S RES=1

 Q RES

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMSR   7326     printed  Apr 23, 2025@18:25:36                                                                                                                                                                                                     Page 2

IBCEMSR   ;WOIFO/AAT - MRA STATISTICS REPORT ;09/03/04

 +1       ;;2.0;INTEGRATED BILLING;**155,288,294,349,447**;21-MAR-94;Build 80

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

EN        ;

 +1        NEW IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR

 +2        WRITE !!,"Report requires 132 Columns"

 +3       ; quit flag

           SET IBQ=0

 +4       ; Prompts to the user:

 +5       ; Division(s)

           DO DIV

           if IBQ

               QUIT

 +6       ; Summary only?

           DO SUM

           if IBQ

               QUIT

 +7        WRITE !!,"Normal processing time for a MRA is 10-12 days.  If you select a date range of"

 +8        WRITE !,"less than 2 weeks, do not expect to have received many MRAs."

 +9       ; From-To date range

           DO DTR

           if IBQ

               QUIT

 +10       DO DEVICE

           if IBQ

               QUIT

 +11       DO RUN

 +12       QUIT

 +13      ;

DIV        NEW DIC,DIR,DIRUT,Y

 +1        WRITE !

           SET DIR("B")="ALL"

           SET DIR("A")="Run this report for All divisions or Selected Divisions: "

 +2        SET DIR(0)="SA^ALL:All divisions;S:Selected divisions"

           DO ^DIR

 +3        IF $DATA(DIRUT)

               SET IBQ=1

               QUIT

 +4        SET IBDIV=Y

           if Y="ALL"

               QUIT

 +5       ; Collect divisions

 +6        FOR

               Begin DoDot:1

 +7                WRITE !

                   SET DIC("A")="Division: "

                   SET DIC=40.8

                   SET DIC(0)="AEQM"

                   DO ^DIC

 +8                IF $DATA(DIRUT)

                       SET IBQ=1

                       QUIT

 +9                IF Y'>0

                       QUIT

 +10               SET IBDIV(+Y)=""

               End DoDot:1

               if Y'>0

                   QUIT

 +11      ; None selected

           IF $ORDER(IBDIV(""))=""

               SET IBQ=1

               QUIT

 +12       QUIT

 +13      ;

DTR       ;date range

 +1        NEW %DT,Y

 +2        SET (IBBDT,IBEDT)=DT

 +3        SET %DT="AEX"

 +4       ; No default,%DT("B")="TODAY"

           SET %DT("A")="Start with MRA Request Transmission Date: "

 +5        WRITE !

           DO ^%DT

           KILL %DT

 +6        IF Y<0

               SET IBQ=1

               QUIT

 +7        SET IBBDT=+Y

 +8        SET %DT="AEX"

 +9        SET %DT("A")="Go to MRA Request Transmission Date: "

           SET %DT("B")="TODAY"

 +10       DO ^%DT

           KILL %DT

 +11       IF Y<0

               SET IBQ=1

               QUIT

 +12       SET IBEDT=+Y

 +13       QUIT

 +14      ;

SUM        NEW DIR,DIRUT,Y

 +1        WRITE !

           SET DIR("B")="YES"

           SET DIR("A")="Do you want to print a summary only? "

 +2        SET DIR(0)="YA"

           DO ^DIR

 +3        IF $DATA(DIRUT)

               SET IBQ=1

               QUIT

 +4        SET IBSUM=+Y

 +5        QUIT

 +6       ;

DEVICE     NEW %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP

 +1        KILL IO("Q")

 +2        SET %ZIS="QM"

 +3        WRITE !

           DO ^%ZIS

 +4        IF POP

               SET IBQ=1

               QUIT

 +5        SET IBSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)

 +6       ;

 +7        IF $DATA(IO("Q"))

               Begin DoDot:1

 +8                SET ZTRTN="RUN^IBCEMSR"

 +9                SET ZTIO=ION

 +10               SET ZTSAVE("IB*")=""

 +11               SET ZTDESC="IB MRA STATISTICS REPORT"

 +12               DO ^%ZTLOAD

 +13               WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")

 +14               DO HOME^%ZIS

               End DoDot:1

               SET IBQ=1

 +15       USE IO

 +16       QUIT

 +17      ;

 +18      ;

RUN        NEW REF

 +1        SET REF=$NAME(^TMP($JOB,"IBCEMSR"))

 +2        KILL @REF

 +3       ; Collect the data in ^TMP

           DO COLLECT

 +4        USE IO

 +5        DO REPORT^IBCEMSR1

 +6        IF 'IBSCR

               WRITE !,@IOF

 +7        DO ^%ZISC

 +8        KILL @REF

 +9        QUIT

 +10      ;

COLLECT   ; Collect Information

 +1       ; Input: IBDIV, IBBDT,IBEDT

 +2        NEW IBDT,IBBAT,IBTRAN,IBZ,MRAUSR,NUMDIV,IBDV,ALLDIV

 +3        SET IBDV=0

           FOR NUMDIV=0:1

               SET IBDV=$ORDER(IBDIV(IBDV))

               if 'IBDV

                   QUIT

 +4        SET ALLDIV=" "

 +5        IF IBDIV="ALL"

               SET ALLDIV="  *** ALL DIVISIONS ***"

 +6        IF NUMDIV>1

               SET ALLDIV="  *** ALL SELECTED DIVISIONS ***"

 +7       ;

 +8       ;Auto-authorizer

           SET MRAUSR=$$MRAUSR^IBCEMU1()

 +9        SET IBDT=IBBDT-.000001

 +10       FOR

               SET IBDT=$ORDER(^IBA(364.1,"ALT",IBDT))

               if 'IBDT

                   QUIT

               if IBDT\1>IBEDT

                   QUIT

               Begin DoDot:1

 +11               SET IBBAT=0

FOR

                       SET IBBAT=$ORDER(^IBA(364.1,"ALT",IBDT,IBBAT))

                       if 'IBBAT

                           QUIT

                       Begin DoDot:2

 +12                       SET IBTRAN=0

FOR

                               SET IBTRAN=$ORDER(^IBA(364,"C",IBBAT,IBTRAN))

                               if 'IBTRAN

                                   QUIT

                               Begin DoDot:3

 +13                               SET IBZ=$GET(^IBA(364,IBTRAN,0))

                                   if IBZ=""

                                       QUIT

 +14                               NEW IBIFN,IBSTAT,IBSEQ,IBBILZ,IBBILST,IBFORM,IBCLERK,IBDV,IBDVN,REFX,REFS,REFT,REFTX,MRACNT,IBREJECT

 +15                               SET IBIFN=+IBZ

 +16      ; no MRA request

                                   IF '$PIECE($GET(^DGCR(399,IBIFN,"S")),U,7)

                                       QUIT

 +17                               SET IBSTAT=$PIECE(IBZ,U,3)

 +18                               SET IBSEQ=$PIECE(IBZ,U,8)

                                   if "T"[IBSEQ

                                       QUIT

 +19      ; payer sequence must be Medicare for this transmission

                                   IF '$$WNRBILL^IBEFUNC(IBIFN,IBSEQ)

                                       QUIT

 +20                               SET IBBILZ=$GET(^DGCR(399,IBIFN,0))

 +21                               SET IBBILST=$PIECE(IBBILZ,U,13)

 +22                               SET IBFORM=+$PIECE(IBBILZ,U,19)

 +23      ; not 1500 or UB

                                   IF IBFORM'=2

                                       IF IBFORM'=3

                                           QUIT

 +24      ; Who requested MRA?

                                   SET IBCLERK=+$PIECE($GET(^DGCR(399,IBIFN,"S")),U,8)

 +25                               SET IBCLERK=$PIECE($GET(^VA(200,IBCLERK,0)),U)

 +26                               if IBCLERK=""

                                       SET IBCLERK="UNKNOWN"

 +27      ; Default division

                                   SET IBDV=+$PIECE(IBBILZ,U,22)

 +28      ; Div name

                                   SET IBDVN=$PIECE($GET(^DG(40.8,IBDV,0)),U)

 +29                               if IBDVN=""

                                       SET IBDVN="UNKNOWN"

 +30      ;Division filter

                                   IF IBDIV'="ALL"

                                       IF '$DATA(IBDIV(IBDV))

                                           QUIT

 +31      ; all divisions detail

                                   IF 'IBSUM

                                       SET REFX=$NAME(@REF@(IBDVN,IBCLERK,IBFORM))

                                       IF NUMDIV'=1

                                           SET REFTX=$NAME(@REF@(ALLDIV,IBCLERK,IBFORM))

 +32      ; Summary by division

                                   SET REFS=$NAME(@REF@(IBDVN,0,IBFORM))

 +33      ; all divisions

                                   IF NUMDIV'=1

                                       SET REFT=$NAME(@REF@(ALLDIV,0,IBFORM))

 +34      ; rejected?

                                   DO TXSTS^IBCEMU2(IBIFN,IBTRAN,.IBREJECT)

 +35      ; how many MRAs?

                                   SET MRACNT=$$MRACNT^IBCEMU1(IBIFN)

 +36      ; total no of requests

                                   DO INC("ALL")

 +37      ;cancelled

                                   IF IBSTAT="C"

                                       DO INC("ALLC")

 +38      ;resubmitted

                                   IF IBSTAT="R"

                                       DO INC("ALLR")

 +39      ;unique requests

                                   IF '$DATA(@REFS@("TOT",IBIFN))

                                       SET ^(IBIFN)=""

                                       DO INC("TOT")

 +40      ;no response?

 +41                               IF 'IBREJECT

                                       IF 'MRACNT

                                           IF '$DATA(@REFS@("NON",IBIFN))

                                               SET ^(IBIFN)=""

                                               DO INC("NON")

 +42      ;final reject?

 +43                               IF 'MRACNT

                                       IF IBREJECT

                                           IF '$DATA(@REFS@("REJF",IBIFN))

                                               IF IBTRAN=$$LAST364^IBCEF4(IBIFN)

                                                   Begin DoDot:4

 +44                                                   SET @REFS@("REJF",IBIFN)=""

                                                       DO INC("REJF")

 +45      ; MRA?

                                                   End DoDot:4

 +46                               IF MRACNT

                                       IF '$DATA(@REFS@("MRA",IBIFN))

                                           SET ^(IBIFN)=""

                                           Begin DoDot:4

 +47                                           DO INC("MRA")

 +48                                           IF $$DENIED(IBIFN)

                                                   DO INC("MRAD")

                                           End DoDot:4

 +49      ;any secondary claims?

 +50                               DO SECOND

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +51       QUIT

 +52      ;

INC(NODE,VALUE) ;Increase the respective value in ^TMP

 +1        IF 'IBSUM

               Begin DoDot:1

 +2                SET @REFX@(NODE)=$GET(@REFX@(NODE))+$GET(VALUE,1)

 +3                IF $DATA(REFTX)

                       SET @REFTX@(NODE)=$GET(@REFTX@(NODE))+$GET(VALUE,1)

 +4                QUIT

               End DoDot:1

 +5        SET @REFS@(NODE)=$GET(@REFS@(NODE))+$GET(VALUE,1)

 +6        IF $DATA(REFT)

               SET @REFT@(NODE)=$GET(@REFT@(NODE))+$GET(VALUE,1)

 +7        QUIT

 +8       ;

DENIED(IBIFN) ;MRA requests denied?

 +1       ; 361.1 for this bill#

 +2       ; if at least one request is 'processed' - MRA is NOT DENIED

 +3        NEW IBDEN,IEN,IBZ

 +4        SET IBDEN=1

 +5        SET IEN=0

FOR

               SET IEN=$ORDER(^IBM(361.1,"B",+$GET(IBIFN),IEN))

               if 'IEN

                   QUIT

               Begin DoDot:1

 +6                SET IBZ=$GET(^IBM(361.1,IEN,0))

 +7       ; only MEDICARE

                   IF $PIECE(IBZ,U,4)'=1

                       QUIT

 +8                IF $PIECE(IBZ,U,13)=1

                       SET IBDEN=0

               End DoDot:1

               if 'IBDEN

                   QUIT

 +9        QUIT IBDEN

 +10      ;

SECOND    ;Secondary claims

 +1        NEW IBAUT,IBTX,IBCBPS,IBNEXT,IBBILS,IBTOT,IBUNR,IB2ND,IBNODE,IBGRPN,IBTYPLN,IBPRP

 +2       ; Already included

           IF $DATA(@REFS@("SEC",IBIFN))

               QUIT

 +3       ; current bill sequence

           SET IBCBPS=$PIECE(IBBILZ,U,21)

 +4       ;Next (after MRA) sequence

           SET IBNEXT=$SELECT(IBSEQ="S":"T",1:"S")

 +5        IF IBCBPS'=IBNEXT

               QUIT

 +6       ; Number of unique sec claims

 +7        SET @REFS@("SEC",IBIFN)=""

 +8        DO INC("SEC")

 +9       ; Not even authorized

           SET IBBILS=$GET(^DGCR(399,IBIFN,"S"))

           if '$PIECE(IBBILS,U,10)

               QUIT

 +10      ; Authorized but not yet printed?

 +11       IF $PIECE(IBBILS,U,10)

               IF '$PIECE(IBBILS,U,13)

                   Begin DoDot:1

 +12      ; Exclude transmittable

                       IF +$$TXMT^IBCEF4(IBIFN)'=1

                           DO INC("AUT")

                   End DoDot:1

                   QUIT

 +13      ; Check the field 'AUTHORIZER'

 +14      ; Auto-authorized?

           SET IBAUT=($PIECE(IBBILS,U,11)=MRAUSR)

 +15      ; Transmitted? (present in 364?)

           SET IBTX=$$TRANSM(IBIFN,IBNEXT)

 +16      ; Auto-gen Tx

           IF IBAUT

               IF IBTX

                   SET IBNODE="AT"

 +17      ; Manually Tx

           IF 'IBAUT

               IF IBTX

                   SET IBNODE="MT"

 +18      ; Auto-gen Prn

           IF IBAUT

               IF 'IBTX

                   SET IBNODE="AP"

 +19      ; Manually Prn

           IF 'IBAUT

               IF 'IBTX

                   SET IBNODE="MP"

 +20      ;

 +21      ;Calculate amounts

 +22       SET IBTOT=+$GET(^DGCR(399,IBIFN,"U1"))

 +23      ; Medicare Unreimbursable

           SET IBUNR=$PIECE($GET(^PRCA(430,IBIFN,13)),U,2)

 +24      ; IB*2.0*447 calculate differently for claims w/Medicare supplemental, need plan type now and prior payments

 +25      ;S IB2ND=$$PREOBTOT^IBCEU0(IBIFN)

 +26       SET IBGRPN=+$PIECE($GET(^DGCR(399,IBIFN,"I"_$SELECT(IBCBPS="S":2,IBCBPS="T":3,1:1))),U,18)

           SET IBTYPLN=$PIECE($GET(^IBA(355.3,IBGRPN,0)),U,9)

 +27       SET IBPRP=$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,4)

           if IBCBPS="T"

               SET IBPRP=IBPRP+$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,5)

 +28      ; if current payer is primary, or prior payments are a negative amt., set prior payments to 0

 +29       IF IBCBPS="P"!(IBPRP<0)

               SET IBPRP=0

 +30      ; if plan type does NOT have any special calculations, just calculate the old way (PR only)

 +31       SET IB2ND=$SELECT($$MSEDT^IBCEMU4(IBIFN,IBTYPLN)'="":IBTOT-IBPRP,1:$$PREOBTOT^IBCEU0(IBIFN))

 +32       DO INC(IBNODE)

 +33       DO INC(IBNODE_"1",IBTOT)

 +34       DO INC(IBNODE_"2",IBUNR)

 +35       DO INC(IBNODE_"3",IB2ND)

 +36       QUIT

 +37      ;

TRANSM(IBIFN,IBSEQ) ;was the claim ever transmitted?

 +1       ; Does the claim present in 364?

 +2        NEW RES,IBI

 +3        SET RES=0

 +4        SET IBI=""

FOR

               SET IBI=$ORDER(^IBA(364,"B",IBIFN,IBI),-1)

               if IBI=""

                   QUIT

               Begin DoDot:1

 +5                IF $PIECE($GET(^IBA(364,IBI,0)),U,8)=IBSEQ

                       SET RES=1

               End DoDot:1

               if RES

                   QUIT

 +6        QUIT RES

 +7       ;

IBCEMSR.m