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
Q
;
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
Q
;
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
Q
;
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
Q
;
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
Q
;
;
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
Q
;
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
Q
;
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)
Q
;
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)
Q
;
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 09, 2024@21:32:54 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 ;
