Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEOB1

IBCEOB1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. STORE(A,IB0,IBEOB,LEVEL) ;
  1.  ; A = the string of data to extract and try to store
  1.  ;       each ^ piece is a field to store
  1.  ;         within each ^ piece, there are 5 ';' pieces:
  1.  ;            1 = piece to extract from the data string;
  1.  ;            2 = field to update;
  1.  ;            3 = flag for dollar amt (1=YES);
  1.  ;            4 = flag for 4-slash stuff without transform (1=YES);
  1.  ;            5 = flag for numeric/non-dollar amt (1=Yes, 0=No,
  1.  ;                 Dn = the field is numeric with 'n' decimal places
  1.  ; IB0 = the record being processed
  1.  ; IBEOB = the ien of the EOB entry in file 361.1
  1.  ; LEVEL = the array that contains the DIE and DA values if stuffing at a
  1.  ;         level other than the top level
  1.  ;
  1.  N B,IBPC,IBFLD,DA,DR,DIE,X,Y
  1.  S DR=";"
  1.  ;
  1.  I '$G(LEVEL) S DIE="^IBM(361.1,",DA=IBEOB
  1.  ;
  1.  I $G(LEVEL) D
  1.  . N Q
  1.  . S DIE=$G(LEVEL("DIE"))
  1.  . S Q=0 F  S Q=$O(LEVEL(Q)) Q:'Q  S DA(Q)=LEVEL(Q)
  1.  . S DA=LEVEL(0)
  1.  ;
  1.  I $G(DA) F B=1:1:$L(A,U) D
  1.  . S IBPC=$P(A,U,B),IBFLD=$P(IBPC,";",2)
  1.  . I $P(IB0,U,+IBPC)'="",IBFLD D
  1.  .. N VAL
  1.  .. ; For dollar amts, add full cents; For numerics, strip leading
  1.  .. ;   0's; For non-numeric/non-dollar amts, make any ; in data into |
  1.  .. 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),";","|"))
  1.  .. I $P(IBPC,";",3),VAL S VAL=$P(VAL,".")_"."_$E($P(VAL,".",2)_"00",1,2)
  1.  .. S DR=DR_IBFLD_"///"_$S($P(IBPC,";",4):"/",1:"")_VAL_";"
  1.  ;
  1.  S DR=$P(DR,";",2,$L(DR,";")-1)
  1.  I DR'="" D ^DIE
  1.  Q ($D(Y)=0) ;Successfully stored all the data it was sent if $D(Y)=0
  1.  ;
  1. HDR(IB0,IBEGBL,IBEOB,HIPAA) ; Store header data for EOB
  1.  ; IB0 = the record being processed from the msg
  1.  ; IBEOB = the ien of the EOB entry in file 361.1
  1.  ;
  1.  N IBDT,IBDTP,DA,DR,DIE,X,Y
  1.  K IBXSAVE("XTRA"),IBZSAVE
  1.  ;
  1.  S HIPAA=+$P(IB0,U,16) ;HIPAA Version code
  1.  S IBDT=$P(IB0,U,3),IBDT=$E(IBDT,1,4)-1700_$E(IBDT,5,8)_"."_$P(IB0,U,4)
  1.  S IBDTP=$P(IB0,U,9)
  1.  I IBDTP S IBDTP=$E(IBDTP,1,4)-1700_$E(IBDTP,5,8)
  1.  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:"")
  1.  S DIE="^IBM(361.1,",DA=IBEOB
  1.  D ^DIE
  1.  I $D(Y)'=0 D
  1.  . S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad header data"
  1.  Q ($D(Y)=0)
  1.  ;
  1. FINDLN(IB0,IBEOB,IBZDATA,PLREF,ERRCOD) ; Find corresponding billed line for the adj
  1.  ; IB0 = the record being processed
  1.  ;       NOTE: pieces 3,4,16 are already reformatted
  1.  ; IBEOB = the ien of the EOB entry in file 361.1
  1.  ; IBZDATA = the array from the output formatter containing line
  1.  ;           items for the bill.  This is passed in so this data only has
  1.  ;           to be extracted once for each bill (the first time in, it
  1.  ;           will be undefined)
  1.  ; PLREF = Provider Line Reference
  1.  ; OUTPUT = Line # in the original bill that this adjustment relates to
  1.  ;          ^ paid procedure code if different from original procedure OR
  1.  ;            paid rev code if different from original and no proc code
  1.  ; ERRCOD = Contains any error condition that may have been encountered
  1.  ;            while conducting the field matching tests.
  1.  ;
  1.  N IBLN,IBLN1,IBBNDL,OCHG,OCHG2,OPROC,OREVCD,IBIFN,IBXARRAY,IBXARRY
  1.  N IBXERR,UNITS,UNITS2,UNITS3,IBMOD,Z,Z0,EOBCHG,IBZVLA,IBAMIN,MATCHED,MOD837S
  1.  ;
  1.  S (IBLN,IBLN1)="",IBIFN=+$G(^IBM(361.1,IBEOB,0)),(ERRCOD,MATCHED)=0
  1.  S EOBCHG=+$$DOLLAR^IBCEOB($P(IB0,U,15))   ; charges on EOB 40 record
  1.  ;
  1.  ; if original procedure exists and is different than the 835 procedure,
  1.  ; the procedure or revenue code originally billed will be in piece 10
  1.  ; of the '40' record of the 835 flat file.  Otherwise, pc 10 is null.
  1.  S IBBNDL=$S($P(IB0,U,10)'="":1,1:0)
  1.  ;
  1.  ; If this is a split MRA, build array of Vista line#'s from other split MRA's
  1.  I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$$SPLIT^IBCEMU1(IBEOB) D
  1.  . N IEN S IEN=0
  1.  . F  S IEN=$O(^IBM(361.1,"B",IBIFN,IEN)) Q:'IEN  I IEN'=IBEOB D
  1.  .. I $P($G(^IBM(361.1,IEN,0)),U,4)'=1 Q    ; not an MRA
  1.  .. I '$$SPLIT^IBCEMU1(IEN) Q               ; not a split EOB
  1.  .. M IBZVLA=^IBM(361.1,IEN,15,"AC")
  1.  .. Q
  1.  . Q
  1.  ;
  1.  I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D  G FINDLNX     ; UB-04 format
  1.  . I '$D(IBZDATA) D F^IBCEF("N-UB-04 SERVICE LINE (EDI)","IBZDATA",,IBIFN)
  1.  . ; Quit if a Line Item CTRL # exist, skip mismatching process.
  1.  . I +PLREF,$D(IBZDATA(+PLREF)) S IBLN=+PLREF_U_$P(IB0,U,10) Q
  1.  . ;
  1.  . S Z=0 F  S Z=$O(IBZDATA(Z)) Q:'Z  D  Q:+MATCHED
  1.  .. ; Quit if processing an MRA and this VistA line# has already been filed
  1.  .. I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
  1.  .. ; Quit if split MRA and this VistA line# has already been filed
  1.  .. I $D(IBZVLA(Z)) Q
  1.  .. I $G(IBZDATA(Z))="" Q
  1.  .. ;
  1.  .. ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
  1.  .. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))      ; Get the Procedure Code values.
  1.  .. ; if not bundled/unbundled
  1.  .. I 'IBBNDL D  Q
  1.  ... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) Q      ; revenue code
  1.  ... I OPROC'="",OPROC'=$P(IB0,U,3) Q             ; procedure code
  1.  ... S MATCHED=Z
  1.  .. ;
  1.  .. ; if bundled/unbundled
  1.  .. I IBBNDL D  Q
  1.  ... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) Q    ; revenue code
  1.  ... I OPROC'="",OPROC'=$P(IB0,U,10) Q            ; procedure code
  1.  ... S MATCHED=Z
  1.  .. Q
  1.  . ;
  1.  . I 'MATCHED D  Q
  1.  .. I $G(IBZDATA(1))="" Q  ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
  1.  .. D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1))  ; Due to no matches, get the info from the 1st line item.
  1.  .. I 'IBBNDL D  Q
  1.  ... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) S ERRCOD=1 Q      ; revenue code
  1.  ... I OPROC'="",OPROC'=$P(IB0,U,3) S ERRCOD=2 Q             ; procedure code
  1.  .. I IBBNDL D  Q
  1.  ... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) S ERRCOD=1 Q    ; revenue code
  1.  ... I OPROC'="",OPROC'=$P(IB0,U,10) S ERRCOD=2 Q            ; procedure code
  1.  .. Q
  1.  . ;
  1.  . ; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
  1.  . S Z=MATCHED
  1.  . D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))      ; Get the Procedure Code values.
  1.  . S OCHG=$P(IBZDATA(Z),U,3)*$P(IBZDATA(Z),U,4) ; Total charge from bill
  1.  . S OCHG2=+$P(IBZDATA(Z),U,5)
  1.  . I OCHG'=EOBCHG,OCHG2=EOBCHG S OCHG=OCHG2     ; update OCHG
  1.  . ;
  1.  . ; if not bundled/unbundled
  1.  . I 'IBBNDL D  Q
  1.  .. I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) S ERRCOD=3 Q        ; original units
  1.  .. I +OCHG'=EOBCHG S ERRCOD=4 Q                            ; original charges
  1.  .. 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
  1.  .. S IBLN=Z
  1.  .. Q
  1.  . ;
  1.  . ; if bundled/unbundled
  1.  . I IBBNDL D  Q
  1.  .. I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) S ERRCOD=3 Q        ; original units
  1.  .. I +OCHG'=EOBCHG S ERRCOD=4 Q                            ; original charges
  1.  .. 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
  1.  .. S IBLN=Z_U_$S(OPROC'="":OPROC,1:OREVCD)
  1.  .. Q
  1.  . ; When dealing with Inpatient UB-04's, check for revenue code roll-ups
  1.  . I 'IBLN,$$INPAT^IBCEF(IBIFN,1) D RCRU^IBCEOB00(.IBZDATA,IB0,.IBLN)
  1.  . ; If only 1 rev code and charges are the same, assume a match
  1.  . I 'IBLN,'$P($G(^IBM(361.1,IBEOB,0)),U,4),$O(IBZDATA(""),-1)=$O(IBZDATA("")),+OCHG=EOBCHG S IBLN=+$O(IBZDATA(""))_U_OREVCD
  1.  ;
  1.  ; At this point, we can assume the claim is CMS-1500 format
  1.  ;JWS;IB*2.0*592;need to be form specific with line level data collection call using output formatter
  1.  I '$D(IBZDATA) D
  1.  . I $$FT^IBCEF(IBIFN)=2 D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)","IBZDATA",,IBIFN) Q
  1.  . I $$FT^IBCEF(IBIFN)=7 D F^IBCEF("N-HCFA SERVICE LINE CALLABLE","IBZDATA",,IBIFN)
  1.  I +PLREF,$D(IBZDATA(+PLREF)) S IBLN=PLREF_U_$P(IB0,U,10) G FINDLNX   ; If a Line Item CTRL # exist, skip mismatching process.
  1.  ;
  1.  S Z=0 F  S Z=$O(IBZDATA(Z)) Q:'Z  D  Q:+MATCHED
  1.  . ; Quit if processing an MRA and this VistA line# has already been filed
  1.  . I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) Q
  1.  . ; Quit if split MRA and this VistA line# has already been filed
  1.  . I $D(IBZVLA(Z)) Q
  1.  . I $G(IBZDATA(Z))="" Q
  1.  . ;
  1.  . ; CHECKING FOR A MATCHING RECORD ON FIRST PASS.
  1.  . D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(Z))      ; Get the Procedure Code values.
  1.  . I OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10)) Q   ;procedure code.
  1.  . S MATCHED=Z
  1.  . Q
  1.  ;
  1.  I 'MATCHED D  G FINDLNX
  1.  . I $G(IBZDATA(1))="" Q  ;if no data in IBZDATA(1) Quit to avoid undefined error - *597
  1.  . D GTPRCD(IBBNDL,.OPROC,.OREVCD,IBZDATA(1))  ; Because no matches, get the information from the 1st line item.
  1.  . I OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10)) S ERRCOD=2   ; Mis-matched Proc Code.
  1.  ;
  1.  ; FOUND A MATCHING PROCEDURE CODE...SO LET'S SEE IF EVERYTHING ELSE MATCHES.
  1.  S Z=MATCHED
  1.  ; Quit if processing an MRA and this VistA line# has already been filed
  1.  I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,IBEOB,15,"AC",Z)) G FINDLNX
  1.  ; Quit if split MRA and this VistA line# has already been filed
  1.  I $D(IBZVLA(Z)) G FINDLNX
  1.  I $G(IBZDATA(Z))="" G FINDLNX
  1.  ;
  1.  S OCHG=$P(IBZDATA(Z),U,8)*$P(IBZDATA(Z),U,9) ; charge from bill
  1.  S IBAMIN=""
  1.  I $P(IBZDATA(Z),U,12)'="" S IBAMIN=$P(IBZDATA(Z),U,12)  ;anesthesia minutes
  1.  S UNITS=$S('IBAMIN:$P(IBZDATA(Z),U,9),1:IBAMIN/15)
  1.  ; original units from bill or anesthesia minutes calculation
  1.  I $P(UNITS,".",2) S UNITS=$FN(UNITS,"",1)    ; round to a single decimal place for fractional units
  1.  I $P($P(IB0,U,16),".",2) S $P(IB0,U,16)=$FN($P(IB0,U,16),"",1)
  1.  S UNITS2=$P(IBZDATA(Z),U,9)     ; just the units
  1.  ; UNITS3 is the number of anesthesia minutes divided by 10, or nil.
  1.  ; Solution to get around the Trailblazers bug for MRAs
  1.  S UNITS3=""
  1.  I IBAMIN'=0 S UNITS3=IBAMIN/10
  1.  ;
  1.  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
  1.  I $$DOLLAR^IBCEFG1(OCHG)'=+$P(IB0,U,15) S ERRCOD=4 G FINDLNX  ; original charges.
  1.  I $S($P(IB0,U,19):$P(IB0,U,19)=$P(IBZDATA(Z),U),1:1) D  G:+ERRCOD FINDLNX
  1.  . ;Original procedure/chg/units/date have matched in order to get here
  1.  . ;Check matching original modifiers
  1.  . 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.
  1.  . S IBLN=Z_$S(IBBNDL:U_OPROC,1:"")
  1.  I 'IBLN,IBLN1 S IBLN=IBLN1
  1.  ;
  1. FINDLNX ;
  1.  Q IBLN
  1.  ;
  1. GTPRCD(IBBNDL,OPROC,OREVCD,IBZREC) ; Set up the Procedure Code/Revenue Code fields.
  1.  N CPT
  1.  ;
  1.  I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D  Q   ; For UB-04s
  1.  . S CPT=$P(IBZREC,U,2)                        ; proc from bill
  1.  . I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,""))   ; non-numeric proc
  1.  . S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(")            ; ext proc code
  1.  . S OREVCD=+$P($G(^DGCR(399.2,+IBZREC,0)),U)  ; Rev cd from bill
  1.  ;
  1.  ; For CMS-1500s
  1.  S CPT=$P(IBZREC,U,5)        ; proc from bill
  1.  I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,""))   ; non-numeric proc
  1.  S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(")            ; ext proc code
  1.  Q
  1.  ;
  1. MODMATCH(IB,MODLST,MOD837S) ; Match modifiers
  1.  ; IB = the list of modifiers iens from the bill, comma delimited
  1.  ; MODLST = the 4 '^' pieces of the reported modifiers
  1.  ;
  1.  N MODOK,Q,Z0,IBMOD,MMOD
  1.  S MODOK=1,MOD837S=""
  1.  I $TR(IB,",")'="" F Q=1:1:$L(IB,",") S Z0=$P(IB,",",Q) I Z0'="" D
  1.  . S IBMOD(Z0)=$G(IBMOD(Z0))+1
  1.  . I '$L(MOD837S) S MOD837S=Z0 Q
  1.  . S MOD837S=MOD837S_","_Z0
  1.  I $TR(MODLST,U)="",$O(IBMOD(""))="" G MODQ ; No modifiers used
  1.  ;
  1.  ; No match if no VistA modifiers, but there are MRA modifiers
  1.  I $TR(MODLST,U)'="",$O(IBMOD(""))="" S MODOK=0 G MODQ
  1.  ;
  1.  ; Evaluate each MRA modifier
  1.  F Z0=1:1:4 D
  1.  . S MMOD=$P(MODLST,U,Z0) Q:MMOD=""     ; individual MRA modifier
  1.  . I '$D(IBMOD(MMOD)) Q                 ; not in array so just quit
  1.  . S IBMOD(MMOD)=IBMOD(MMOD)-1          ; decrement array counter
  1.  . I 'IBMOD(MMOD) KILL IBMOD(MMOD)      ; if 0, then kill array entry
  1.  . Q
  1.  ;
  1.  I $O(IBMOD(""))'="" S MODOK=0 ; All submitted mods not matched
  1. MODQ Q MODOK
  1.  ;