IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
;;2.0;INTEGRATED BILLING;**137,155,296,349,371,432,473,547,608**;21-MAR-94;Build 90
;;Per VA Directive 6402, this routine should not be modified.
;
CCOB1(IBIFN,NODE,SEQ,IBRSBTST) ; Extract Claim level COB data
; for a bill IBIFN
; NODE = the file 361.1 node(s) to be returned, separated by commas
; SEQ = the specific insurance sequence you want returned. If not =
; 1, 2, or 3, all are returned
; Returns IBXDATA(COB,n,node) where COB = COB insurance sequence,
; n is the entry number in file 361.1 and node is the node requested
; = the requested node's data
; IBRSBTST=1, this indicates the claim is being resubmitted as a "TEST"
; claim and should be used be the OUTPUT FORMATTER entries
; to determine what COB information is going out. - IB*2*608 (vd)
;
N IB,IBN,IBBILL,IBS,A,B,C,IBCURR,IBMRAF,Z,CSEQ
;
K IBXDATA
;
S:$G(NODE)="" NODE=1
S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
S IBCURR=$$COB^IBCEF(IBIFN)
S CSEQ=$$COBN^IBCEF(IBIFN)
; ib*2.0*547 make sure you only set MRA flag if MRA 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:"123"'[$G(SEQ) SEQ=""
;
F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D
. I '$$EOBELIG(C,IBMRAF,IBCURR) Q ; eob not eligible for secondary claim
. S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence
. I +$G(IBRSBTST),((CSEQ=IBS)!(CSEQ<IBS)) Q ; IB*2.0*608/vd (US2486) added to prevent COB Data from being put on Resubmitted Claims for TEST.
. I $S('$G(SEQ):1,1:SEQ=IBS) D
.. F Z=1:1:$L(NODE,",") D
... S A=$P(NODE,",",Z)
... Q:A=""
... S IBN=$G(^IBM(361.1,C,A))
... ; Start IB*2.0*473 BI Added to null patient responsibility in OI1
... ; if the data is contained at the line level to be sent in LCOB.
... ; Perform the following for only OI1.19 using the dictionary 364.6 IEN.
... S:+$G(IBX0)=2204&($$LPREXIST(C))&(A=1) $P(IBN,U,2)=""
... ; End IB*2.0*473
... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN
;
Q
;
CCAS1(IBIFN,SEQ,IBRSBTST) ; Extract all MEDICARE COB claim level adjustment data
; for a bill IBIFN (subfile 361.11 in file 361.1)
; SEQ = the specific insurance sequence you want returned. If not =
; 1, 2, or 3, all are returned
; Returns IBXDATA(COB,n) where COB = COB insurance sequence,
; n is the entry number in file 361.1 and
; = the 0-node of the subfile entry (361.11)
; and IBXDATA(COB,n,m) where m is a sequential # and
; = this level's 0-node
; IBRSBTST=1, this indicates the claim is being resubmitted as a "TEST"
; claim and should be used be the OUTPUT FORMATTER entries
; to determine what COB information is going out. - IB*2*608 (vd)
N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E,CSEQ
;
S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
S:"123"'[$G(SEQ) SEQ=""
S CSEQ=$$COBN^IBCEF(IBIFN)
;
F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D
. I '$$EOBELIG(C) Q ; eob not eligible for secondary claim
. S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence
. I +$G(IBRSBTST),((CSEQ=IBS)!(CSEQ<IBS)) Q ; IB*2.0*608/vd (US2486) added to prevent COB Data from being put on Resubmitted Claims for TEST.
. I $S('$G(SEQ):1,1:SEQ=IBS) D
.. S (IBA,D)=0 F S D=$O(^IBM(361.1,C,10,D)) Q:'D S IB0=$G(^(D,0)) D
... S IBXDATA(IBS,D)=IB0
... S (IBA,E)=0
... F S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E S IB00=$G(^(E,0)) D
.... S IBA=IBA+1
.... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00
;
Q
;
SEQ(A) ; Translate sequence # A into corresponding letter representation
S A=$E("PST",A)
I $S(A'="":"PST"'[A,1:1) S A="P"
Q A
;
EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence
; Function returns the total of all EOB's for a specific COB seq
; IBIFN = ien of bill in file 399
; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3)
;
N Z,Z0,IBTOT
S IBTOT=0
I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D
. ; Set up prior payment field here from MRA/EOB(s)
. S (IBTOT,Z)=0
. F S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z D
.. ; HD64841 IB*2*371 - total up the payer paid amounts
.. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,1)
Q IBTOT
;
;
LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB
; line # data for an electronic claim
; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
; pass by reference
; COL = the column in the 837 flat file being output for LCAS record
N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA
S (LINE,RECCT)=0
S RCPC=(COL#3) S:'RCPC RCPC=3
S RCREC=$S(COL'<4:COL-1\3,1:0)
;S RCREC=$S(COL'<4:COL+5\6-1,1:0)
F S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE D
. S COBSEQ=0
. F S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ S SEQLINE=0 F S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE S GRPCD="" F S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD="" D
.. S RECCT=RECCT+1
.. ;IB*2.0*432/TAZ Added payer sequence in piece 22 of LCAS record (parameter Z)
.. I COL="Z" S IBXDATA(RECCT)=$E("PST",COBSEQ) I RECCT>1 D ID^IBCEF2(RECCT,"LCAS")
.. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS")
.. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ")
.. S (SEQ,RCCT)=0
.. F S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D
... S RCCT=RCCT+1
... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC))
... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
Q
;
CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB
; data for an electronic claim
; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
; pass by reference
; COL = the column in the 837 flat file being output for CCAS record
N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA
S RECCT=0
S RCPC=(COL#3) S:'RCPC RCPC=3
S RCREC=$S(COL'<4:COL+5\6-1,1:0)
S COBSEQ=0
F S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ S GRPSEQ="" F S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ="" D
. S RECCT=RECCT+1
. I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS")
. I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U)
. S (SEQ,RCCT)=0
. F S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D
.. S RCCT=RCCT+1
.. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
.. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC))
.. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
.. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
Q
;
COBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
; This is basically the 361.115, but all the piece numbers here in this
; local array are one higher than the pieces in subfile 361.115.
N Z,M,N,P,PCCL
S (N,Z)=0
F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D
. S M=0 F S M=$O(IBXSAVE("LCOB",Z,"COB",M)) Q:'M D
.. S P=0 F S P=$O(IBXSAVE("LCOB",Z,"COB",M,P)) Q:'P D
... S N=N+1
... I CL="Z" S IBXDATA(N)=$E("PST",M) Q
... S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
... ;IB*2.0*432/TAZ - If the revenue code is blank for the EOB get it from the Primary Level
... I PCCL="",CL=11 S PCCL=$P($G(IBXSAVE("LCOB",Z)),U)
... S:PCCL'="" IBXDATA(N)=PCCL
Q
;
;IB*2.0*432/TAZ - XCOBOUT is the original code which did not capture all the LCOB records.
XCOBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
; This is basically the 361.115, but all the piece numbers here in this
; local array are one higher than the pieces in subfile 361.115.
N Z,M,N,P,PCCL
S (N,Z,P)=0 F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D
. S N=N+1
. S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M
. S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P
. ;IB*2.0*432/TAZ Added Payer Sequence to piece 18 of the LCOB record
. I CL="Z" S IBXDATA(N)=$E("PST",M) Q
. S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
. S:PCCL'="" IBXDATA(N)=PCCL
. Q
Q
;
COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
N CT,N,NUM,Z
K IBXDATA
I '$D(IBXSAVE("LCOB")) G COBPYRX
;
;IB*2.0*432/TAZ - Replaced following code with loop to insure that all LCOB records have the Payer ID
;D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
;S NUM=$G(NUM(1))
;S NUM=$E(NUM_$J("",5),1,5)
;S (CT,N)=0
;F S N=$O(IBXSAVE("LCOB",N)) Q:'N S CT=CT+1,IBXDATA(CT)=NUM
;
D ALLPAYID^IBCEF2(IBXIEN,.NUM)
S (CT,N)=0
F S N=$O(IBXSAVE("LCOB",N)) Q:'N D
. S Z=0
. F S Z=$O(IBXSAVE("LCOB",N,"COB",Z)) Q:'Z D
.. S CT=CT+1,IBXDATA(CT)=$G(NUM(Z))
COBPYRX ;
Q
;
EOBELIG(IBEOB,IBMRAF,IBCURR) ; EOB eligibility for secondary claim
; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is
; eligible to be included for secondary claim creation process
; The EOB is not eligible if the review status is not 3, or if there
; is no insurance sequence indicator, or if the EOB has been DENIED
; and the patient responsibility for that EOB is $0 and that EOB is
; not a split EOB. Split EOB's need to be included (IB*2*371).
;
; 432 - added new flag IBMRAF to indicate if we need to check only MRA's or all EOB's
; IBMRAF = 1 if only need MRA EOB's
;
NEW ELIG,IBDATA,PTRESP
S ELIG=0
; IB*2.0*432/TAZ Get current Payer sequence if not passed in.
I '$G(IBCURR) S IBCURR=$$COB^IBCEF(IBIFN)
I '$G(IBEOB) G EOBELIGX
S IBDATA=$G(^IBM(361.1,IBEOB,0))
I $G(IBMRAF)=1,$P(IBDATA,U,4)'=1 G EOBELIGX ; Only MRA EOB's for now if flag = 1
I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX ; filing error
I $P(IBDATA,U,16)'=3 G EOBELIGX ; review status - accepted-complete
I '$P(IBDATA,U,15) G EOBELIGX ; insurance sequence must exist
; IB*2.0*432/TAZ Don't send EOB data for current payer
I $P(IBDATA,U,15)=IBCURR G EOBELIGX ; Don't send EOB data for current payer (this is for retransmits)
S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2) ; Pt Resp Amount for 1500s
I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB) ; for UBs
I PTRESP'>0,$P(IBDATA,U,13)=2,'$$SPLIT^IBCEMU1(IBEOB) G EOBELIGX ; Denied & No Pt. Resp. & not a split MRA
;
S ELIG=1
EOBELIGX ;
Q ELIG
;
EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible
; for the secondary claim creation process for a given bill#.
NEW CNT,IEN
S (CNT,IEN)=0
F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D
. I $$EOBELIG(IEN) S CNT=CNT+1
. Q
EOBCNTX ;
Q CNT
;
LPTRESP(IBIFN,IBXSAVE,IBXDATA,CL) ; Line level patient responsibility.
; Added with IB*2.0*473 BI
N IBPTZ,IBPTM,IBPTP,IBPTPR,IBPRDATA,IBPTCNT
S:'$D(CL) CL=17
S IBPTCNT=0
S IBPTZ=0 F S IBPTZ=$O(IBXSAVE("LCOB",IBPTZ)) Q:'IBPTZ D
. S IBPTM=0 F S IBPTM=$O(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM)) Q:'IBPTM D
.. S IBPTP=0 F S IBPTP=$O(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP)) Q:'IBPTP D
... S IBPTCNT=IBPTCNT+1
... I $$CHKCCOB1(IBIFN,IBPTM) S IBXDATA(IBPTCNT)="" Q
... I CL=16 S IBXDATA(IBPTCNT)="EAF" Q
... S IBXDATA(IBPTCNT)=0
... S IBPTPR=0 F S IBPTPR=$O(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP,"PR",IBPTPR)) Q:'IBPTPR D
.... S IBPRDATA=$G(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP,"PR",IBPTPR))
.... I +IBPRDATA S IBXDATA(IBPTCNT)=IBXDATA(IBPTCNT)+$P(IBPRDATA,U,2)
... S IBXDATA(IBPTCNT)=$$DOLLAR^IBCEFG1(IBXDATA(IBPTCNT))
Q
;
LPREXIST(EOBIEN) ; Tests to see if Line Level Patient Responsibility Segments exists.
; Added with IB*2.0*473 BI
N CL,CAS,PR,PRSEQ,PRZ,RESULT
S RESULT=0
Q:'$G(EOBIEN) RESULT
S CL=0 F S CL=$O(^IBM(361.1,EOBIEN,15,CL)) Q:+CL=0 D
. S CAS=0 F S CAS=$O(^IBM(361.1,EOBIEN,15,CL,CAS)) Q:+CAS=0 D
.. S PR=$O(^IBM(361.1,EOBIEN,15,CL,CAS,"B","PR",0)) Q:+PR=0
.. S PRSEQ=0 F S PRSEQ=$O(^IBM(361.1,EOBIEN,15,CL,CAS,PR,1,PRSEQ)) Q:+PRSEQ=0 D
... S PRZ=$G(^IBM(361.1,EOBIEN,15,CL,CAS,PR,1,PRSEQ,0)) Q:'+PRZ
... S RESULT=1
Q RESULT
;
CHKCCOB1(IBIFN,IBS) ; Test to see if Patient Responsibility pieces should be included
; Added with IB*2.0*473 BI
N RESULTS,IBXDATA,EOBIEN
S RESULTS=1
; INPUTS: IBIFN - BILL/CLAIM INTERNAL NUMBER
; IBS - INSURANCE SEQUENCE NUMBER
; RETURNS: 0 - IF LCOB RECORDS ARE TO BE INCLUDED
; 1 - IF LCOB RECORDS SHOULD NOT BE INCLUDED
D CCOB1(IBIFN,0,IBS)
S EOBIEN=$O(IBXDATA(IBS,0))
S RESULT='$$LPREXIST(EOBIEN)
Q RESULT
;
;/IB*2*608 (vd) (US2486) - Added this module of code to be referenced by the Output Formatter.
CKCOBTST(IBXIEN,IBXSAVE,Z0,Z,IBRSBTST) ; Check Primary, Secondary & Tertiary COBS for Claims Resubmitted as Test.
; INPUT: IBXIEN - Current Claim number
; IBXSAVE - Array containing current claim COB data.
; Z0 - Will equal "INPT", "OUTPT" or "RX"
; Z - Is the LINE
N A,CURSEQ,XX
I '+$G(IBRSBTST) M IBXSAVE("LCOB",Z)=IBXSAVE(Z0,Z) Q ; Only concerned with Claims that are Resubmitted as Test.
S A="",CURSEQ=$$COBN^IBCEF(IBXIEN)
; With the line below, ideally, we want to merge all of IBXSAVE(Z0,Z) into IBXSAVE("LCOB",Z),
; but the COB node should be handled separately for the current sequence.
S IBXSAVE("LCOB",Z)=IBXSAVE(Z0,Z)
S XX="" F S XX=$O(IBXSAVE(Z0,Z,XX)) Q:XX="" I XX'="COB" M IBXSAVE("LCOB",Z,XX)=IBXSAVE(Z0,Z,XX)
; Now handle the COB node for the current sequence.
F S A=$O(IBXSAVE(Z0,Z,"COB",A)) Q:A="" D ; Only want to merge those COBS that are previous to the current
. I (CURSEQ=A)!(CURSEQ<A) Q ; Only want to merge those COBS that are previous to the current sequence.
. M IBXSAVE("LCOB",Z,"COB",A)=IBXSAVE(Z0,Z,"COB",A)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEU1 14375 printed Apr 09, 2024@21:18:10 Page 2
IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
+1 ;;2.0;INTEGRATED BILLING;**137,155,296,349,371,432,473,547,608**;21-MAR-94;Build 90
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
CCOB1(IBIFN,NODE,SEQ,IBRSBTST) ; Extract Claim level COB data
+1 ; for a bill IBIFN
+2 ; NODE = the file 361.1 node(s) to be returned, separated by commas
+3 ; SEQ = the specific insurance sequence you want returned. If not =
+4 ; 1, 2, or 3, all are returned
+5 ; Returns IBXDATA(COB,n,node) where COB = COB insurance sequence,
+6 ; n is the entry number in file 361.1 and node is the node requested
+7 ; = the requested node's data
+8 ; IBRSBTST=1, this indicates the claim is being resubmitted as a "TEST"
+9 ; claim and should be used be the OUTPUT FORMATTER entries
+10 ; to determine what COB information is going out. - IB*2*608 (vd)
+11 ;
+12 NEW IB,IBN,IBBILL,IBS,A,B,C,IBCURR,IBMRAF,Z,CSEQ
+13 ;
+14 KILL IBXDATA
+15 ;
+16 if $GET(NODE)=""
SET NODE=1
+17 SET IB=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5,7)
+18 SET IBCURR=$$COB^IBCEF(IBIFN)
+19 SET CSEQ=$$COBN^IBCEF(IBIFN)
+20 ; ib*2.0*547 make sure you only set MRA flag if MRA on current sequence being checked
+21 ;S IBMRAF=$$MCRONBIL^IBEFUNC(IBIFN)
+22 SET IBMRAF=$PIECE($$MCRONBIL^IBEFUNC(IBIFN,$SELECT(IBCURR="P":1,IBCURR="S":2,1:3)),U,2)
+23 ;
+24 if "123"'[$GET(SEQ)
SET SEQ=""
+25 ;
+26 FOR B=1:1:3
SET IBBILL=$PIECE(IB,U,B)
IF IBBILL
SET C=0
FOR
SET C=$ORDER(^IBM(361.1,"B",IBBILL,C))
if 'C
QUIT
Begin DoDot:1
+27 ; eob not eligible for secondary claim
IF '$$EOBELIG(C,IBMRAF,IBCURR)
QUIT
+28 ; insurance sequence
SET IBS=$PIECE($GET(^IBM(361.1,C,0)),U,15)
+29 ; IB*2.0*608/vd (US2486) added to prevent COB Data from being put on Resubmitted Claims for TEST.
IF +$GET(IBRSBTST)
IF ((CSEQ=IBS)!(CSEQ<IBS))
QUIT
+30 IF $SELECT('$GET(SEQ):1,1:SEQ=IBS)
Begin DoDot:2
+31 FOR Z=1:1:$LENGTH(NODE,",")
Begin DoDot:3
+32 SET A=$PIECE(NODE,",",Z)
+33 if A=""
QUIT
+34 SET IBN=$GET(^IBM(361.1,C,A))
+35 ; Start IB*2.0*473 BI Added to null patient responsibility in OI1
+36 ; if the data is contained at the line level to be sent in LCOB.
+37 ; Perform the following for only OI1.19 using the dictionary 364.6 IEN.
+38 if +$GET(IBX0)=2204&($$LPREXIST(C))&(A=1)
SET $PIECE(IBN,U,2)=""
+39 ; End IB*2.0*473
+40 IF $TRANSLATE(IBN,U)'=""
SET IBXDATA(IBS,C,A)=IBN
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 QUIT
+43 ;
CCAS1(IBIFN,SEQ,IBRSBTST) ; Extract all MEDICARE COB claim level adjustment data
+1 ; for a bill IBIFN (subfile 361.11 in file 361.1)
+2 ; SEQ = the specific insurance sequence you want returned. If not =
+3 ; 1, 2, or 3, all are returned
+4 ; Returns IBXDATA(COB,n) where COB = COB insurance sequence,
+5 ; n is the entry number in file 361.1 and
+6 ; = the 0-node of the subfile entry (361.11)
+7 ; and IBXDATA(COB,n,m) where m is a sequential # and
+8 ; = this level's 0-node
+9 ; IBRSBTST=1, this indicates the claim is being resubmitted as a "TEST"
+10 ; claim and should be used be the OUTPUT FORMATTER entries
+11 ; to determine what COB information is going out. - IB*2*608 (vd)
+12 NEW IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E,CSEQ
+13 ;
+14 SET IB=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5,7)
+15 if "123"'[$GET(SEQ)
SET SEQ=""
+16 SET CSEQ=$$COBN^IBCEF(IBIFN)
+17 ;
+18 FOR B=1:1:3
SET IBBILL=$PIECE(IB,U,B)
IF IBBILL
SET C=0
FOR
SET C=$ORDER(^IBM(361.1,"B",IBBILL,C))
if 'C
QUIT
Begin DoDot:1
+19 ; eob not eligible for secondary claim
IF '$$EOBELIG(C)
QUIT
+20 ; insurance sequence
SET IBS=$PIECE($GET(^IBM(361.1,C,0)),U,15)
+21 ; IB*2.0*608/vd (US2486) added to prevent COB Data from being put on Resubmitted Claims for TEST.
IF +$GET(IBRSBTST)
IF ((CSEQ=IBS)!(CSEQ<IBS))
QUIT
+22 IF $SELECT('$GET(SEQ):1,1:SEQ=IBS)
Begin DoDot:2
+23 SET (IBA,D)=0
FOR
SET D=$ORDER(^IBM(361.1,C,10,D))
if 'D
QUIT
SET IB0=$GET(^(D,0))
Begin DoDot:3
+24 SET IBXDATA(IBS,D)=IB0
+25 SET (IBA,E)=0
+26 FOR
SET E=$ORDER(^IBM(361.1,C,10,D,1,E))
if 'E
QUIT
SET IB00=$GET(^(E,0))
Begin DoDot:4
+27 SET IBA=IBA+1
+28 IF $TRANSLATE(IB00,U)'=""
SET IBXDATA(IBS,D,IBA)=IB00
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 QUIT
+31 ;
SEQ(A) ; Translate sequence # A into corresponding letter representation
+1 SET A=$EXTRACT("PST",A)
+2 IF $SELECT(A'="":"PST"'[A,1:1)
SET A="P"
+3 QUIT A
+4 ;
EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence
+1 ; Function returns the total of all EOB's for a specific COB seq
+2 ; IBIFN = ien of bill in file 399
+3 ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3)
+4 ;
+5 NEW Z,Z0,IBTOT
+6 SET IBTOT=0
+7 IF $ORDER(^IBM(361.1,"ABS",IBIFN,IBCOBN,0))
Begin DoDot:1
+8 ; Set up prior payment field here from MRA/EOB(s)
+9 SET (IBTOT,Z)=0
+10 FOR
SET Z=$ORDER(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z))
if 'Z
QUIT
Begin DoDot:2
+11 ; HD64841 IB*2*371 - total up the payer paid amounts
+12 SET IBTOT=IBTOT+$PIECE($GET(^IBM(361.1,Z,1)),U,1)
End DoDot:2
End DoDot:1
+13 QUIT IBTOT
+14 ;
+15 ;
LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB
+1 ; line # data for an electronic claim
+2 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
+3 ; pass by reference
+4 ; COL = the column in the 837 flat file being output for LCAS record
+5 NEW LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE
KILL IBXDATA
+6 SET (LINE,RECCT)=0
+7 SET RCPC=(COL#3)
if 'RCPC
SET RCPC=3
+8 SET RCREC=$SELECT(COL'<4:COL-1\3,1:0)
+9 ;S RCREC=$S(COL'<4:COL+5\6-1,1:0)
+10 FOR
SET LINE=$ORDER(IBXSAVE("LCOB",LINE))
if 'LINE
QUIT
Begin DoDot:1
+11 SET COBSEQ=0
+12 FOR
SET COBSEQ=$ORDER(IBXSAVE("LCOB",LINE,"COB",COBSEQ))
if 'COBSEQ
QUIT
SET SEQLINE=0
FOR
SET SEQLINE=$ORDER(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE))
if 'SEQLINE
QUIT
SET GRPCD=""
FOR
SET GRPCD=$ORDER(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD))
if GRPCD=""
QUIT
Begin DoDot:2
+13 SET RECCT=RECCT+1
+14 ;IB*2.0*432/TAZ Added payer sequence in piece 22 of LCAS record (parameter Z)
+15 IF COL="Z"
SET IBXDATA(RECCT)=$EXTRACT("PST",COBSEQ)
IF RECCT>1
DO ID^IBCEF2(RECCT,"LCAS")
+16 IF COL=2
SET IBXDATA(RECCT)=LINE
SET DATA=LINE
if RECCT>1
DO ID^IBCEF2(RECCT,"LCAS")
+17 IF COL=3
SET IBXDATA(RECCT)=$TRANSLATE(GRPCD," ")
+18 SET (SEQ,RCCT)=0
+19 FOR
SET SEQ=$ORDER(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ))
if 'SEQ
QUIT
IF $TRANSLATE($GET(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'=""
Begin DoDot:3
+20 SET RCCT=RCCT+1
+21 if COL'<4&(RCCT'=RCREC)&(RCCT'>6)
QUIT
+22 SET DATA=$SELECT(COL=2:LINE,COL=3:$TRANSLATE(GRPCD," "),1:$PIECE($GET(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC))
+23 IF COL'<4
IF RCCT=RCREC
if DATA'=""
SET IBXDATA(RECCT)=DATA
QUIT
+24 IF RCCT>6
SET RCCT=1
SET RECCT=RECCT+1
if COL=2
DO ID^IBCEF2(RECCT,"LCAS")
IF DATA'=""
IF $SELECT(COL'>3:1,1:RCCT=RCREC)
SET IBXDATA(RECCT)=DATA
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB
+1 ; data for an electronic claim
+2 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
+3 ; pass by reference
+4 ; COL = the column in the 837 flat file being output for CCAS record
+5 NEW COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA
KILL IBXDATA
+6 SET RECCT=0
+7 SET RCPC=(COL#3)
if 'RCPC
SET RCPC=3
+8 SET RCREC=$SELECT(COL'<4:COL+5\6-1,1:0)
+9 SET COBSEQ=0
+10 FOR
SET COBSEQ=$ORDER(IBXSAVE("CCAS",COBSEQ))
if 'COBSEQ
QUIT
SET GRPSEQ=""
FOR
SET GRPSEQ=$ORDER(IBXSAVE("CCAS",COBSEQ,GRPSEQ))
if GRPSEQ=""
QUIT
Begin DoDot:1
+11 SET RECCT=RECCT+1
+12 IF COL=2
SET IBXDATA(RECCT)=COBSEQ
if RECCT>1
DO ID^IBCEF2(RECCT,"CCAS")
+13 IF COL=3
SET IBXDATA(RECCT)=$PIECE($GET(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U)
+14 SET (SEQ,RCCT)=0
+15 FOR
SET SEQ=$ORDER(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ))
if 'SEQ
QUIT
IF $TRANSLATE($GET(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'=""
Begin DoDot:2
+16 SET RCCT=RCCT+1
+17 if COL'<4&(RCCT'=RCREC)&(RCCT'>6)
QUIT
+18 SET DATA=$SELECT(COL=2:COBSEQ,COL=3:$PIECE($GET(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$PIECE($GET(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC))
+19 IF COL'<4
IF RCCT=RCREC
if DATA'=""
SET IBXDATA(RECCT)=DATA
QUIT
+20 IF RCCT>6
SET RCCT=1
SET RECCT=RECCT+1
if COL=2
DO ID^IBCEF2(RECCT,"CCAS")
IF DATA'=""
IF $SELECT(COL'>3:1,1:RCCT=RCREC)
SET IBXDATA(RECCT)=DATA
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
COBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
+1 ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
+2 ; This is basically the 361.115, but all the piece numbers here in this
+3 ; local array are one higher than the pieces in subfile 361.115.
+4 NEW Z,M,N,P,PCCL
+5 SET (N,Z)=0
+6 FOR
SET Z=$ORDER(IBXSAVE("LCOB",Z))
if 'Z
QUIT
Begin DoDot:1
+7 SET M=0
FOR
SET M=$ORDER(IBXSAVE("LCOB",Z,"COB",M))
if 'M
QUIT
Begin DoDot:2
+8 SET P=0
FOR
SET P=$ORDER(IBXSAVE("LCOB",Z,"COB",M,P))
if 'P
QUIT
Begin DoDot:3
+9 SET N=N+1
+10 IF CL="Z"
SET IBXDATA(N)=$EXTRACT("PST",M)
QUIT
+11 SET PCCL=$PIECE($GET(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
+12 ;IB*2.0*432/TAZ - If the revenue code is blank for the EOB get it from the Primary Level
+13 IF PCCL=""
IF CL=11
SET PCCL=$PIECE($GET(IBXSAVE("LCOB",Z)),U)
+14 if PCCL'=""
SET IBXDATA(N)=PCCL
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
+17 ;IB*2.0*432/TAZ - XCOBOUT is the original code which did not capture all the LCOB records.
XCOBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
+1 ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
+2 ; This is basically the 361.115, but all the piece numbers here in this
+3 ; local array are one higher than the pieces in subfile 361.115.
+4 NEW Z,M,N,P,PCCL
+5 SET (N,Z,P)=0
FOR
SET Z=$ORDER(IBXSAVE("LCOB",Z))
if 'Z
QUIT
Begin DoDot:1
+6 SET N=N+1
+7 SET M=$ORDER(IBXSAVE("LCOB",Z,"COB",""),-1)
if 'M
QUIT
+8 SET P=$ORDER(IBXSAVE("LCOB",Z,"COB",M,""),-1)
if 'P
QUIT
+9 ;IB*2.0*432/TAZ Added Payer Sequence to piece 18 of the LCOB record
+10 IF CL="Z"
SET IBXDATA(N)=$EXTRACT("PST",M)
QUIT
+11 SET PCCL=$PIECE($GET(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
+12 if PCCL'=""
SET IBXDATA(N)=PCCL
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
+1 NEW CT,N,NUM,Z
+2 KILL IBXDATA
+3 IF '$DATA(IBXSAVE("LCOB"))
GOTO COBPYRX
+4 ;
+5 ;IB*2.0*432/TAZ - Replaced following code with loop to insure that all LCOB records have the Payer ID
+6 ;D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
+7 ;S NUM=$G(NUM(1))
+8 ;S NUM=$E(NUM_$J("",5),1,5)
+9 ;S (CT,N)=0
+10 ;F S N=$O(IBXSAVE("LCOB",N)) Q:'N S CT=CT+1,IBXDATA(CT)=NUM
+11 ;
+12 DO ALLPAYID^IBCEF2(IBXIEN,.NUM)
+13 SET (CT,N)=0
+14 FOR
SET N=$ORDER(IBXSAVE("LCOB",N))
if 'N
QUIT
Begin DoDot:1
+15 SET Z=0
+16 FOR
SET Z=$ORDER(IBXSAVE("LCOB",N,"COB",Z))
if 'Z
QUIT
Begin DoDot:2
+17 SET CT=CT+1
SET IBXDATA(CT)=$GET(NUM(Z))
End DoDot:2
End DoDot:1
COBPYRX ;
+1 QUIT
+2 ;
EOBELIG(IBEOB,IBMRAF,IBCURR) ; EOB eligibility for secondary claim
+1 ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is
+2 ; eligible to be included for secondary claim creation process
+3 ; The EOB is not eligible if the review status is not 3, or if there
+4 ; is no insurance sequence indicator, or if the EOB has been DENIED
+5 ; and the patient responsibility for that EOB is $0 and that EOB is
+6 ; not a split EOB. Split EOB's need to be included (IB*2*371).
+7 ;
+8 ; 432 - added new flag IBMRAF to indicate if we need to check only MRA's or all EOB's
+9 ; IBMRAF = 1 if only need MRA EOB's
+10 ;
+11 NEW ELIG,IBDATA,PTRESP
+12 SET ELIG=0
+13 ; IB*2.0*432/TAZ Get current Payer sequence if not passed in.
+14 IF '$GET(IBCURR)
SET IBCURR=$$COB^IBCEF(IBIFN)
+15 IF '$GET(IBEOB)
GOTO EOBELIGX
+16 SET IBDATA=$GET(^IBM(361.1,IBEOB,0))
+17 ; Only MRA EOB's for now if flag = 1
IF $GET(IBMRAF)=1
IF $PIECE(IBDATA,U,4)'=1
GOTO EOBELIGX
+18 ; filing error
IF $DATA(^IBM(361.1,IBEOB,"ERR"))
GOTO EOBELIGX
+19 ; review status - accepted-complete
IF $PIECE(IBDATA,U,16)'=3
GOTO EOBELIGX
+20 ; insurance sequence must exist
IF '$PIECE(IBDATA,U,15)
GOTO EOBELIGX
+21 ; IB*2.0*432/TAZ Don't send EOB data for current payer
+22 ; Don't send EOB data for current payer (this is for retransmits)
IF $PIECE(IBDATA,U,15)=IBCURR
GOTO EOBELIGX
+23 ; Pt Resp Amount for 1500s
SET PTRESP=$PIECE($GET(^IBM(361.1,IBEOB,1)),U,2)
+24 ; for UBs
IF $$FT^IBCEF(+IBDATA)=3
SET PTRESP=$$PTRESPI^IBCECOB1(IBEOB)
+25 ; Denied & No Pt. Resp. & not a split MRA
IF PTRESP'>0
IF $PIECE(IBDATA,U,13)=2
IF '$$SPLIT^IBCEMU1(IBEOB)
GOTO EOBELIGX
+26 ;
+27 SET ELIG=1
EOBELIGX ;
+1 QUIT ELIG
+2 ;
EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible
+1 ; for the secondary claim creation process for a given bill#.
+2 NEW CNT,IEN
+3 SET (CNT,IEN)=0
+4 FOR
SET IEN=$ORDER(^IBM(361.1,"B",+$GET(IBIFN),IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 IF $$EOBELIG(IEN)
SET CNT=CNT+1
+6 QUIT
End DoDot:1
EOBCNTX ;
+1 QUIT CNT
+2 ;
LPTRESP(IBIFN,IBXSAVE,IBXDATA,CL) ; Line level patient responsibility.
+1 ; Added with IB*2.0*473 BI
+2 NEW IBPTZ,IBPTM,IBPTP,IBPTPR,IBPRDATA,IBPTCNT
+3 if '$DATA(CL)
SET CL=17
+4 SET IBPTCNT=0
+5 SET IBPTZ=0
FOR
SET IBPTZ=$ORDER(IBXSAVE("LCOB",IBPTZ))
if 'IBPTZ
QUIT
Begin DoDot:1
+6 SET IBPTM=0
FOR
SET IBPTM=$ORDER(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM))
if 'IBPTM
QUIT
Begin DoDot:2
+7 SET IBPTP=0
FOR
SET IBPTP=$ORDER(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP))
if 'IBPTP
QUIT
Begin DoDot:3
+8 SET IBPTCNT=IBPTCNT+1
+9 IF $$CHKCCOB1(IBIFN,IBPTM)
SET IBXDATA(IBPTCNT)=""
QUIT
+10 IF CL=16
SET IBXDATA(IBPTCNT)="EAF"
QUIT
+11 SET IBXDATA(IBPTCNT)=0
+12 SET IBPTPR=0
FOR
SET IBPTPR=$ORDER(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP,"PR",IBPTPR))
if 'IBPTPR
QUIT
Begin DoDot:4
+13 SET IBPRDATA=$GET(IBXSAVE("LCOB",IBPTZ,"COB",IBPTM,IBPTP,"PR",IBPTPR))
+14 IF +IBPRDATA
SET IBXDATA(IBPTCNT)=IBXDATA(IBPTCNT)+$PIECE(IBPRDATA,U,2)
End DoDot:4
+15 SET IBXDATA(IBPTCNT)=$$DOLLAR^IBCEFG1(IBXDATA(IBPTCNT))
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
LPREXIST(EOBIEN) ; Tests to see if Line Level Patient Responsibility Segments exists.
+1 ; Added with IB*2.0*473 BI
+2 NEW CL,CAS,PR,PRSEQ,PRZ,RESULT
+3 SET RESULT=0
+4 if '$GET(EOBIEN)
QUIT RESULT
+5 SET CL=0
FOR
SET CL=$ORDER(^IBM(361.1,EOBIEN,15,CL))
if +CL=0
QUIT
Begin DoDot:1
+6 SET CAS=0
FOR
SET CAS=$ORDER(^IBM(361.1,EOBIEN,15,CL,CAS))
if +CAS=0
QUIT
Begin DoDot:2
+7 SET PR=$ORDER(^IBM(361.1,EOBIEN,15,CL,CAS,"B","PR",0))
if +PR=0
QUIT
+8 SET PRSEQ=0
FOR
SET PRSEQ=$ORDER(^IBM(361.1,EOBIEN,15,CL,CAS,PR,1,PRSEQ))
if +PRSEQ=0
QUIT
Begin DoDot:3
+9 SET PRZ=$GET(^IBM(361.1,EOBIEN,15,CL,CAS,PR,1,PRSEQ,0))
if '+PRZ
QUIT
+10 SET RESULT=1
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT RESULT
+12 ;
CHKCCOB1(IBIFN,IBS) ; Test to see if Patient Responsibility pieces should be included
+1 ; Added with IB*2.0*473 BI
+2 NEW RESULTS,IBXDATA,EOBIEN
+3 SET RESULTS=1
+4 ; INPUTS: IBIFN - BILL/CLAIM INTERNAL NUMBER
+5 ; IBS - INSURANCE SEQUENCE NUMBER
+6 ; RETURNS: 0 - IF LCOB RECORDS ARE TO BE INCLUDED
+7 ; 1 - IF LCOB RECORDS SHOULD NOT BE INCLUDED
+8 DO CCOB1(IBIFN,0,IBS)
+9 SET EOBIEN=$ORDER(IBXDATA(IBS,0))
+10 SET RESULT='$$LPREXIST(EOBIEN)
+11 QUIT RESULT
+12 ;
+13 ;/IB*2*608 (vd) (US2486) - Added this module of code to be referenced by the Output Formatter.
CKCOBTST(IBXIEN,IBXSAVE,Z0,Z,IBRSBTST) ; Check Primary, Secondary & Tertiary COBS for Claims Resubmitted as Test.
+1 ; INPUT: IBXIEN - Current Claim number
+2 ; IBXSAVE - Array containing current claim COB data.
+3 ; Z0 - Will equal "INPT", "OUTPT" or "RX"
+4 ; Z - Is the LINE
+5 NEW A,CURSEQ,XX
+6 ; Only concerned with Claims that are Resubmitted as Test.
IF '+$GET(IBRSBTST)
MERGE IBXSAVE("LCOB",Z)=IBXSAVE(Z0,Z)
QUIT
+7 SET A=""
SET CURSEQ=$$COBN^IBCEF(IBXIEN)
+8 ; With the line below, ideally, we want to merge all of IBXSAVE(Z0,Z) into IBXSAVE("LCOB",Z),
+9 ; but the COB node should be handled separately for the current sequence.
+10 SET IBXSAVE("LCOB",Z)=IBXSAVE(Z0,Z)
+11 SET XX=""
FOR
SET XX=$ORDER(IBXSAVE(Z0,Z,XX))
if XX=""
QUIT
IF XX'="COB"
MERGE IBXSAVE("LCOB",Z,XX)=IBXSAVE(Z0,Z,XX)
+12 ; Now handle the COB node for the current sequence.
+13 ; Only want to merge those COBS that are previous to the current
FOR
SET A=$ORDER(IBXSAVE(Z0,Z,"COB",A))
if A=""
QUIT
Begin DoDot:1
+14 ; Only want to merge those COBS that are previous to the current sequence.
IF (CURSEQ=A)!(CURSEQ<A)
QUIT
+15 MERGE IBXSAVE("LCOB",Z,"COB",A)=IBXSAVE(Z0,Z,"COB",A)
End DoDot:1
+16 QUIT
+17 ;
