| [613] | 1 | IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 10:54am
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155,296,349**;21-MAR-94;Build 46
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | HOS(IBIFN) ; Extract rev codes for inst. episode into IBXDATA
|
|---|
| 6 | ; Moved for space
|
|---|
| 7 | D HOS^IBCEF22(IBIFN)
|
|---|
| 8 | Q
|
|---|
| 9 | ;
|
|---|
| 10 | OTHINS(IBIFN) ;Determine 'other insurance' node (I1,I2)
|
|---|
| 11 | ; If primary bill, other ins is secondary
|
|---|
| 12 | ; If sec or tert bill, other ins is primary
|
|---|
| 13 | ;IBIFN = bill ien
|
|---|
| 14 | N Z
|
|---|
| 15 | S Z=$$COBN^IBCEF(IBIFN)
|
|---|
| 16 | Q "I"_$S(Z=1:2,1:1)
|
|---|
| 17 | ;
|
|---|
| 18 | OTHINS1(IBIFN) ; Returns the COB #'s of all 'other insurance' as a string
|
|---|
| 19 | ;IBIFN = bill ien
|
|---|
| 20 | N IBC,Z
|
|---|
| 21 | S Z=$$COBN^IBCEF(IBIFN)
|
|---|
| 22 | I Z=1 S IBC=$S($D(^DGCR(399,IBIFN,"I2")):$S($D(^DGCR(399,IBIFN,"I3")):23,1:2),1:"") ;Primary=>2 or 23
|
|---|
| 23 | I Z=2 S IBC="1"_$S($D(^DGCR(399,IBIFN,"I3")):3,1:"") ;Secondary=>1 or 13
|
|---|
| 24 | I Z=3 S IBC="12" ;Tertiary =>12
|
|---|
| 25 | OTHQ Q IBC
|
|---|
| 26 | ;
|
|---|
| 27 | RECVR(IBIFN) ; Returns the V.A. internal routing id of the current ins
|
|---|
| 28 | ; co for 837
|
|---|
| 29 | ;IBIFN = bill ien
|
|---|
| 30 | N MCR,NUM,IBPH
|
|---|
| 31 | S IBPH=$P("P^H",U,$$FT^IBCEF(IBIFN)-1)
|
|---|
| 32 | S NUM="ENVOY"_IBPH
|
|---|
| 33 | ; If rate type is CHAMPVA, send 'CHAMVA'
|
|---|
| 34 | I $P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U)="CHAMPVA" S NUM="CHAMV"_IBPH
|
|---|
| 35 | I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D
|
|---|
| 36 | . S MCR=$P("B^A",U,$$FT^IBCEF(IBIFN)-1) ; PART A/B for MEDICARE
|
|---|
| 37 | . S NUM="PART"_MCR
|
|---|
| 38 | Q NUM
|
|---|
| 39 | ;
|
|---|
| 40 | ALLPAYID(IBIFN,IBXDATA,SEQ) ; Returns clearinghouse id for all (SEQ="")
|
|---|
| 41 | ; or a specific (SEQ=1,2,3) ins co's for 837 in IBXDATA(n) for bill ien
|
|---|
| 42 | ; IBIFN
|
|---|
| 43 | ; EJK *296* Add IBMRA - MRA Claim type.
|
|---|
| 44 | ; EJK *296* Add IBEBI - Electronic Billing ID
|
|---|
| 45 | N Z,Z0,Z1,A,IBM,IBINST,IBMCR,IBX,IBMRA,IBEBI
|
|---|
| 46 | S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M"))
|
|---|
| 47 | F Z=1:1:3 I $S('$G(SEQ):1,1:Z=SEQ) S Z0=$P(IBM,U,Z) I Z0 D S:A'="" IBXDATA(Z)=A
|
|---|
| 48 | . S A=""
|
|---|
| 49 | . S IBINST=($$FT^IBCEF(IBIFN)=3) ;Is bill UB-04?
|
|---|
| 50 | . ; EJK *296* Get IBEBI based on Prof. or Inst. claim
|
|---|
| 51 | . I IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,4)
|
|---|
| 52 | . I 'IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,2)
|
|---|
| 53 | . S IBEBI=$$UP^XLFSTR(IBEBI)
|
|---|
| 54 | . ; EJK *296* If this is a Medicare claim, it may be printed or transmitted.
|
|---|
| 55 | . S IBMRA=$$MRASEC^IBCEF4(IBIFN) ;Is claim 2ndary to an MRA?
|
|---|
| 56 | . S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN),Z1=$G(^DGCR(399,IBIFN,"TX"))
|
|---|
| 57 | . Q:$P(Z1,U,8)=1!$S('$P(Z1,U,9):0,1:$$MRASEC^IBCEF4(IBIFN)) ;Force local prnt
|
|---|
| 58 | . S A=$S($P(Z1,U,8)'=2:$P($G(^DIC(36,Z0,3)),U,$S(IBINST:4,1:2)),1:"")
|
|---|
| 59 | . S A=$$UP^XLFSTR(A)
|
|---|
| 60 | . ;
|
|---|
| 61 | . ; RPRNT = CMS-1500 Rx bills
|
|---|
| 62 | . ; IPRNT = Inst MRA secondary claims
|
|---|
| 63 | . ; PPRNT = Prof MRA secondary claims
|
|---|
| 64 | . ; HPRNT = inst printed bills (non-MRA, force print at clearinghouse)
|
|---|
| 65 | . ; SPRNT = prof printed bills (non-MRA, force print at clearinghouse)
|
|---|
| 66 | . ;
|
|---|
| 67 | . ; Default to appropriate 'xPRNT' if Rx bill or COB bill or forced to
|
|---|
| 68 | . ; print - claims must print at clearinghouse
|
|---|
| 69 | . ;
|
|---|
| 70 | . ; Rx bills on CMS-1500
|
|---|
| 71 | . I 'IBINST,$$ISRX^IBCEF1(IBIFN) S A="RPRNT" Q
|
|---|
| 72 | . ;
|
|---|
| 73 | . ; Claim forced to print at clearinghouse
|
|---|
| 74 | . I $P(Z1,U,8)=2 S A=$S(IBINST:"H",1:"S")_"PRNT" Q
|
|---|
| 75 | . ;
|
|---|
| 76 | . ; EJK *296* Send IBEBI for MRA secondary claims if it exists
|
|---|
| 77 | . I Z>1,IBMRA,IBEBI'="" S A=IBEBI Q
|
|---|
| 78 | . ;
|
|---|
| 79 | . ; MRA secondary claim
|
|---|
| 80 | . I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P")_"PRNT" Q
|
|---|
| 81 | . ;
|
|---|
| 82 | . ; Medicare is current payer (MRA request claim)
|
|---|
| 83 | . I $$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12M61",1:"SMTX1") Q
|
|---|
| 84 | . ;
|
|---|
| 85 | . ; IB*296 - Do not modify the payer ID for CHAMPVA (HAC)
|
|---|
| 86 | . I A=84146 Q
|
|---|
| 87 | . I A=84147 Q
|
|---|
| 88 | . ;
|
|---|
| 89 | . ; If not a primary bill force to print
|
|---|
| 90 | . I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S")_"PRNT" Q
|
|---|
| 91 | . Q
|
|---|
| 92 | ;
|
|---|
| 93 | Q
|
|---|
| 94 | ;
|
|---|
| 95 | PAYERID(IBIFN) ; Returns clearinghouse id for current ins co
|
|---|
| 96 | ; IBIFN = bill ien
|
|---|
| 97 | N NUM,IBSEQ
|
|---|
| 98 | ; Determine the current ins co's # to identify at WEBMD
|
|---|
| 99 | ; Envoy changed to WEBMD in patch 232
|
|---|
| 100 | S IBSEQ=+$$COBN^IBCEF(IBIFN)
|
|---|
| 101 | D ALLPAYID(IBIFN,.NUM,IBSEQ) S NUM=$G(NUM(IBSEQ))
|
|---|
| 102 | Q $G(NUM)
|
|---|
| 103 | ;
|
|---|
| 104 | CURR(IBIFN) ; Returns ien of the current insurance
|
|---|
| 105 | ; company for bill ien IBIFN
|
|---|
| 106 | Q $$FINDINS^IBCEF1(IBIFN)
|
|---|
| 107 | ;
|
|---|
| 108 | ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
|
|---|
| 109 | D ADMDT^IBCEF21(IBIFN,$G(NOOUTCK)) ; Moved for space
|
|---|
| 110 | Q
|
|---|
| 111 | ;
|
|---|
| 112 | DISDT(IBIFN) ; Calculate discharge date
|
|---|
| 113 | D DISDT^IBCEF21(IBIFN) ; Moved for space
|
|---|
| 114 | Q
|
|---|
| 115 | ;
|
|---|
| 116 | INDTS(IBIFN) ; Function returns the admit ^ discharge date/time of admission if patient is an inpatient on bill's event date
|
|---|
| 117 | N Z,Z0,DFN,VAINDT,VAIN S Z0=""
|
|---|
| 118 | S Z=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(Z,U,2),VAINDT=$P(Z,U,3)
|
|---|
| 119 | I +DFN,+VAINDT D INP^VADPT I +VAIN(1) S Z0=+VAIN(7)_U_+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
|
|---|
| 120 | Q Z0
|
|---|
| 121 | ;
|
|---|
| 122 | TXMT(IBIFN) ; Function moved - use new call in IBCEF4
|
|---|
| 123 | Q $$TXMT^IBCEF4(IBIFN)
|
|---|
| 124 | ;
|
|---|
| 125 | ;
|
|---|
| 126 | ID(LN,VAL) ; Set EXTRACT GLOBAL for multi-valued record
|
|---|
| 127 | ; ids for Austin
|
|---|
| 128 | ; LN = the line # being extracted
|
|---|
| 129 | ; VAL = the value of the element being extracted
|
|---|
| 130 | ;
|
|---|
| 131 | ; Assumes IBXPG exists
|
|---|
| 132 | ;
|
|---|
| 133 | Q:LN<2
|
|---|
| 134 | D SETGBL^IBCEFG(IBXPG,LN,1,VAL,.IBXSIZE)
|
|---|
| 135 | Q
|
|---|
| 136 | ;
|
|---|
| 137 | ID1(LN,DX,CT) ;Special entrypoint for diagnoses to 'save' the fact
|
|---|
| 138 | ; a dx code is an e-code.
|
|---|
| 139 | ; LN is last entry # output, returned as the entry # (IBXLINE) to assign to this entry
|
|---|
| 140 | ; DX = the actual Dx code array(RECORD ID). Pass by reference, DX returned null if
|
|---|
| 141 | ; dx was not output
|
|---|
| 142 | ; CT = the ct on the 'DC' entry. pass by reference, returned null if
|
|---|
| 143 | ; the end of the valid dx codes has been reached
|
|---|
| 144 | N IBINS,VAL
|
|---|
| 145 | S IBINS=($$FT^IBCEF(IBXIEN)=3)
|
|---|
| 146 | S VAL="DC"_CT ; **232**
|
|---|
| 147 | S VAL=$E(VAL_" ",1,4)
|
|---|
| 148 | I IBINS D
|
|---|
| 149 | . I CT>8 S CT="" Q ;Only 8 codes for institutional/UB **232**
|
|---|
| 150 | . ; Check for 'E-code'. If there, don't extract the first one as a dx,
|
|---|
| 151 | . ; but as a special E-code
|
|---|
| 152 | . I $G(IBXSAVE("DX-E"))="",$E($G(DX))="E" S IBXSAVE("DX-E")=DX,DX=""
|
|---|
| 153 | I 'IBINS,CT>8 S ^TMP("IBXSAVE",$J,"DX",IBXIEN)=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN))+1,^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(+^TMP("IBXSAVE",$J,"DX",IBXIEN)),U,2))=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN)) S DX="" Q
|
|---|
| 154 | I CT'="",DX'="" S LN=LN+1 D ID(LN,VAL) S ^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(LN),U,2))=LN,^TMP("IBXSAVE",$J,"DX",IBXIEN)=CT,CT=CT+1 Q
|
|---|
| 155 | Q
|
|---|
| 156 | ;
|
|---|
| 157 | M(CT) ; Calculate multi-valued field for 837 extract
|
|---|
| 158 | ; CT = passed by reference/the record ID counter
|
|---|
| 159 | S CT=CT+1
|
|---|
| 160 | Q $E(CT#12+$S(CT#12:0,1:12)_" ",1,2)
|
|---|
| 161 | ;
|
|---|
| 162 | SVITM(IBA,LINE) ; Saves the linked items from the bill data extract into
|
|---|
| 163 | ; an array the formatter will use to link Rxs and prosthetics
|
|---|
| 164 | ; to an SV1 or SV2 line item, if possible. Kills off IBA array entries
|
|---|
| 165 | ; after they are 'moved'
|
|---|
| 166 | ; IBA = array that contains the data to be saved
|
|---|
| 167 | ; subscripts are (line #,item type,item pointer)=ct
|
|---|
| 168 | N Z0,Z1
|
|---|
| 169 | S Z0="" F S Z0=$O(IBA("OUTPT",LINE,Z0)) Q:Z0="" I Z0?1N.N S Z1="" F S Z1=$O(IBA("OUTPT",LINE,Z0,Z1)) Q:Z1="" S ^TMP($J,"IBITEM",Z0,Z1,LINE)=IBA("OUTPT",LINE,Z0,Z1) K IBA("OUTPT",LINE,Z0,Z1)
|
|---|
| 170 | Q
|
|---|
| 171 | ;
|
|---|
| 172 | LINK(IBTYP,IBDATA) ; Link the item with a service line, if possible
|
|---|
| 173 | ; IBTYP = the code for the type of item
|
|---|
| 174 | ; returned incremented if no link is made
|
|---|
| 175 | ; IBDATA = the extracted data string that identifies the item.
|
|---|
| 176 | ; Returns the line to link to or null if no link
|
|---|
| 177 | N IBLN,IBKEY,Z
|
|---|
| 178 | S IBLN=""
|
|---|
| 179 | S IBKEY=$S(IBTYP=3:$P(IBDATA,U,9),IBTYP=5:$P(IBDATA,U,4),1:"") Q:IBKEY=""
|
|---|
| 180 | I $D(^TMP($J,"IBITEM",IBTYP,IBKEY)) D G:IBLN LINKQ
|
|---|
| 181 | .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
|
|---|
| 182 | I $D(^TMP($J,"IBITEM",IBTYP,0)) S IBKEY=0 D
|
|---|
| 183 | .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
|
|---|
| 184 | LINKQ Q IBLN
|
|---|
| 185 | ;
|
|---|
| 186 | COID(IBIFN) ; Claim office ID - moved for space
|
|---|
| 187 | Q $$COID^IBCEF21(IBIFN)
|
|---|
| 188 | ;
|
|---|
| 189 | PPOL(IBIFN,COB) ; return IFN of patient policy on a bill defined by COB (fields 399,112-114)
|
|---|
| 190 | N X,Y,PPOL S PPOL=""
|
|---|
| 191 | I +$G(IBIFN) S X=$G(^DGCR(399,+IBIFN,"M")) I +$G(COB),COB<4 S Y=COB+11,PPOL=$P(X,U,Y)
|
|---|
| 192 | Q PPOL
|
|---|
| 193 | ;
|
|---|
| 194 | LADJ(SUB,LINE,SEQ1,GRP,IBXSAVE,PIECE) ; Extract line level adjustments
|
|---|
| 195 | ; SUB = 1st subscript in IBXSAVE array to use
|
|---|
| 196 | ; LINE = 2nd subscript
|
|---|
| 197 | ; SEQ1 = 4th subscript
|
|---|
| 198 | ; GRP = 5th subscript
|
|---|
| 199 | ; IBXSAVE = array that has the data for COB line level adjustments
|
|---|
| 200 | ; PIECE = # of the piece on the 0-node of the line level
|
|---|
| 201 | ; adjustment reason to be extracted
|
|---|
| 202 | ;
|
|---|
| 203 | N A,B
|
|---|
| 204 | S (A,B)=0
|
|---|
| 205 | F S A=$O(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A)) Q:'A D
|
|---|
| 206 | . S B=B+1,IBXDATA(B)=$P(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A),U,PIECE)
|
|---|
| 207 | Q
|
|---|
| 208 | ;
|
|---|
| 209 | ESGHPST(IBIFN,COB) ; return insureds employ status if bill policy defined by COB is an Employer Sponsored Group Health Plan
|
|---|
| 210 | Q $$ESGHPST^IBCEF21(IBIFN,COB) ;Tag moved
|
|---|
| 211 | ;
|
|---|
| 212 | ESGHPNL(IBIFN,COB) ; return employer name and location if bill policy defined by COB is an Employer Sponsored Group Health Plan
|
|---|
| 213 | Q $$ESGHPNL^IBCEF21(IBIFN,COB) ;Tag moved
|
|---|
| 214 | ;
|
|---|
| 215 | AMTOUT(A,B,C,IBXSAVE) ; format output amount
|
|---|
| 216 | ;
|
|---|
| 217 | N Z,K,IBZ,IBARR K IBXDATA S (IBZ,K)=0,IBARR="IBXSAVE("""_A_""")" F S IBZ=$O(@IBARR@(IBZ)) Q:'IBZ S K=K+1,Z=0 F S Z=$O(@IBARR@(IBZ,Z)) Q:'Z I $P($G(@IBARR@(IBZ,Z,B)),U,C) S IBXDATA(K)=$$DOLLAR^IBCEFG1($G(IBXDATA(K))+$P(@IBARR@(IBZ,Z,B),U,C))
|
|---|
| 218 | Q
|
|---|
