IBCEOB1 ;ALB/TMP/PJH - 835 EDI EOB MSG PROCESSING ;Feb 09, 2018@10:11:43
;;2.0;INTEGRATED BILLING;**137,135,155,296,356,349,431,488,597,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
Q
;
STORE(A,IB0,IBEOB,LEVEL) ;
; A = the string of data to extract and try to store
; each ^ piece is a field to store
; within each ^ piece, there are 5 ';' pieces:
; 1 = piece to extract from the data string;
; 2 = field to update;
; 3 = flag for dollar amt (1=YES);
; 4 = flag for 4-slash stuff without transform (1=YES);
; 5 = flag for numeric/non-dollar amt (1=Yes, 0=No,
; Dn = the field is numeric with 'n' decimal places
; IB0 = the record being processed
; IBEOB = the ien of the EOB entry in file 361.1
; LEVEL = the array that contains the DIE and DA values if stuffing at a
; level other than the top level
;
N B,IBPC,IBFLD,DA,DR,DIE,X,Y
S DR=";"
;
I '$G(LEVEL) S DIE="^IBM(361.1,",DA=IBEOB
;
I $G(LEVEL) D
. N Q
. S DIE=$G(LEVEL("DIE"))
. S Q=0 F S Q=$O(LEVEL(Q)) Q:'Q S DA(Q)=LEVEL(Q)
. S DA=LEVEL(0)
;
I $G(DA) F B=1:1:$L(A,U) D
. S IBPC=$P(A,U,B),IBFLD=$P(IBPC,";",2)
. I $P(IB0,U,+IBPC)'="",IBFLD D
.. N VAL
.. ; For dollar amts, add full cents; For numerics, strip leading
.. ; 0's; For non-numeric/non-dollar amts, make any ; in data into |
.. S VAL=$S($P(IBPC,";",3):$$DOLLAR^IBCEOB($P(IB0,U,+IBPC)),$P(IBPC,";",5):+$P(IB0,U,+IBPC),$P($P(IBPC,";",5),"D",2):$P(IB0,U,+IBPC)/(10**$P($P(IBPC,";",5),"D",2)),1:$TR($P(IB0,U,+IBPC),";","|"))
.. I $P(IBPC,";",3),VAL S VAL=$P(VAL,".")_"."_$E($P(VAL,".",2)_"00",1,2)
.. S DR=DR_IBFLD_"///"_$S($P(IBPC,";",4):"/",1:"")_VAL_";"
;
S DR=$P(DR,";",2,$L(DR,";")-1)
I DR'="" D ^DIE
Q ($D(Y)=0) ;Successfully stored all the data it was sent if $D(Y)=0
;
HDR(IB0,IBEGBL,IBEOB,HIPAA) ; Store header data for EOB
; IB0 = the record being processed from the msg
; IBEOB = the ien of the EOB entry in file 361.1
;
N IBDT,IBDTP,DA,DR,DIE,X,Y
K IBXSAVE("XTRA"),IBZSAVE
;
S HIPAA=+$P(IB0,U,16) ;HIPAA Version code
S IBDT=$P(IB0,U,3),IBDT=$E(IBDT,1,4)-1700_$E(IBDT,5,8)_"."_$P(IB0,U,4)
S IBDTP=$P(IB0,U,9)
I IBDTP S IBDTP=$E(IBDTP,1,4)-1700_$E(IBDTP,5,8)
S DR=$S($P(IB0,U,7)'="":".03////"_$P(IB0,U,7)_";",1:"")_".05////"_IBDT_";.04////"_($P(IB0,U,5)="Y")_";.15///"_$$COBN^IBCEF(+$G(^IBM(361.1,IBEOB,0)))_";.07///"_$P(IB0,U,8)_$S(IBDTP:";.06////"_IBDTP,1:"")
S DIE="^IBM(361.1,",DA=IBEOB
D ^DIE
I $D(Y)'=0 D
. S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad header data"
Q ($D(Y)=0)
;
FINDLN(IB0,IBEOB,IBZDATA,PLREF,ERRCOD) ; Find corresponding billed line for the adj
; IB0 = the record being processed
; NOTE: pieces 3,4,16 are already reformatted
; IBEOB = the ien of the EOB entry in file 361.1
; IBZDATA = the array from the output formatter containing line
; items for the bill. This is passed in so this data only has
; to be extracted once for each bill (the first time in, it
; will be undefined)
; PLREF = Provider Line Reference
; OUTPUT = Line # in the original bill that this adjustment relates to
; ^ paid procedure code if different from original procedure OR
; paid rev code if different from original and no proc code
; ERRCOD = Contains any error condition that may have been encountered
; while conducting the field matching tests.
;
N IBLN,IBLN1,IBBNDL,OCHG,OCHG2,OPROC,OREVCD,IBIFN,IBXARRAY,IBXARRY
N IBXERR,UNITS,UNITS2,UNITS3,IBMOD,Z,Z0,EOBCHG,IBZVLA,IBAMIN,MATCHED,MOD837S
;
S (IBLN,IBLN1)="",IBIFN=+$G(^IBM(361.1,IBEOB,0)),(ERRCOD,MATCHED)=0
S EOBCHG=+$$DOLLAR^IBCEOB($P(IB0,U,15)) ; charges on EOB 40 record
;
; if original procedure exists and is different than the 835 procedure,
; the procedure or revenue code originally billed will be in piece 10
; of the '40' record of the 835 flat file. Otherwise, pc 10 is null.
S IBBNDL=$S($P(IB0,U,10)'="":1,1:0)
;
; If this is a split MRA, build array of Vista line#'s from other split MRA's
I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$$SPLIT^IBCEMU1(IBEOB) D
. N IEN S IEN=0
. F S IEN=$O(^IBM(361.1,"B",IBIFN,IEN)) Q:'IEN I IEN'=IBEOB D
.. I $P($G(^IBM(361.1,IEN,0)),U,4)'=1 Q ; not an MRA
.. I '$$SPLIT^IBCEMU1(IEN) Q ; not a split EOB
.. M IBZVLA=^IBM(361.1,IEN,15,"AC")
.. Q
. Q
;
I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D G FINDLNX ; UB-04 format
. I '$D(IBZDATA) D F^IBCEF("N-UB-04 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
. ; Quit if a Line Item CTRL # exist, skip mismatching process.
. I +PLREF,$D(IBZDATA(+PLREF)) S IBLN=+PLREF_U_$P(IB0,U,10) Q
. ;
. S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D Q:+MATCHED
.. ; Quit if processing an MRA and this VistA line# has already been filed
.. I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
.. ; Quit if split MRA and this VistA line# has already been filed
.. I $D(IBZVLA(Z)) Q
.. I $G(IBZDATA(Z))="" Q
.. ;
.. ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
.. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z)) ; Get the Procedure Code values.
.. ; if not bundled/unbundled
.. I 'IBBNDL D Q
... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) Q ; revenue code
... I OPROC'="",OPROC'=$P(IB0,U,3) Q ; procedure code
... S MATCHED=Z
.. ;
.. ; if bundled/unbundled
.. I IBBNDL D Q
... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) Q ; revenue code
... I OPROC'="",OPROC'=$P(IB0,U,10) Q ; procedure code
... S MATCHED=Z
.. Q
. ;
. I 'MATCHED D Q
.. I $G(IBZDATA(1))="" Q ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
.. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1)) ; Due to no matches, get the info from the 1st line item.
.. I 'IBBNDL D Q
... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) S ERRCOD=1 Q ; revenue code
... I OPROC'="",OPROC'=$P(IB0,U,3) S ERRCOD=2 Q ; procedure code
.. I IBBNDL D Q
... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) S ERRCOD=1 Q ; revenue code
... I OPROC'="",OPROC'=$P(IB0,U,10) S ERRCOD=2 Q ; procedure code
.. Q
. ;
. ; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
. S Z=MATCHED
. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z)) ; Get the Procedure Code values.
. S OCHG=$P(IBZDATA(Z),U,3)*$P(IBZDATA(Z),U,4) ; Total charge from bill
. S OCHG2=+$P(IBZDATA(Z),U,5)
. I OCHG'=EOBCHG,OCHG2=EOBCHG S OCHG=OCHG2 ; update OCHG
. ;
. ; if not bundled/unbundled
. I 'IBBNDL D Q
.. I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) S ERRCOD=3 Q ; original units
.. I +OCHG'=EOBCHG S ERRCOD=4 Q ; original charges
.. I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,5,8),.MOD837S),'$$MODMATCH($P($P(IBZDATA(Z),U,9),",",1),$P(IB0,U,5),.MOD837S) S ERRCOD=5_U_MOD837S Q ; modifiers
.. S IBLN=Z
.. Q
. ;
. ; if bundled/unbundled
. I IBBNDL D Q
.. I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) S ERRCOD=3 Q ; original units
.. I +OCHG'=EOBCHG S ERRCOD=4 Q ; original charges
.. I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,11,14),.MOD837S),'$$MODMATCH($P($P(IBZDATA(Z),U,9),",",1),$P(IB0,U,11),.MOD837S) S ERRCOD=5_U_MOD837S Q ; modifiers
.. S IBLN=Z_U_$S(OPROC'="":OPROC,1:OREVCD)
.. Q
. ; When dealing with Inpatient UB-04's, check for revenue code roll-ups
. I 'IBLN,$$INPAT^IBCEF(IBIFN,1) D RCRU^IBCEOB00(.IBZDATA,IB0,.IBLN)
. ; If only 1 rev code and charges are the same, assume a match
. I 'IBLN,'$P($G(^IBM(361.1,IBEOB,0)),U,4),$O(IBZDATA(""),-1)=$O(IBZDATA("")),+OCHG=EOBCHG S IBLN=+$O(IBZDATA(""))_U_OREVCD
;
; At this point, we can assume the claim is CMS-1500 format
;JWS;IB*2.0*592;need to be form specific with line level data collection call using output formatter
I '$D(IBZDATA) D
. I $$FT^IBCEF(IBIFN)=2 D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)","IBZDATA",,IBIFN) Q
. I $$FT^IBCEF(IBIFN)=7 D F^IBCEF("N-HCFA SERVICE LINE CALLABLE","IBZDATA",,IBIFN)
I +PLREF,$D(IBZDATA(+PLREF)) S IBLN=PLREF_U_$P(IB0,U,10) G FINDLNX ; If a Line Item CTRL # exist, skip mismatching process.
;
S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D Q:+MATCHED
. ; Quit if processing an MRA and this VistA line# has already been filed
. I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
. ; Quit if split MRA and this VistA line# has already been filed
. I $D(IBZVLA(Z)) Q
. I $G(IBZDATA(Z))="" Q
. ;
. ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z)) ; Get the Procedure Code values.
. I OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10)) Q ;procedure code.
. S MATCHED=Z
. Q
;
I 'MATCHED D G FINDLNX
. I $G(IBZDATA(1))="" Q ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1)) ; Because no matches, get the information from the 1st line item.
. I OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10)) S ERRCOD=2 ; Mis-matched Proc Code.
;
; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
S Z=MATCHED
; Quit if processing an MRA and this VistA line# has already been filed
I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) G FINDLNX
; Quit if split MRA and this VistA line# has already been filed
I $D(IBZVLA(Z)) G FINDLNX
I $G(IBZDATA(Z))="" G FINDLNX
;
S OCHG=$P(IBZDATA(Z),U,8)*$P(IBZDATA(Z),U,9) ; charge from bill
S IBAMIN=""
I $P(IBZDATA(Z),U,12)'="" S IBAMIN=$P(IBZDATA(Z),U,12) ;anesthesia minutes
S UNITS=$S('IBAMIN:$P(IBZDATA(Z),U,9),1:IBAMIN/15)
; original units from bill or anesthesia minutes calculation
I $P(UNITS,".",2) S UNITS=$FN(UNITS,"",1) ; round to a single decimal place for fractional units
I $P($P(IB0,U,16),".",2) S $P(IB0,U,16)=$FN($P(IB0,U,16),"",1)
S UNITS2=$P(IBZDATA(Z),U,9) ; just the units
; UNITS3 is the number of anesthesia minutes divided by 10, or nil.
; Solution to get around the Trailblazers bug for MRAs
S UNITS3=""
I IBAMIN'=0 S UNITS3=IBAMIN/10
;
I UNITS'=$P(IB0,U,16),UNITS2'=$P(IB0,U,16),UNITS3'=$P(IB0,U,16),IBAMIN'=$P(IB0,U,16) S ERRCOD=3 G FINDLNX ; Original units
I $$DOLLAR^IBCEFG1(OCHG)'=+$P(IB0,U,15) S ERRCOD=4 G FINDLNX ; original charges.
I $S($P(IB0,U,19):$P(IB0,U,19)=$P(IBZDATA(Z),U),1:1) D G:+ERRCOD FINDLNX
. ;Original procedure/chg/units/date have matched in order to get here
. ;Check matching original modifiers
. I '$$MODMATCH($$MODLST^IBEFUNC2($P(IBZDATA(Z),U,10)),$S('IBBNDL:$P(IB0,U,5,8),1:$P(IB0,U,11,14)),.MOD837S) S ERRCOD=5_U_MOD837S Q ; modifiers.
. S IBLN=Z_$S(IBBNDL:U_OPROC,1:"")
I 'IBLN,IBLN1 S IBLN=IBLN1
;
FINDLNX ;
Q IBLN
;
GTPRCD(IBBNDL,OPROC,OREVCD,IBZREC) ; Set up the Procedure Code/Revenue Code fields.
N CPT
;
I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D Q ; For UB-04s
. S CPT=$P(IBZREC,U,2) ; proc from bill
. I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; non-numeric proc
. S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; ext proc code
. S OREVCD=+$P($G(^DGCR(399.2,+IBZREC,0)),U) ; Rev cd from bill
;
; For CMS-1500s
S CPT=$P(IBZREC,U,5) ; proc from bill
I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; non-numeric proc
S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; ext proc code
Q
;
MODMATCH(IB,MODLST,MOD837S) ; Match modifiers
; IB = the list of modifiers iens from the bill, comma delimited
; MODLST = the 4 '^' pieces of the reported modifiers
;
N MODOK,Q,Z0,IBMOD,MMOD
S MODOK=1,MOD837S=""
I $TR(IB,",")'="" F Q=1:1:$L(IB,",") S Z0=$P(IB,",",Q) I Z0'="" D
. S IBMOD(Z0)=$G(IBMOD(Z0))+1
. I '$L(MOD837S) S MOD837S=Z0 Q
. S MOD837S=MOD837S_","_Z0
I $TR(MODLST,U)="",$O(IBMOD(""))="" G MODQ ; No modifiers used
;
; No match if no VistA modifiers, but there are MRA modifiers
I $TR(MODLST,U)'="",$O(IBMOD(""))="" S MODOK=0 G MODQ
;
; Evaluate each MRA modifier
F Z0=1:1:4 D
. S MMOD=$P(MODLST,U,Z0) Q:MMOD="" ; individual MRA modifier
. I '$D(IBMOD(MMOD)) Q ; not in array so just quit
. S IBMOD(MMOD)=IBMOD(MMOD)-1 ; decrement array counter
. I 'IBMOD(MMOD) KILL IBMOD(MMOD) ; if 0, then kill array entry
. Q
;
I $O(IBMOD(""))'="" S MODOK=0 ; All submitted mods not matched
MODQ Q MODOK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEOB1 12465 printed Dec 13, 2024@02:11:21 Page 2
IBCEOB1 ;ALB/TMP/PJH - 835 EDI EOB MSG PROCESSING ;Feb 09, 2018@10:11:43
+1 ;;2.0;INTEGRATED BILLING;**137,135,155,296,356,349,431,488,597,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
STORE(A,IB0,IBEOB,LEVEL) ;
+1 ; A = the string of data to extract and try to store
+2 ; each ^ piece is a field to store
+3 ; within each ^ piece, there are 5 ';' pieces:
+4 ; 1 = piece to extract from the data string;
+5 ; 2 = field to update;
+6 ; 3 = flag for dollar amt (1=YES);
+7 ; 4 = flag for 4-slash stuff without transform (1=YES);
+8 ; 5 = flag for numeric/non-dollar amt (1=Yes, 0=No,
+9 ; Dn = the field is numeric with 'n' decimal places
+10 ; IB0 = the record being processed
+11 ; IBEOB = the ien of the EOB entry in file 361.1
+12 ; LEVEL = the array that contains the DIE and DA values if stuffing at a
+13 ; level other than the top level
+14 ;
+15 NEW B,IBPC,IBFLD,DA,DR,DIE,X,Y
+16 SET DR=";"
+17 ;
+18 IF '$GET(LEVEL)
SET DIE="^IBM(361.1,"
SET DA=IBEOB
+19 ;
+20 IF $GET(LEVEL)
Begin DoDot:1
+21 NEW Q
+22 SET DIE=$GET(LEVEL("DIE"))
+23 SET Q=0
FOR
SET Q=$ORDER(LEVEL(Q))
if 'Q
QUIT
SET DA(Q)=LEVEL(Q)
+24 SET DA=LEVEL(0)
End DoDot:1
+25 ;
+26 IF $GET(DA)
FOR B=1:1:$LENGTH(A,U)
Begin DoDot:1
+27 SET IBPC=$PIECE(A,U,B)
SET IBFLD=$PIECE(IBPC,";",2)
+28 IF $PIECE(IB0,U,+IBPC)'=""
IF IBFLD
Begin DoDot:2
+29 NEW VAL
+30 ; For dollar amts, add full cents; For numerics, strip leading
+31 ; 0's; For non-numeric/non-dollar amts, make any ; in data into |
+32 SET VAL=$SELECT($PIECE(IBPC,";",3):$$DOLLAR^IBCEOB($PIECE(IB0,U,+IBPC)),$PIECE(IBPC,";",5):+$PIECE(IB0,U,+IBPC),$PIECE($PIECE(IBPC,";",5),"D",2):$PIECE(IB0,U,+IBPC)/(10**$PIECE($PIECE(IBPC,";",5),"D",2)),1:$TRANSLATE($PI
ECE(IB0,U,+IBPC),";","|"))
+33 IF $PIECE(IBPC,";",3)
IF VAL
SET VAL=$PIECE(VAL,".")_"."_$EXTRACT($PIECE(VAL,".",2)_"00",1,2)
+34 SET DR=DR_IBFLD_"///"_$SELECT($PIECE(IBPC,";",4):"/",1:"")_VAL_";"
End DoDot:2
End DoDot:1
+35 ;
+36 SET DR=$PIECE(DR,";",2,$LENGTH(DR,";")-1)
+37 IF DR'=""
DO ^DIE
+38 ;Successfully stored all the data it was sent if $D(Y)=0
QUIT ($DATA(Y)=0)
+39 ;
HDR(IB0,IBEGBL,IBEOB,HIPAA) ; Store header data for EOB
+1 ; IB0 = the record being processed from the msg
+2 ; IBEOB = the ien of the EOB entry in file 361.1
+3 ;
+4 NEW IBDT,IBDTP,DA,DR,DIE,X,Y
+5 KILL IBXSAVE("XTRA"),IBZSAVE
+6 ;
+7 ;HIPAA Version code
SET HIPAA=+$PIECE(IB0,U,16)
+8 SET IBDT=$PIECE(IB0,U,3)
SET IBDT=$EXTRACT(IBDT,1,4)-1700_$EXTRACT(IBDT,5,8)_"."_$PIECE(IB0,U,4)
+9 SET IBDTP=$PIECE(IB0,U,9)
+10 IF IBDTP
SET IBDTP=$EXTRACT(IBDTP,1,4)-1700_$EXTRACT(IBDTP,5,8)
+11 SET DR=$SELECT($PIECE(IB0,U,7)'="":".03////"_$PIECE(IB0,U,7)_";",1:"")_".05////"_IBDT_";.04////"_($PIECE(IB0,U,5)="Y")_";.15///"_$$COBN^IBCEF(+$GET(^IBM(361.1,IBEOB,0)))_";.07///"_$PIECE(IB0,U,8)_$SELECT(IBDTP:";.06////"_IBDTP,1:"")
+12 SET DIE="^IBM(361.1,"
SET DA=IBEOB
+13 DO ^DIE
+14 IF $DATA(Y)'=0
Begin DoDot:1
+15 SET ^TMP(IBEGBL,$JOB,+$ORDER(^TMP(IBEGBL,$JOB,""),-1)+1)="Bad header data"
End DoDot:1
+16 QUIT ($DATA(Y)=0)
+17 ;
FINDLN(IB0,IBEOB,IBZDATA,PLREF,ERRCOD) ; Find corresponding billed line for the adj
+1 ; IB0 = the record being processed
+2 ; NOTE: pieces 3,4,16 are already reformatted
+3 ; IBEOB = the ien of the EOB entry in file 361.1
+4 ; IBZDATA = the array from the output formatter containing line
+5 ; items for the bill. This is passed in so this data only has
+6 ; to be extracted once for each bill (the first time in, it
+7 ; will be undefined)
+8 ; PLREF = Provider Line Reference
+9 ; OUTPUT = Line # in the original bill that this adjustment relates to
+10 ; ^ paid procedure code if different from original procedure OR
+11 ; paid rev code if different from original and no proc code
+12 ; ERRCOD = Contains any error condition that may have been encountered
+13 ; while conducting the field matching tests.
+14 ;
+15 NEW IBLN,IBLN1,IBBNDL,OCHG,OCHG2,OPROC,OREVCD,IBIFN,IBXARRAY,IBXARRY
+16 NEW IBXERR,UNITS,UNITS2,UNITS3,IBMOD,Z,Z0,EOBCHG,IBZVLA,IBAMIN,MATCHED,MOD837S
+17 ;
+18 SET (IBLN,IBLN1)=""
SET IBIFN=+$GET(^IBM(361.1,IBEOB,0))
SET (ERRCOD,MATCHED)=0
+19 ; charges on EOB 40 record
SET EOBCHG=+$$DOLLAR^IBCEOB($PIECE(IB0,U,15))
+20 ;
+21 ; if original procedure exists and is different than the 835 procedure,
+22 ; the procedure or revenue code originally billed will be in piece 10
+23 ; of the '40' record of the 835 flat file. Otherwise, pc 10 is null.
+24 SET IBBNDL=$SELECT($PIECE(IB0,U,10)'="":1,1:0)
+25 ;
+26 ; If this is a split MRA, build array of Vista line#'s from other split MRA's
+27 IF $PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)=1
IF $$SPLIT^IBCEMU1(IBEOB)
Begin DoDot:1
+28 NEW IEN
SET IEN=0
+29 FOR
SET IEN=$ORDER(^IBM(361.1,"B",IBIFN,IEN))
if 'IEN
QUIT
IF IEN'=IBEOB
Begin DoDot:2
+30 ; not an MRA
IF $PIECE($GET(^IBM(361.1,IEN,0)),U,4)'=1
QUIT
+31 ; not a split EOB
IF '$$SPLIT^IBCEMU1(IEN)
QUIT
+32 MERGE IBZVLA=^IBM(361.1,IEN,15,"AC")
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 ;
+36 ; UB-04 format
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,19)=3
Begin DoDot:1
+37 IF '$DATA(IBZDATA)
DO F^IBCEF("N-UB-04 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
+38 ; Quit if a Line Item CTRL # exist, skip mismatching process.
+39 IF +PLREF
IF $DATA(IBZDATA(+PLREF))
SET IBLN=+PLREF_U_$PIECE(IB0,U,10)
QUIT
+40 ;
+41 SET Z=0
FOR
SET Z=$ORDER(IBZDATA(Z))
if 'Z
QUIT
Begin DoDot:2
+42 ; Quit if processing an MRA and this VistA line# has already been filed
+43 IF $PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)=1
IF $DATA(^IBM(361.1,IBEOB,15,"AC",Z))
QUIT
+44 ; Quit if split MRA and this VistA line# has already been filed
+45 IF $DATA(IBZVLA(Z))
QUIT
+46 IF $GET(IBZDATA(Z))=""
QUIT
+47 ;
+48 ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
+49 ; Get the Procedure Code values.
DO GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))
+50 ; if not bundled/unbundled
+51 IF 'IBBNDL
Begin DoDot:3
+52 ; revenue code
IF OPROC=""
IF OREVCD
IF OREVCD'=$PIECE(IB0,U,4)
QUIT
+53 ; procedure code
IF OPROC'=""
IF OPROC'=$PIECE(IB0,U,3)
QUIT
+54 SET MATCHED=Z
End DoDot:3
QUIT
+55 ;
+56 ; if bundled/unbundled
+57 IF IBBNDL
Begin DoDot:3
+58 ; revenue code
IF OPROC=""
IF OREVCD
IF OREVCD'=+$PIECE(IB0,U,10)
QUIT
+59 ; procedure code
IF OPROC'=""
IF OPROC'=$PIECE(IB0,U,10)
QUIT
+60 SET MATCHED=Z
End DoDot:3
QUIT
+61 QUIT
End DoDot:2
if +MATCHED
QUIT
+62 ;
+63 IF 'MATCHED
Begin DoDot:2
+64 ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
IF $GET(IBZDATA(1))=""
QUIT
+65 ; Due to no matches, get the info from the 1st line item.
DO GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1))
+66 IF 'IBBNDL
Begin DoDot:3
+67 ; revenue code
IF OPROC=""
IF OREVCD
IF OREVCD'=$PIECE(IB0,U,4)
SET ERRCOD=1
QUIT
+68 ; procedure code
IF OPROC'=""
IF OPROC'=$PIECE(IB0,U,3)
SET ERRCOD=2
QUIT
End DoDot:3
QUIT
+69 IF IBBNDL
Begin DoDot:3
+70 ; revenue code
IF OPROC=""
IF OREVCD
IF OREVCD'=+$PIECE(IB0,U,10)
SET ERRCOD=1
QUIT
+71 ; procedure code
IF OPROC'=""
IF OPROC'=$PIECE(IB0,U,10)
SET ERRCOD=2
QUIT
End DoDot:3
QUIT
+72 QUIT
End DoDot:2
QUIT
+73 ;
+74 ; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
+75 SET Z=MATCHED
+76 ; Get the Procedure Code values.
DO GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))
+77 ; Total charge from bill
SET OCHG=$PIECE(IBZDATA(Z),U,3)*$PIECE(IBZDATA(Z),U,4)
+78 SET OCHG2=+$PIECE(IBZDATA(Z),U,5)
+79 ; update OCHG
IF OCHG'=EOBCHG
IF OCHG2=EOBCHG
SET OCHG=OCHG2
+80 ;
+81 ; if not bundled/unbundled
+82 IF 'IBBNDL
Begin DoDot:2
+83 ; original units
IF +$PIECE(IBZDATA(Z),U,4)'=$PIECE(IB0,U,16)
SET ERRCOD=3
QUIT
+84 ; original charges
IF +OCHG'=EOBCHG
SET ERRCOD=4
QUIT
+85 ; modifiers
IF '$$MODMATCH($PIECE(IBZDATA(Z),U,9),$PIECE(IB0,U,5,8),.MOD837S)
IF '$$MODMATCH($PIECE($PIECE(IBZDATA(Z),U,9),",",1),$PIECE(IB0,U,5),.MOD837S)
SET ERRCOD=5_U_MOD837S
QUIT
+86 SET IBLN=Z
+87 QUIT
End DoDot:2
QUIT
+88 ;
+89 ; if bundled/unbundled
+90 IF IBBNDL
Begin DoDot:2
+91 ; original units
IF +$PIECE(IBZDATA(Z),U,4)'=$PIECE(IB0,U,16)
SET ERRCOD=3
QUIT
+92 ; original charges
IF +OCHG'=EOBCHG
SET ERRCOD=4
QUIT
+93 ; modifiers
IF '$$MODMATCH($PIECE(IBZDATA(Z),U,9),$PIECE(IB0,U,11,14),.MOD837S)
IF '$$MODMATCH($PIECE($PIECE(IBZDATA(Z),U,9),",",1),$PIECE(IB0,U,11),.MOD837S)
SET ERRCOD=5_U_MOD837S
QUIT
+94 SET IBLN=Z_U_$SELECT(OPROC'="":OPROC,1:OREVCD)
+95 QUIT
End DoDot:2
QUIT
+96 ; When dealing with Inpatient UB-04's, check for revenue code roll-ups
+97 IF 'IBLN
IF $$INPAT^IBCEF(IBIFN,1)
DO RCRU^IBCEOB00(.IBZDATA,IB0,.IBLN)
+98 ; If only 1 rev code and charges are the same, assume a match
+99 IF 'IBLN
IF '$PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)
IF $ORDER(IBZDATA(""),-1)=$ORDER(IBZDATA(""))
IF +OCHG=EOBCHG
SET IBLN=+$ORDER(IBZDATA(""))_U_OREVCD
End DoDot:1
GOTO FINDLNX
+100 ;
+101 ; At this point, we can assume the claim is CMS-1500 format
+102 ;JWS;IB*2.0*592;need to be form specific with line level data collection call using output formatter
+103 IF '$DATA(IBZDATA)
Begin DoDot:1
+104 IF $$FT^IBCEF(IBIFN)=2
DO F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
QUIT
+105 IF $$FT^IBCEF(IBIFN)=7
DO F^IBCEF("N-HCFA SERVICE LINE CALLABLE","IBZDATA",,IBIFN)
End DoDot:1
+106 ; If a Line Item CTRL # exist, skip mismatching process.
IF +PLREF
IF $DATA(IBZDATA(+PLREF))
SET IBLN=PLREF_U_$PIECE(IB0,U,10)
GOTO FINDLNX
+107 ;
+108 SET Z=0
FOR
SET Z=$ORDER(IBZDATA(Z))
if 'Z
QUIT
Begin DoDot:1
+109 ; Quit if processing an MRA and this VistA line# has already been filed
+110 IF $PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)=1
IF $DATA(^IBM(361.1,IBEOB,15,"AC",Z))
QUIT
+111 ; Quit if split MRA and this VistA line# has already been filed
+112 IF $DATA(IBZVLA(Z))
QUIT
+113 IF $GET(IBZDATA(Z))=""
QUIT
+114 ;
+115 ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
+116 ; Get the Procedure Code values.
DO GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))
+117 ;procedure code.
IF OPROC'=$SELECT('IBBNDL:$PIECE(IB0,U,3),1:$PIECE(IB0,U,10))
QUIT
+118 SET MATCHED=Z
+119 QUIT
End DoDot:1
if +MATCHED
QUIT
+120 ;
+121 IF 'MATCHED
Begin DoDot:1
+122 ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
IF $GET(IBZDATA(1))=""
QUIT
+123 ; Because no matches, get the information from the 1st line item.
DO GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1))
+124 ; Mis-matched Proc Code.
IF OPROC'=$SELECT('IBBNDL:$PIECE(IB0,U,3),1:$PIECE(IB0,U,10))
SET ERRCOD=2
End DoDot:1
GOTO FINDLNX
+125 ;
+126 ; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
+127 SET Z=MATCHED
+128 ; Quit if processing an MRA and this VistA line# has already been filed
+129 IF $PIECE($GET(^IBM(361.1,IBEOB,0)),U,4)=1
IF $DATA(^IBM(361.1,IBEOB,15,"AC",Z))
GOTO FINDLNX
+130 ; Quit if split MRA and this VistA line# has already been filed
+131 IF $DATA(IBZVLA(Z))
GOTO FINDLNX
+132 IF $GET(IBZDATA(Z))=""
GOTO FINDLNX
+133 ;
+134 ; charge from bill
SET OCHG=$PIECE(IBZDATA(Z),U,8)*$PIECE(IBZDATA(Z),U,9)
+135 SET IBAMIN=""
+136 ;anesthesia minutes
IF $PIECE(IBZDATA(Z),U,12)'=""
SET IBAMIN=$PIECE(IBZDATA(Z),U,12)
+137 SET UNITS=$SELECT('IBAMIN:$PIECE(IBZDATA(Z),U,9),1:IBAMIN/15)
+138 ; original units from bill or anesthesia minutes calculation
+139 ; round to a single decimal place for fractional units
IF $PIECE(UNITS,".",2)
SET UNITS=$FNUMBER(UNITS,"",1)
+140 IF $PIECE($PIECE(IB0,U,16),".",2)
SET $PIECE(IB0,U,16)=$FNUMBER($PIECE(IB0,U,16),"",1)
+141 ; just the units
SET UNITS2=$PIECE(IBZDATA(Z),U,9)
+142 ; UNITS3 is the number of anesthesia minutes divided by 10, or nil.
+143 ; Solution to get around the Trailblazers bug for MRAs
+144 SET UNITS3=""
+145 IF IBAMIN'=0
SET UNITS3=IBAMIN/10
+146 ;
+147 ; Original units
IF UNITS'=$PIECE(IB0,U,16)
IF UNITS2'=$PIECE(IB0,U,16)
IF UNITS3'=$PIECE(IB0,U,16)
IF IBAMIN'=$PIECE(IB0,U,16)
SET ERRCOD=3
GOTO FINDLNX
+148 ; original charges.
IF $$DOLLAR^IBCEFG1(OCHG)'=+$PIECE(IB0,U,15)
SET ERRCOD=4
GOTO FINDLNX
+149 IF $SELECT($PIECE(IB0,U,19):$PIECE(IB0,U,19)=$PIECE(IBZDATA(Z),U),1:1)
Begin DoDot:1
+150 ;Original procedure/chg/units/date have matched in order to get here
+151 ;Check matching original modifiers
+152 ; modifiers.
IF '$$MODMATCH($$MODLST^IBEFUNC2($PIECE(IBZDATA(Z),U,10)),$SELECT('IBBNDL:$PIECE(IB0,U,5,8),1:$PIECE(IB0,U,11,14)),.MOD837S)
SET ERRCOD=5_U_MOD837S
QUIT
+153 SET IBLN=Z_$SELECT(IBBNDL:U_OPROC,1:"")
End DoDot:1
if +ERRCOD
GOTO FINDLNX
+154 IF 'IBLN
IF IBLN1
SET IBLN=IBLN1
+155 ;
FINDLNX ;
+1 QUIT IBLN
+2 ;
GTPRCD(IBBNDL,OPROC,OREVCD,IBZREC) ; Set up the Procedure Code/Revenue Code fields.
+1 NEW CPT
+2 ;
+3 ; For UB-04s
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,19)=3
Begin DoDot:1
+4 ; proc from bill
SET CPT=$PIECE(IBZREC,U,2)
+5 ; non-numeric proc
IF CPT'?.N
IF CPT'=""
SET CPT=$ORDER(^ICPT("B",CPT,""))
+6 ; ext proc code
SET OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(")
+7 ; Rev cd from bill
SET OREVCD=+$PIECE($GET(^DGCR(399.2,+IBZREC,0)),U)
End DoDot:1
QUIT
+8 ;
+9 ; For CMS-1500s
+10 ; proc from bill
SET CPT=$PIECE(IBZREC,U,5)
+11 ; non-numeric proc
IF CPT'?.N
IF CPT'=""
SET CPT=$ORDER(^ICPT("B",CPT,""))
+12 ; ext proc code
SET OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(")
+13 QUIT
+14 ;
MODMATCH(IB,MODLST,MOD837S) ; Match modifiers
+1 ; IB = the list of modifiers iens from the bill, comma delimited
+2 ; MODLST = the 4 '^' pieces of the reported modifiers
+3 ;
+4 NEW MODOK,Q,Z0,IBMOD,MMOD
+5 SET MODOK=1
SET MOD837S=""
+6 IF $TRANSLATE(IB,",")'=""
FOR Q=1:1:$LENGTH(IB,",")
SET Z0=$PIECE(IB,",",Q)
IF Z0'=""
Begin DoDot:1
+7 SET IBMOD(Z0)=$GET(IBMOD(Z0))+1
+8 IF '$LENGTH(MOD837S)
SET MOD837S=Z0
QUIT
+9 SET MOD837S=MOD837S_","_Z0
End DoDot:1
+10 ; No modifiers used
IF $TRANSLATE(MODLST,U)=""
IF $ORDER(IBMOD(""))=""
GOTO MODQ
+11 ;
+12 ; No match if no VistA modifiers, but there are MRA modifiers
+13 IF $TRANSLATE(MODLST,U)'=""
IF $ORDER(IBMOD(""))=""
SET MODOK=0
GOTO MODQ
+14 ;
+15 ; Evaluate each MRA modifier
+16 FOR Z0=1:1:4
Begin DoDot:1
+17 ; individual MRA modifier
SET MMOD=$PIECE(MODLST,U,Z0)
if MMOD=""
QUIT
+18 ; not in array so just quit
IF '$DATA(IBMOD(MMOD))
QUIT
+19 ; decrement array counter
SET IBMOD(MMOD)=IBMOD(MMOD)-1
+20 ; if 0, then kill array entry
IF 'IBMOD(MMOD)
KILL IBMOD(MMOD)
+21 QUIT
End DoDot:1
+22 ;
+23 ; All submitted mods not matched
IF $ORDER(IBMOD(""))'=""
SET MODOK=0
MODQ QUIT MODOK
+1 ;
