IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
;;2.0;INTEGRATED BILLING;**155,371,432,547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;
COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB data for line item
; from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n)
;
; IBIFN = bill entry #
; IBI = VistA outbound line item #
; IBXDATA = array returned with COB line item data/pass by reference
; SORT = flag that determines whether the data should be sorted for
; output for the 837 record ('PR' group always there and has
; a reason code for deductible first and co-insurance second -
; even if they are 0).
; 1 = sort, 0 = no sort needed
;
; Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item
; found in an accepted EOB for the bill and = the '0' node data of
; file 361.115 (LINE LEVEL ADJUSTMENTS)
; -- AND --
; IBXDATA(IBI,"COB",COB,n,z,p)=
; the data on the '0' node for each subordinate entry of file
; 361.11511 (REASONS) (Only first 3 pieces for 837 output)
; z = this is either piece 1 of the 0-node for subfile
; 361.1151 (ADJUSTMENTS)
; OR
; for the 837 COB 'sorted' output, this will be ' PR'
; for the forced/extracted entries for deductible
; and co-insurance so they are always output first
; The space needs to be stripped off on output
; -- AND --
; IBXTRA = array returned if passed by reference if line is found
; associated with line IBI due to bundling/unbundling
; IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding
; to subscript n in IBXDATA(,"COB",COB,n
; (x = line #-original proc-service dt)
;
;IB*2.0*432/TAZ - Added loop to extract data from all associated EOBs.
;
N IB,IBBILL,IBCURR
S IBCURR=$$COB^IBCEF(IBIFN)
; IB*2.0*547 make sure MRA flag is only set if on current sequence being checked
;S IBMRAF=$$MCRONBIL^IBEFUNC(IBIFN)
S IBMRAF=$P($$MCRONBIL^IBEFUNC(IBIFN,$S(IBCURR="P":1,IBCURR="S":2,1:3)),U,2)
S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
;
F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL D COB1(IBBILL,.IBXDATA,IBMRAF,IBCURR)
Q
;
COB1(IBIFN,IBXDATA,IBMRAF,IBCURR) ; Process the EOB
;
N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT
;
; If multiple EOB's reference this line for the same COB sequence,
; extract only the last one marked accepted containing this line item.
;
S A=0
F S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A D
.
. I '$$EOBELIG^IBCEU1(A,IBMRAF,IBCURR) Q ; eob not eligible for secondary claim
. I '$D(^IBM(361.1,A,15,"AC",IBI)) Q ; this EOB does not reference VistA line# IBI
. S IBA=0
. S IBDATA=$G(^IBM(361.1,A,0))
. S IBS=$P(IBDATA,U,15) ; insurance sequence#
. S IBN=+$O(IBXDATA(IBI,"COB",IBS,0))
. I IBN D Q:IBN ; check for later EOB
.. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS) S IBN=0
. ;
. S IBDT(IBI,IBS)=$P(IBDATA,U,6)
. S B=0
. F S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B S IB0=$G(^IBM(361.1,A,15,B,0)),IB0=IB0_U_IBDT(IBI,IBS) D
.. Q:$TR(IB0,U)=""
.. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0
.. ;
.. ; capture the modifiers (361.1152)
.. I $D(^IBM(361.1,A,15,B,2)) M IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2)
.. I $P(IB0,U,15)'="" D ;Line involved in bundling/unbundling
... N Z0 S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16)
... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDATA(IBI,"COB",IBS,IBA),U)=""
.. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if not found in list
.. F S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C S IB0=$G(^(C,0)) D
... S D=0
... F S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D S IB00=$S($G(SORT):$P($G(^(D,0)),U,1,3),1:$G(^(D,0))) D
.... I $G(SORT),$P(IB0,U)="PR" D ;Check for deductible or co-ins
..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB00="" Q
..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB00="" Q
.... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),""),-1)+1,IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),IBB)=IB00
.. Q:'$G(SORT)
.. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA)
.. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEU6 4465 printed Oct 16, 2024@18:13:18 Page 2
IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
+1 ;;2.0;INTEGRATED BILLING;**155,371,432,547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB data for line item
+1 ; from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n)
+2 ;
+3 ; IBIFN = bill entry #
+4 ; IBI = VistA outbound line item #
+5 ; IBXDATA = array returned with COB line item data/pass by reference
+6 ; SORT = flag that determines whether the data should be sorted for
+7 ; output for the 837 record ('PR' group always there and has
+8 ; a reason code for deductible first and co-insurance second -
+9 ; even if they are 0).
+10 ; 1 = sort, 0 = no sort needed
+11 ;
+12 ; Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item
+13 ; found in an accepted EOB for the bill and = the '0' node data of
+14 ; file 361.115 (LINE LEVEL ADJUSTMENTS)
+15 ; -- AND --
+16 ; IBXDATA(IBI,"COB",COB,n,z,p)=
+17 ; the data on the '0' node for each subordinate entry of file
+18 ; 361.11511 (REASONS) (Only first 3 pieces for 837 output)
+19 ; z = this is either piece 1 of the 0-node for subfile
+20 ; 361.1151 (ADJUSTMENTS)
+21 ; OR
+22 ; for the 837 COB 'sorted' output, this will be ' PR'
+23 ; for the forced/extracted entries for deductible
+24 ; and co-insurance so they are always output first
+25 ; The space needs to be stripped off on output
+26 ; -- AND --
+27 ; IBXTRA = array returned if passed by reference if line is found
+28 ; associated with line IBI due to bundling/unbundling
+29 ; IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding
+30 ; to subscript n in IBXDATA(,"COB",COB,n
+31 ; (x = line #-original proc-service dt)
+32 ;
+33 ;IB*2.0*432/TAZ - Added loop to extract data from all associated EOBs.
+34 ;
+35 NEW IB,IBBILL,IBCURR
+36 SET IBCURR=$$COB^IBCEF(IBIFN)
+37 ; IB*2.0*547 make sure MRA flag is only set if on current sequence being checked
+38 ;S IBMRAF=$$MCRONBIL^IBEFUNC(IBIFN)
+39 SET IBMRAF=$PIECE($$MCRONBIL^IBEFUNC(IBIFN,$SELECT(IBCURR="P":1,IBCURR="S":2,1:3)),U,2)
+40 SET IB=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5,7)
+41 ;
+42 FOR B=1:1:3
SET IBBILL=$PIECE(IB,U,B)
IF IBBILL
DO COB1(IBBILL,.IBXDATA,IBMRAF,IBCURR)
+43 QUIT
+44 ;
COB1(IBIFN,IBXDATA,IBMRAF,IBCURR) ; Process the EOB
+1 ;
+2 NEW A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT
+3 ;
+4 ; If multiple EOB's reference this line for the same COB sequence,
+5 ; extract only the last one marked accepted containing this line item.
+6 ;
+7 SET A=0
+8 FOR
SET A=$ORDER(^IBM(361.1,"B",IBIFN,A))
if 'A
QUIT
Begin DoDot:1
+9 +10 ; eob not eligible for secondary claim
IF '$$EOBELIG^IBCEU1(A,IBMRAF,IBCURR)
QUIT
+11 ; this EOB does not reference VistA line# IBI
IF '$DATA(^IBM(361.1,A,15,"AC",IBI))
QUIT
+12 SET IBA=0
+13 SET IBDATA=$GET(^IBM(361.1,A,0))
+14 ; insurance sequence#
SET IBS=$PIECE(IBDATA,U,15)
+15 SET IBN=+$ORDER(IBXDATA(IBI,"COB",IBS,0))
+16 ; check for later EOB
IF IBN
Begin DoDot:2
+17 IF $GET(IBDT(IBI,IBS))
IF IBDT(IBI,IBS)<$PIECE(IBDATA,U,6)
KILL IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS)
SET IBN=0
End DoDot:2
if IBN
QUIT
+18 ;
+19 SET IBDT(IBI,IBS)=$PIECE(IBDATA,U,6)
+20 SET B=0
+21 FOR
SET B=$ORDER(^IBM(361.1,A,15,"AC",IBI,B))
if 'B
QUIT
SET IB0=$GET(^IBM(361.1,A,15,B,0))
SET IB0=IB0_U_IBDT(IBI,IBS)
Begin DoDot:2
+22 if $TRANSLATE(IB0,U)=""
QUIT
+23 SET IBA=IBA+1
SET IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0
+24 ;
+25 ; capture the modifiers (361.1152)
+26 IF $DATA(^IBM(361.1,A,15,B,2))
MERGE IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2)
+27 ;Line involved in bundling/unbundling
IF $PIECE(IB0,U,15)'=""
Begin DoDot:3
+28 NEW Z0
SET Z0=IBI_"-"_$PIECE(IB0,U,15)_"-"_$PIECE(IB0,U,16)
+29 SET IBXTRA("ALL",Z0,$PIECE(IB0,U,4))=IBS_U_IBA
SET $PIECE(IBXDATA(IBI,"COB",IBS,IBA),U)=""
End DoDot:3
+30 ;Assume 0 if not found in list
SET C=0
SET (IBDED(IBA),IBCOI(IBA))="0^0"
+31 FOR
SET C=$ORDER(^IBM(361.1,A,15,B,1,C))
if 'C
QUIT
SET IB0=$GET(^(C,0))
Begin DoDot:3
+32 SET D=0
+33 FOR
SET D=$ORDER(^IBM(361.1,A,15,B,1,C,1,D))
if 'D
QUIT
SET IB00=$SELECT($GET(SORT):$PIECE($GET(^(D,0)),U,1,3),1:$GET(^(D,0)))
Begin DoDot:4
+34 ;Check for deductible or co-ins
IF $GET(SORT)
IF $PIECE(IB0,U)="PR"
Begin DoDot:5
+35 IF 'IBDED(IBA)
IF $PIECE(IB00,U)=1
SET IBDED(IBA)=IB00
SET IB00=""
QUIT
+36 IF 'IBCOI(IBA)
IF $PIECE(IB00,U)=2
SET IBCOI(IBA)=IB00
SET IB00=""
QUIT
End DoDot:5
+37 IF $TRANSLATE(IB00,U)'=""
SET IBB=$ORDER(IBXDATA(IBI,"COB",IBS,IBA,$PIECE(IB0,U),""),-1)+1
SET IBXDATA(IBI,"COB",IBS,IBA,$PIECE(IB0,U),IBB)=IB00
End DoDot:4
End DoDot:3
+38 if '$GET(SORT)
QUIT
+39 SET IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA)
+40 SET IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA)
End DoDot:2
End DoDot:1
+41 QUIT
+42 ;
