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

IBCECSA5.m

Go to the documentation of this file. 
  1. IBCECSA5 ;ALB/CXW - VIEW EOB SCREEN ;01-OCT-1999
  1.  ;;2.0;INTEGRATED BILLING;**137,135,263,280,155,349,489,488,547,592**;21-MAR-1994;Build 58
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; reference to $$VFILE^DILFD allowed with IA#2055  (IB*2.0*547)
  1.  ;
  1. EN ; -- main entry point for VIEW EOB
  1.  N VALMCNT,VALMBG,VALMHDR
  1.  S VALMCNT=0,VALMBG=1
  1.  D EN^VALM("IBCEM VIEW EOB")
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  I '$G(IBIFN) S VALMQUIT="" G INITQ    ; bill# is required
  1.  D HDR^IBCEOB2                         ; build the VALMHDR array
  1.  K IBCNT,IBONE,^TMP("IBCECSD",$J)      ; kill vars and scratch global
  1.  ;
  1.  ; 8/13/03 - If variable IBEOBIFN is set, then this is the 361.1 ien
  1.  ;           that the user selected from a list.  Build the detail.
  1.  I $G(IBEOBIFN) S IBCNT=IBEOBIFN,IBONE=1 D BLD^IBCECSA6,EOBERR G INITQ
  1.  ;
  1.  D BLD^IBCEOB2   ; build ^TMP("IBCEOB",$J) containing MRA/EOB lister
  1.  S IBONE=0
  1.  M ^TMP("IBCECSD",$J)=^TMP("IBCEOB",$J)
  1.  ;
  1.  ; 4/7/03 - If only 1 EOB record found for this bill, then set the
  1.  ;          IBCNT variable, the IBONE one-time flag, and build the
  1.  ;          detail sections of this list.
  1.  I $G(VALMCNT)=1 S IBCNT=$P($G(^TMP("IBCECSD",$J,1)),U,2),IBONE=1 I IBCNT D BLD^IBCECSA6
  1.  D EOBERR   ; IB*2.0*488  (vd)
  1.  ;
  1. INITQ Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("IBCECSD",$J)
  1.  D CLEAR^VALM1,CLEAN^VALM10
  1.  Q
  1. MIN ;
  1.  N IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5,IBRL,IBTYPE,IBT,IBTX,IBD
  1.  ; flag for inpatient mra
  1.  S IBTYPE=$S($G(IBSRC):1,$$INPAT^IBCEF(+IBREC):1,1:0)
  1.  ;
  1.  S IB=$$SETSTR^VALM1("MEDICARE INFORMATION:","",1,50)
  1.  D SET(IB)
  1.  I '$G(IBSRC) D
  1.  . D CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF)
  1.  . S ^TMP("IBCECSD",$J,"X",5)=VALMCNT
  1.  I $G(IBSRC),'$D(^IBM(361.1,IBCNT,4)) Q
  1.  I '$G(IBSRC),'$$INPAT^IBCEF(+IBREC) Q
  1.  D SET(" INPATIENT:")
  1.  S IBREC1=$G(^IBM(361.1,IBCNT,4)),(IB,IBRL)=""
  1.  ;
  1.  F IBT=2:1 S IBTX=$P($T(MINDAT+IBT),";",3) Q:IBTX=""  D
  1.  . S IBD=$P(IBREC1,"^",+IBTX)
  1.  . I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) E  N IBFULL S IBFULL=1
  1.  . I $S(IBFULL:1,1:IBD) D
  1.  .. I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) I  Q
  1.  .. X "S IBD="_$S($L($P(IBTX,"^",3)):$P(IBTX,"^",3),1:"$$A10(IBD)")
  1.  .. S IB=$$SETSTR^VALM1($P(IBTX,"^",2)_IBD,IB,$S('IBRL:4,1:37),$S('IBRL:41,1:38))
  1.  .. S IBRL=$S(IBRL:0,1:1)
  1.  .. I 'IBRL D SET(IB,IBRL) S IB=""
  1.  ;
  1.  D:IBRL'="" SET(IB)
  1.  D REMARK
  1.  Q
  1.  ;
  1. MINDAT ; data for MIN tag
  1.  ; format:  piece^label^special format code^special decision for disp
  1.  ;;1^Cov Days/Visit Ct  : ^$$RJ(+IBD)^I $G(IBSRC)
  1.  ;;3^Claim DRG Amt      : 
  1.  ;;2^Lifetm Psych Dy Ct : ^$$RJ(IBD)
  1.  ;;5^Disprop Share Amt  : ^^I IBTYPE
  1.  ;;4^Cap Exception Amt  : 
  1.  ;;7^PPS Capital Amt    : ^^I IBTYPE
  1.  ;;6^MSP Pass Thru Amt  : 
  1.  ;;9^PPS Cap HSP-DRG Amt: ^^I IBTYPE
  1.  ;;8^PPS Cap FSP-DRG Amt: ^^I IBTYPE
  1.  ;;11^Old Capital Amt    : ^^I IBTYPE
  1.  ;;10^PPS Cap DSH-DRG Amt: ^^I IBTYPE
  1.  ;;13^PPS Op Hos DRG Amt : 
  1.  ;;12^PPS Capital IME Amt: ^^I IBTYPE
  1.  ;;15^PPS Op Fed DRG Amt : ^^I IBTYPE
  1.  ;;14^Cost Report Day Ct : ^$$RJ(IBD)^I IBTYPE
  1.  ;;17^Indirect Teach Amt : ^^I IBTYPE
  1.  ;;16^PPS Cap Outlier Amt: ^^I IBTYPE
  1.  ;;18^Non-Pay Prof Comp  : ^$$RJ(IBD)
  1.  ;;19^Non-Covered Days Ct: ^$$RJ(+IBD)^I IBTYPE
  1.  ;;
  1.  ;
  1. REMARK ; set up remarks and line level details
  1.  N IBREC1,IBP,IBT,IBX,RCODE,RDESC,REXIST
  1.  Q:$G(IBREM)  S IBREM=1
  1.  D SET(" ")
  1.  D SET(" Claim Level Remark Information")
  1.  D SET("   Code     Description")
  1.  I '$G(IBSRC) D
  1.  . D CNTRL^VALM10(VALMCNT,4,4,IOUON,IOUOFF)
  1.  . D CNTRL^VALM10(VALMCNT,13,11,IOUON,IOUOFF)
  1.  . Q
  1.  ;
  1.  S IBREC1=$P($G(^IBM(361.1,IBCNT,3)),U,3,7)
  1.  I $P(IBREC1,U,1)="" S IBREC1=$P($G(^IBM(361.1,IBCNT,5)),U,1,5)
  1.  S REXIST=0
  1.  ;
  1.  F IBP=1:1:5 D
  1.  . S RCODE=$P(IBREC1,U,IBP)
  1.  . S RDESC=$G(^IBM(361.1,IBCNT,"RM"_IBP))
  1.  . ; IB*2.0*547 - get RARC desription from new AR file 346 when available
  1.  . I '$$VFILE^DILFD(346),RCODE="",RDESC="" Q
  1.  . K IBT
  1.  . Q:RCODE=""
  1.  . I '$$VFILE^DILFD(346) S REXIST=1,IBT(IBP)=RDESC
  1.  . I $$VFILE^DILFD(346) S REXIST=$$CARC(RCODE,346,60,"IBT") Q:REXIST<1
  1.  . D TXT1(.IBT,0,60)
  1.  . D SET("   "_$$LJ^XLFSTR(RCODE,6)_"-  "_$G(IBT(1)))
  1.  . S IBX=1
  1.  . F  S IBX=$O(IBT(IBX)) Q:'IBX  D SET($J("",12)_IBT(IBX))
  1.  . Q
  1.  ;
  1.  I 'REXIST D SET("   No claim level remarks on file")
  1.  D SET(" ")
  1.  Q:$G(IBSRC)  ; MRA Only
  1.  ;
  1. MRALLA S IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50)
  1.  D SET(IB)
  1.  I '$G(IBSRC) D
  1.  . D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
  1.  . S ^TMP("IBCECSD",$J,"X",7)=VALMCNT
  1.  I '$D(^IBM(361.1,IBCNT,15,0)) D SET(" NONE") Q  ; only if there is info
  1.  ;
  1.  ; look up all billed data
  1.  N IBZDATA,IBFORM,IBX2,IBX3,IBREC2,IBREC3,IBTX,IBT,IBRC,IBZ,IBTXL
  1.  ;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500
  1.  S IBFORM=0                         ; cms-1500 & J430D
  1.  I $$FT^IBCEF(+IBREC)=3 S IBFORM=1  ; UB-04
  1.  ;JWS;IB*2.0*592:Dental form #7
  1.  D F^IBCEF("N-"_$S(IBFORM=1:"UB-04",$$FT^IBCEF(+IBREC)=7:"J430D",1:"HCFA 1500")_" SERVICE LINE (EDI)","IBZDATA",,+IBREC)
  1.  S IBX=0 F  S IBX=$O(^IBM(361.1,IBCNT,15,IBX)) Q:IBX<1  S IBREC1=^IBM(361.1,IBCNT,15,IBX,0) D
  1.  . NEW RVL
  1.  . D SET("  #   SV DT   REVCD  PROC  MOD  UNITS  BILLED  DEDUCT  COINS    ALLOW     PYMT")
  1.  . S RVL=+$P(IBREC1,U,12)       ; referenced Vista line#
  1.  . I 'RVL S RVL=IBX             ; use the EOB line# if not there
  1.  . S IBT=$$RJ($P(IBREC1,"^"),3) ;             line number
  1.  . S IBT=IBT_" "_$$RJ($$DAT1^IBOUTL($P($P(IBREC1,"^",16),".")),8) ; service date
  1.  . S IBT=IBT_" "_$$RJ($$EXTERNAL^DILFD(361.115,.1,"",$P(IBREC1,"^",10)),6) ;                                                revcd
  1.  . S IBT=IBT_" "_$$RJ($P(IBREC1,"^",4),5) ;   procedure
  1.  . S IBT=IBT_" "_$$RJ($P($G(^IBM(361.1,IBCNT,15,IBX,2,1,0)),"^"),3)_$S($D(^IBM(361.1,IBCNT,15,IBX,2,2,0)):"+",1:" ") ;      modifiers
  1.  . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",11),"",0),5) ; units
  1.  . ;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500 no change, just comment
  1.  . S IBT=IBT_" "_$$RJ($FN($S(IBFORM:$P($G(IBZDATA(RVL)),"^",5),1:$P($G(IBZDATA(RVL)),"^",8)*$P($G(IBZDATA(RVL)),"^",9)),"",2),8) ;    billed
  1.  . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",1,0)),0)),"^",2),"",2),7) ;  deduct
  1.  . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",2,0)),0)),"^",2),"",2),6) ;   coins
  1.  . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",13),"",2),8) ; allow
  1.  . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",3),"",2),8) ;  payment
  1.  . D SET(IBT)
  1.  . S IBX2=0 F  S IBX2=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2)) Q:IBX2<1  D
  1.  .. S IBREC2=^IBM(361.1,IBCNT,15,IBX,1,IBX2,0),IBX3=0
  1.  .. F  S IBX3=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3)) Q:IBX3<1  D
  1.  ... S IBREC3=^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3,0)
  1.  ... ; line level adjustments; don't display kludges (esg 10/23/03)
  1.  ... I $P(IBREC2,U,1)="PR",$P(IBREC3,U,1)="AAA" Q
  1.  ... I $P(IBREC2,U,1)="OA",$P(IBREC3,U,1)="AB3" Q
  1.  ... I $P(IBREC2,U,1)="LQ" Q
  1.  ... ; IB*2.0*547 - get CARC description from AR file 345, when ready
  1.  ... I '$$VFILE^DILFD(345) S IBTX(1)="ADJ: "_$P(IBREC2,"^")_"  "_$P(IBREC3,"^")_"  "_$P(IBREC3,"^",4) D TXT1(.IBTX,0,79) S IBT=0 F  S IBT=$O(IBTX(IBT)) Q:IBT<1  D SET(IBTX(IBT))
  1.  ... I $$VFILE^DILFD(345) S IBT=$$CARC($P(IBREC3,"^"),345,79,"IBTX"),IBTX(1)="ADJ: "_$P(IBREC2,"^")_"  "_$P(IBREC3,"^")_":  "_$G(IBTX(1)) D TXT1(.IBTX,0,79) S IBT=0 F  S IBT=$O(IBTX(IBT)) Q:IBT<1  D SET(IBTX(IBT))
  1.  ... K IBTX
  1.  ... D SET("ADJ AMT: "_$FN($P(IBREC3,"^",2),"",2))
  1.  . S IBRC=0
  1.  . F  S IBRC=$O(^IBM(361.1,IBCNT,15,IBX,4,IBRC)) Q:'IBRC  S IBREC2=$G(^(IBRC,0)) I IBREC2 K IBTX,IBZ S IBTX(1)="  -REMARK CODE("_+IBREC2_"): ",IBTXL=$L(IBTX(1)) D
  1.  .. ; IB*2.0*547 - get RARC description from AR file 346, when ready
  1.  .. I '$$VFILE^DILFD(346) S IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_"  "_$P(IBREC2,U,3)
  1.  .. I $$VFILE^DILFD(346) S IBT=$$CARC($P(IBREC2,U,2),346,79,"IBTX"),IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_"  "_$G(IBT(1))
  1.  .. I $L(IBTX(1))>79 D
  1.  ... D TXT1(.IBTX,0,79) D SET(IBTX(1)) M IBZ=IBTX K IBTX S IBTX(1)="",IBT=1 F  S IBT=$O(IBZ(IBT)) Q:'IBT  S IBTX(1)=IBTX(1)_IBZ(IBT)_" "
  1.  .. E  D
  1.  ... S IBTXL=0
  1.  .. D TXT1(.IBTX,IBTXL,79) S IBT=0 F  S IBT=$O(IBTX(IBT)) Q:IBT<1  D SET(IBTX(IBT))
  1.  . D SET(" ")
  1.  D SET(" ")
  1.  Q
  1.  ;
  1.  ;/Beginning IB*2.0*488 (vd)
  1. EOBERR ; Display information about any 361.1 message storage or filing errors
  1.  N ERRTXT,DASHES,Z
  1.  S DASHES="---------------------------------------------------------------------"
  1.  I '$O(^IBM(361.1,IBCNT,"ERR",0)) Q
  1.  D SET("VistA could not match all of the Line Level data received in the EEOB")
  1.  D SET("(835 Record 40) to the claim in VistA.")
  1.  D SET(" ")
  1.  S Z=0 F  S Z=$O(^IBM(361.1,IBCNT,"ERR",Z)) Q:'Z  D
  1.  .S ERRTXT=$G(^IBM(361.1,IBCNT,"ERR",Z,0))
  1.  .I ERRTXT["##RAW DATA" S ERRTXT=DASHES
  1.  .D SET(ERRTXT)
  1.  Q
  1.  ;/End of IB*2.0*488 (vd)
  1.  ;
  1. TXT(IBRM,IBLN,IBXY) ;display text over 79 chars
  1.  ;IBRM - text, IBLN - length, IBXY - position
  1.  S IBRM=$E(IBRM,IBLN+1,999)
  1. REP I $E(IBRM,1,IBLN)'="" S IB=$$SETSTR^VALM1($E(IBRM,1,IBLN),"",IBXY,IBLN) D SET(IB) S IBRM=$E(IBRM,IBLN+1,999) G REP
  1.  Q
  1.  ;
  1. SET(IB,IBSAV) ;
  1.  I '$G(IBSAV) D SET^IBCECSA6($G(IBSRC),IB,+$G(CNT),IBCNT)
  1.  Q
  1.  ;
  1. A10(X) ;
  1.  Q $$A10^IBCECSA6(X)
  1.  ;
  1. A7(X) ; returns a dollar amount right justified to 7 characters
  1.  Q $$RJ($FN(X,"",2),7)
  1.  ;
  1. TXT1(IBT,DIWL,DIWR) ; sets up text for over 79 chars
  1.  ; IBT - pass by ref, array of text to be formatted back in array
  1.  ; DIWL - left margin, DIWR = right margin
  1.  N IBX,X,DIWF,IBS K ^UTILITY($J,"W")
  1.  S DIWF="|I"_DIWL
  1.  S IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1  S X=IBT(IBX) D ^DIWP
  1.  K IBT F  S IBX=$O(^UTILITY($J,"W",DIWL,IBX)) Q:IBX<1  S IBT(IBX)=^UTILITY($J,"W",DIWL,IBX,0)
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1. RJ(X,Y) ; right just, default is 10
  1.  Q $$RJ^XLFSTR(X,$G(Y,10)," ")
  1.  ;
  1. CARC(IBCDE,IBF,IBML,IBARY) ;new CARC/RACR API for IB*2.0*547
  1.  ; IBCDE = reason code from EOB to lookup in carc/rarc file (REQUIRED)
  1.  ; IBF = file# to do lookup (either 345-CARC or 346-RARC) *REQUIRED*
  1.  ; IBML = max length for each line (default is 79)
  1.  ; IBARY = (required) subscripted array to return description data in:
  1.  ;  array(1)=first line of word-processed description
  1.  ;  array(2)= 2nd line of wp description, and so on
  1.  ;
  1.  ; Returns total # of lines in description
  1.  ;
  1.  N IBY,IBX,IBC,IBI,IBN,IBALN,IBSTP,IBDSC
  1.  S IBC=0
  1.  Q:$G(IBARY)="" IBC
  1.  Q:$G(IBCDE)="" IBC
  1.  Q:$G(IBF)="" IBC
  1.  S:$G(IBML)="" IBML=79
  1.  S IBY=$$FIND1^DIC(IBF,,"BX",IBCDE) Q:IBY<1 IBC
  1.  S IBX=$$GET1^DIQ(IBF,IBY_",",4,"","IBDSC")
  1.  S IBI=0 F  S IBI=$O(IBDSC(IBI)) Q:'IBI  D
  1.  .S IBC=IBC+1,IBSTP=0,IBALN=$L(IBDSC(IBI))
  1.  .S @IBARY@(IBI)=$E(IBDSC(IBI),1,IBML) Q:IBML>IBALN
  1.  .S IBDSC(IBI+1)=($E(IBDSC(IBI),(IBML+1),IBALN)_" "_$G(IBDSC(IBI+1)))
  1.  .; make sure we don't break words in 2
  1.  .Q:$E(@IBARY@(IBI),IBML)=" "
  1.  .F IBN=IBML:-1:1 Q:$G(IBSTP)=1  D
  1.  ..Q:$E(IBDSC(IBI),IBN)'=" " 
  1.  ..S @IBARY@(IBI)=$E(IBDSC(IBI),1,IBN),IBDSC(IBI+1)=($E(IBDSC(IBI),(IBN+1),IBML)_$G(IBDSC(IBI+1))),IBSTP=1 Q
  1.  Q IBC
  1.  ;