- IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 10:54am
- ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155,296,349,403,400,432,488,461,547,592,608,665**;21-MAR-94;Build 28
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- HOS(IBIFN) ; Extract rev codes for inst. episode into IBXDATA
- ; Moved for space
- D HOS^IBCEF22(IBIFN)
- Q
- ;
- OTHINS(IBIFN) ;Determine 'other insurance' node (I1,I2)
- ; If primary bill, other ins is secondary
- ; If sec or tert bill, other ins is primary
- ;IBIFN = bill ien
- N Z
- S Z=$$COBN^IBCEF(IBIFN)
- Q "I"_$S(Z=1:2,1:1)
- ;
- OTHINS1(IBIFN) ; Returns the COB #'s of all 'other insurance' as a string
- ;IBIFN = bill ien
- N IBC,Z
- S Z=$$COBN^IBCEF(IBIFN)
- 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
- I Z=2 S IBC="1"_$S($D(^DGCR(399,IBIFN,"I3")):3,1:"") ;Secondary=>1 or 13
- I Z=3 S IBC="12" ;Tertiary =>12
- OTHQ Q IBC
- ;
- RECVR(IBIFN) ; Returns the V.A. internal routing id of the current ins
- ; co for 837
- ;IBIFN = bill ien
- N MCR,NUM,IBPH
- ;JWS;IB*2.0*592:Dental form #7
- S IBPH=$P("P^H^^^^DENTAL",U,$$FT^IBCEF(IBIFN)-1)
- S NUM=$S($$FT^IBCEF(IBIFN)=7:IBPH,1:"ENVOY"_IBPH)
- ; If rate type is CHAMPVA, send 'CHAMVA'
- I $P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U)="CHAMPVA" S NUM="CHAMV"_IBPH
- I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D
- . ;JWS;IB*2.0*592:Dental form #7
- . S MCR=$P("B^A^^^^B",U,$$FT^IBCEF(IBIFN)-1) ; PART A/B for MEDICARE
- . S NUM="PART"_MCR
- Q NUM
- ;
- ALLPAYID(IBIFN,IBXDATA,SEQ) ; Returns clearinghouse id for all (SEQ="")
- ; or a specific (SEQ=1,2,3) ins co's for 837 in IBXDATA(n) for bill ien
- ; IBIFN
- ; EJK *296* Add IBMRA - MRA Claim type.
- ; EJK *296* Add IBEBI - Electronic Billing ID
- ;
- ;WCJ;IB*2.0*547 - added IBM2
- ;N Z,Z0,Z1,A,IBM,IBINST,IBMCR,IBX,IBMRA,IBEBI
- N Z,Z0,Z1,A,IBM,IBM2,IBINST,IBMCR,IBX,IBMRA,IBEBI
- ;S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M"))
- S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M")),IBM2=$G(^DGCR(399,IBIFN,"M2"))
- 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
- . S A=""
- . ;WCJ;IB*2.0*547
- . I $P(IBM2,U,Z*2)]"" S A=$P(IBM2,U,Z*2) Q ; grab new alternate payer IDs from bill if they exist
- . ;
- . S IBINST=($$FT^IBCEF(IBIFN)=3) ;Is bill UB-04?
- . ; EJK *296* Get IBEBI based on Prof. or Inst. claim
- . I IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,4)
- . I 'IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,2)
- . ;JWS;IB*2.0*592;Dental payer id;IA# 5292
- . I $$FT^IBCEF(IBIFN)=7 S IBEBI=$P($G(^DIC(36,Z0,3)),U,15)
- . S IBEBI=$$UP^XLFSTR(IBEBI)
- . ; EJK *296* If this is a Medicare claim, it may be printed or transmitted.
- . S IBMRA=$$MRASEC^IBCEF4(IBIFN) ;Is claim 2ndary to an MRA?
- . S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN),Z1=$G(^DGCR(399,IBIFN,"TX"))
- . Q:$P(Z1,U,8)=1!$S('$P(Z1,U,9):0,1:$$MRASEC^IBCEF4(IBIFN)) ;Force local prnt
- . ;JWS;IB*2.0*592;9/1/17 add Dental Payer ID;IA# 5292
- . S A=$S($P(Z1,U,8)'=2:$P($G(^DIC(36,Z0,3)),U,$S(IBINST:4,$$FT^IBCEF(IBIFN)=7:15,1:2)),1:"")
- . S A=$$UP^XLFSTR(A)
- . ;
- . ; RPRNT = CMS-1500 Rx bills
- . ; IPRNT = Inst MRA secondary claims
- . ; PPRNT = Prof MRA secondary claims
- . ; HPRNT = inst printed bills (non-MRA, force print at clearinghouse)
- . ; SPRNT = prof printed bills (non-MRA, force print at clearinghouse)
- . ;
- . ; Default to appropriate 'xPRNT' if Rx bill or COB bill or forced to
- . ; print - claims must print at clearinghouse
- . ;
- . ; Rx bills on CMS-1500
- . ;IB*2.0*432/TAZ Claims no longer print at clearinghouse
- . ;I 'IBINST,$$ISRX^IBCEF1(IBIFN) S A="RPRNT" Q
- . ;
- . ; Claim forced to print at clearinghouse (Field #27)
- . I $P(Z1,U,8)=2 S A=$S(IBINST:"H",1:"S")_"PRNT" Q
- . ;
- . ; EJK *296* Send IBEBI for MRA secondary claims if it exists
- . I Z>1,IBMRA,IBEBI'="" S A=IBEBI Q
- . ;
- . ;WCJ;IB*2.0*665;It was making LCOB not match OI6 for secondary payer on teriary claims
- . ; MRA secondary claim
- . ; I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P")_"PRNT" Q
- . ;
- . ; Medicare is current payer (MRA request claim)
- . I $$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12M61",1:"SMTX1") Q
- . ;
- . ; IB*296 - Do not modify the payer ID for CHAMPVA (HAC)
- . I A=84146 Q
- . I A=84147 Q
- . ;
- . ; If not a primary bill force to print
- . ;IB*2.0*432/TAZ secondary bills will now be processed
- . ;I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S")_"PRNT" Q
- . Q
- ;
- Q
- ;
- PAYERID(IBIFN) ; Returns clearinghouse id for current ins co
- ; IBIFN = bill ien
- N NUM,IBSEQ
- ; Determine the current ins co's # to identify at WEBMD
- ; Envoy changed to WEBMD in patch 232
- S IBSEQ=+$$COBN^IBCEF(IBIFN)
- D ALLPAYID(IBIFN,.NUM,IBSEQ) S NUM=$G(NUM(IBSEQ))
- Q $G(NUM)
- ;
- CURR(IBIFN) ; Returns ien of the current insurance
- ; company for bill ien IBIFN
- Q $$FINDINS^IBCEF1(IBIFN)
- ;
- ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
- D ADMDT^IBCEF21(IBIFN,$G(NOOUTCK)) ; Moved for space
- Q
- ;
- DISDT(IBIFN) ; Calculate discharge date
- D DISDT^IBCEF21(IBIFN) ; Moved for space
- Q
- ;
- INDTS(IBIFN) ; Function returns the admit ^ discharge date/time of admission if patient is an inpatient on bill's event date
- N Z,Z0,DFN,VAINDT,VAIN S Z0=""
- S Z=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(Z,U,2),VAINDT=$P(Z,U,3)
- 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))
- Q Z0
- ;
- TXMT(IBIFN) ; Function moved - use new call in IBCEF4
- Q $$TXMT^IBCEF4(IBIFN)
- ;
- ;
- ID(LN,VAL) ; Set EXTRACT GLOBAL for multi-valued record
- ; ids for Austin
- ; LN = the line # being extracted
- ; VAL = the value of the element being extracted
- ;
- ; Assumes IBXPG exists
- ;
- Q:LN<2
- D SETGBL^IBCEFG(IBXPG,LN,1,VAL,.IBXSIZE)
- Q
- ;
- ID1(LN,DX,CT,DCT,ECT) ;Special entry point for diagnoses to 'save' the fact
- ; a dx code is an e-code.
- ; LN is last entry # output, returned as the entry # (IBXLINE) to assign to this entry
- ; DX = the actual Dx code array(RECORD ID). Pass by reference, DX returned null if
- ; dx was not output
- ; CT = the ct on the 'DC' entry. pass by reference, returned null if
- ; the end of the valid dx codes has been reached
- ; DCT= Count of regular DX codes. UB-04 can have 25 non External Cause codes.
- ; ECT= Count of External Cause codes. UB-04 can have 12 External Cause codes.
- ; External Cause of Injury codes and qualifier changed with ICD-10: E-codes in ICD-9, V,X,W,Y-codes in ICD-10
- N IBINS,VAL,CNT,DXIEN,DXQ,EDX,I,POA,ICDV
- S IBINS=($$FT^IBCEF(IBXIEN)=3)
- S VAL="DC"_CT
- S VAL=$E(VAL_" ",1,4)
- S DCT=+$G(DCT),ECT=+$G(ECT) ;Make sure variables are initialized.
- ;
- S EDX=0,DX=$G(DX)
- S ICDV=$$ICD9VER^IBACSV(+$G(DX(CT)))
- I ICDV=1,$E(DX)="E" S EDX=1 ; TRUE if ECI ICD-9 Dx (e-code)
- I ICDV=30,"VWXY"[$E(DX) S EDX=1 ; TRUE if ECI ICD-10 Dx
- ;
- S I=$S(EDX:3,1:2)
- ;
- S:'EDX DXQ=$S(+$G(^TMP("DCX",$J,2))>0:"BF",1:"BK") ; first non e-code DX is principal (qualifier "BK"), the rest have qualifier "BF"
- ;
- I IBINS D I DX="" G IDX1
- .;I CT>28 S CT="" Q ; Max of 28 codes for institutional/UB
- .I EDX S ECT=ECT+1 I ECT>12 S DX="" Q ;Only 12 E-codes allowed
- .I 'EDX S DCT=DCT+1 I DCT>25 S DX="" Q ;Only 25 DX codes allowed
- .S DXIEN=$P(DX(CT),U,2) Q:DXIEN=""
- .; IB*2.0*547 - no longer stuff a 1 for POA, send a blank if null
- .S POA=$P($G(^IBA(362.3,DXIEN,0)),U,4) ; I POA="",$$INPAT^IBCEF(IBXIEN) S POA=1 ; POA indicator defaults to "1", if not present on inpatient claim
- .S:EDX DXQ="BN" ; e-code DX qualifier
- .Q
- ;
- I 'IBINS S:EDX DXQ="BF" S POA="" ; on CMS-1500 e-code DX qualifiers are "BF" and there's no POA
- ;
- I ICDV=30 S DXQ="A"_DXQ ; adjust Qualifier for ICD-10 codes
- ;
- ;Changed 8 to 12 so we can transmit 12 codes. BAA *488*
- I 'IBINS,CT>12 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
- ;
- I CT'="",DX'="" D
- .; populate ^TMP("DCX") scratch global
- .S ^TMP("DCX",$J,1)=CT,CNT=$G(^TMP("DCX",$J,I))+1,^TMP("DCX",$J,I)=CNT
- .S (^TMP("DCX",$J,I,CNT),^TMP("DCX",$J,1,CT))=DX_U_DXQ_U_POA
- .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
- ;
- IDX1 ;
- Q
- ;
- M(CT) ; Calculate multi-valued field for 837 extract
- ; CT = passed by reference/the record ID counter
- S CT=CT+1
- ;IB*2.0*547/TAZ Increase counter to 25
- ;Q $E(CT#12+$S(CT#12:0,1:12)_" ",1,2)
- ;IB*2.0*665v1;JWS;4/1/21;Do not mod CT with any value, just return count
- ;;Q $E(CT#25+$S(CT#25:0,1:25)_" ",1,2)
- Q CT
- ;
- SVITM(IBA,LINE) ; Saves the linked items from the bill data extract into
- ; an array the formatter will use to link Rxs and prosthetics
- ; to an SV1 or SV2 line item, if possible. Kills off IBA array entries
- ; after they are 'moved'
- ; IBA = array that contains the data to be saved
- ; subscripts are (line #,item type,item pointer)=ct
- N Z0,Z1
- 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)
- Q
- ;
- LINK(IBTYP,IBDATA) ; Link the item with a service line, if possible
- ; IBTYP = the code for the type of item
- ; returned incremented if no link is made
- ; IBDATA = the extracted data string that identifies the item.
- ; Returns the line to link to or null if no link
- N IBLN,IBKEY,Z
- S IBLN=""
- S IBKEY=$S(IBTYP=3:$P(IBDATA,U,9),IBTYP=5:$P(IBDATA,U,4),1:"") Q:IBKEY=""
- I $D(^TMP($J,"IBITEM",IBTYP,IBKEY)) D G:IBLN LINKQ
- .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
- I $D(^TMP($J,"IBITEM",IBTYP,0)) S IBKEY=0 D
- .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
- LINKQ Q IBLN
- ;
- COID(IBIFN) ; Claim office ID - moved for space
- Q $$COID^IBCEF21(IBIFN)
- ;
- PPOL(IBIFN,COB) ; return IFN of patient policy on a bill defined by COB (fields 399,112-114)
- N X,Y,PPOL S PPOL=""
- I +$G(IBIFN) S X=$G(^DGCR(399,+IBIFN,"M")) I +$G(COB),COB<4 S Y=COB+11,PPOL=$P(X,U,Y)
- Q PPOL
- ;
- LADJ(SUB,LINE,SEQ1,GRP,IBXSAVE,PIECE) ; Extract line level adjustments
- ; SUB = 1st subscript in IBXSAVE array to use
- ; LINE = 2nd subscript
- ; SEQ1 = 4th subscript
- ; GRP = 5th subscript
- ; IBXSAVE = array that has the data for COB line level adjustments
- ; PIECE = # of the piece on the 0-node of the line level
- ; adjustment reason to be extracted
- ;
- N A,B
- S (A,B)=0
- F S A=$O(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A)) Q:'A D
- . S B=B+1,IBXDATA(B)=$P(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A),U,PIECE)
- Q
- ;
- ESGHPST(IBIFN,COB) ; return insureds employ status if bill policy defined by COB is an Employer Sponsored Group Health Plan
- Q $$ESGHPST^IBCEF21(IBIFN,COB) ;Tag moved
- ;
- ESGHPNL(IBIFN,COB) ; return employer name and location if bill policy defined by COB is an Employer Sponsored Group Health Plan
- Q $$ESGHPNL^IBCEF21(IBIFN,COB) ;Tag moved
- ;
- AMTOUT(A,B,C,IBXSAVE) ; format output amount
- ;
- 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))
- Q
- ;
- ;/Beginning of IB*2.0*608 (US9) - vd
- SNF(IBIFN) ; Check to see if the claim is a SNF (Skilled Nursing Facility) Claim.
- ; Returned Values:
- ; SNF = 0 if claim is not a SNF Claim.
- ; SNF = 1 if claim is a SNF Claim.
- N SNF
- S SNF=0
- I $$GET1^DIQ(399,IBIFN_", ",.24,"I")=2 S SNF=1 ; Claim is a SNF Claim
- Q SNF
- ;
- VC80CK(IBIFN) ; Determine if the Claim is eligible for Value Code 80 Revenue Code Claim Lines.
- N BLTYPX,COB,IB0,NUM,PPAYID,RCVRID,VC80SW
- S VC80SW=0
- I '$$SNF(IBIFN) Q VC80SW ; Not a SNF Claim.
- S RCVRID=$$RECVR^IBCEF2(IBIFN) I "^ENVOYH^PARTA^"'[(U_RCVRID_U) Q VC80SW ; Not ENVOYH or PARTA
- S COB=$$COB^IBCEF(IBIFN) I COB'="P" Q VC80SW ; Payer Responsibility Sequence not equal to "P".
- D ALLPAYID(IBIFN,.NUM,1) S PPAYID=$G(NUM(1)) Q:(PPAYID'="12M61") VC80SW ; Primary Payer not equal to "12M61"
- S IB0=$G(^DGCR(399,IBIFN,0))
- S BLTYPX=$P(IB0,U,24)_$P(IB0,U,5)
- I BLTYPX<21!(BLTYPX>23) Q VC80SW ; Not a valid Bill Type.
- S VC80SW=1 ; If we got this far.the claim is eligible for Value Code 80 Revenue Code Claim Lines.
- Q VC80SW
- ;
- INS ; Called by the Output Formatter [#364.7, 176]
- N A,Z
- S Z=0,A=$G(^TMP($J,"IBLCT"))
- F S Z=$O(IBXDATA(Z)) D Q:'Z
- . K:'Z&($D(IBXDATA)=1) IBXDATA
- . S:'Z ^TMP($J,"IBLCT")=A Q:'Z
- . S A=A+1 M IBXSAVE("INPT",Z)=IBXDATA(Z)
- . K IBXDATA(Z) S IBXDATA(Z)=A
- . D:Z>1 ID^IBCEF2(Z,"INS ")
- ;
- I +$G(VC80) D
- . S Z=$O(IBXDATA(""),-1)+1
- . D ID^IBCEF2(Z,"INS ")
- . ;D VC80I^IBCEF22(A,$G(IBXSV("VC80",A))) ; Process for 'SNF' claims & the last claim line
- . D VC80I^IBCEF22(A) ; Process for 'SNF' claims & the last claim line.
- . S A=A+1
- . S IBXDATA(Z)=A
- Q
- ;
- INS05 ; Called by the Output Formatter [#364.7, 178]
- ;K IBXDATA S IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN) N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,4)'="" IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4)
- K IBXDATA
- S IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN)
- N LAST,Z S (LAST,Z)=0
- F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
- . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4) Q:LAST
- . S:$P(IBXSAVE("INPT",Z),U,4)'="" IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4)
- Q
- ;
- INS07 ; Called by the Output Formatter [#364.7, 181]
- ;N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,9)'=""&($P(IBXSAVE("INPT",Z),U,2)'="") IBXSAVE("PMOD",Z)=$P(IBXSAVE("INPT",Z),U,9),IBXDATA(Z)=$P(IBXSAVE("PMOD",Z),",")
- N LAST,Z S (LAST,Z)=0
- F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
- . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)="" Q:LAST
- . S:$P(IBXSAVE("INPT",Z),U,9)'=""&($P(IBXSAVE("INPT",Z),U,2)'="") IBXSAVE("PMOD",Z)=$P(IBXSAVE("INPT",Z),U,9),IBXDATA(Z)=$P(IBXSAVE("PMOD",Z),",")
- Q
- ;
- INS09 ; Called by the Output Formatter [#364.7, 180]
- ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,5)))
- K IBXDATA
- N LAST,Z S (LAST,Z)=0
- F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
- . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=0 Q:LAST
- . S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,5)))
- Q
- ;
- INS12 ; Called by the Output Formatter [#364.7, 482]
- ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,6)'="" IBXDATA(Z)=$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,6))
- K IBXDATA
- N LAST,Z S (LAST,Z)=0
- F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
- . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)="" Q:LAST
- . S:$P(IBXSAVE("INPT",Z),U,6)'="" IBXDATA(Z)=$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,6))
- Q
- ;
- INS13 ; Called by the Output Formatter [#364.7, 805]
- ;K IBXDATA N Z,Z0 S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U)'="" Z0=$P(IBXSAVE("INPT",Z),U) S IBXDATA(Z)=$S(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN") K:IBXDATA(Z)="" IBXDATA(Z) K IBXDATA
- K IBXDATA
- N LAST,Z,Z0 S (LAST,Z)=0
- F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
- . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,13) Q:LAST
- . S:$P(IBXSAVE("INPT",Z),U)'="" Z0=$P(IBXSAVE("INPT",Z),U)
- . S IBXDATA(Z)=$S(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN") K:IBXDATA(Z)="" IBXDATA(Z)
- Q
- ;/End IB*2.0*608 (US9) - vd
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF2 15874 printed Feb 18, 2025@23:36:24 Page 2
- IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 10:54am
- +1 ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155,296,349,403,400,432,488,461,547,592,608,665**;21-MAR-94;Build 28
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- HOS(IBIFN) ; Extract rev codes for inst. episode into IBXDATA
- +1 ; Moved for space
- +2 DO HOS^IBCEF22(IBIFN)
- +3 QUIT
- +4 ;
- OTHINS(IBIFN) ;Determine 'other insurance' node (I1,I2)
- +1 ; If primary bill, other ins is secondary
- +2 ; If sec or tert bill, other ins is primary
- +3 ;IBIFN = bill ien
- +4 NEW Z
- +5 SET Z=$$COBN^IBCEF(IBIFN)
- +6 QUIT "I"_$SELECT(Z=1:2,1:1)
- +7 ;
- OTHINS1(IBIFN) ; Returns the COB #'s of all 'other insurance' as a string
- +1 ;IBIFN = bill ien
- +2 NEW IBC,Z
- +3 SET Z=$$COBN^IBCEF(IBIFN)
- +4 ;Primary=>2 or 23
- IF Z=1
- SET IBC=$SELECT($DATA(^DGCR(399,IBIFN,"I2")):$SELECT($DATA(^DGCR(399,IBIFN,"I3")):23,1:2),1:"")
- +5 ;Secondary=>1 or 13
- IF Z=2
- SET IBC="1"_$SELECT($DATA(^DGCR(399,IBIFN,"I3")):3,1:"")
- +6 ;Tertiary =>12
- IF Z=3
- SET IBC="12"
- OTHQ QUIT IBC
- +1 ;
- RECVR(IBIFN) ; Returns the V.A. internal routing id of the current ins
- +1 ; co for 837
- +2 ;IBIFN = bill ien
- +3 NEW MCR,NUM,IBPH
- +4 ;JWS;IB*2.0*592:Dental form #7
- +5 SET IBPH=$PIECE("P^H^^^^DENTAL",U,$$FT^IBCEF(IBIFN)-1)
- +6 SET NUM=$SELECT($$FT^IBCEF(IBIFN)=7:IBPH,1:"ENVOY"_IBPH)
- +7 ; If rate type is CHAMPVA, send 'CHAMVA'
- +8 IF $PIECE($GET(^DGCR(399.3,+$PIECE($GET(^DGCR(399,IBIFN,0)),U,7),0)),U)="CHAMPVA"
- SET NUM="CHAMV"_IBPH
- +9 IF NUM["ENVOY"
- IF $$MCRWNR^IBEFUNC(+$$CURR(IBIFN))
- Begin DoDot:1
- +10 ;JWS;IB*2.0*592:Dental form #7
- +11 ; PART A/B for MEDICARE
- SET MCR=$PIECE("B^A^^^^B",U,$$FT^IBCEF(IBIFN)-1)
- +12 SET NUM="PART"_MCR
- End DoDot:1
- +13 QUIT NUM
- +14 ;
- ALLPAYID(IBIFN,IBXDATA,SEQ) ; Returns clearinghouse id for all (SEQ="")
- +1 ; or a specific (SEQ=1,2,3) ins co's for 837 in IBXDATA(n) for bill ien
- +2 ; IBIFN
- +3 ; EJK *296* Add IBMRA - MRA Claim type.
- +4 ; EJK *296* Add IBEBI - Electronic Billing ID
- +5 ;
- +6 ;WCJ;IB*2.0*547 - added IBM2
- +7 ;N Z,Z0,Z1,A,IBM,IBINST,IBMCR,IBX,IBMRA,IBEBI
- +8 NEW Z,Z0,Z1,A,IBM,IBM2,IBINST,IBMCR,IBX,IBMRA,IBEBI
- +9 ;S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M"))
- +10 SET IBXDATA=""
- SET IBM=$GET(^DGCR(399,IBIFN,"M"))
- SET IBM2=$GET(^DGCR(399,IBIFN,"M2"))
- +11 FOR Z=1:1:3
- IF $SELECT('$GET(SEQ):1,1:Z=SEQ)
- SET Z0=$PIECE(IBM,U,Z)
- IF Z0
- Begin DoDot:1
- +12 SET A=""
- +13 ;WCJ;IB*2.0*547
- +14 ; grab new alternate payer IDs from bill if they exist
- IF $PIECE(IBM2,U,Z*2)]""
- SET A=$PIECE(IBM2,U,Z*2)
- QUIT
- +15 ;
- +16 ;Is bill UB-04?
- SET IBINST=($$FT^IBCEF(IBIFN)=3)
- +17 ; EJK *296* Get IBEBI based on Prof. or Inst. claim
- +18 IF IBINST
- SET IBEBI=$PIECE($GET(^DIC(36,Z0,3)),U,4)
- +19 IF 'IBINST
- SET IBEBI=$PIECE($GET(^DIC(36,Z0,3)),U,2)
- +20 ;JWS;IB*2.0*592;Dental payer id;IA# 5292
- +21 IF $$FT^IBCEF(IBIFN)=7
- SET IBEBI=$PIECE($GET(^DIC(36,Z0,3)),U,15)
- +22 SET IBEBI=$$UP^XLFSTR(IBEBI)
- +23 ; EJK *296* If this is a Medicare claim, it may be printed or transmitted.
- +24 ;Is claim 2ndary to an MRA?
- SET IBMRA=$$MRASEC^IBCEF4(IBIFN)
- +25 SET IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
- SET Z1=$GET(^DGCR(399,IBIFN,"TX"))
- +26 ;Force local prnt
- if $PIECE(Z1,U,8)=1!$SELECT('$PIECE(Z1,U,9)
- QUIT
- +27 ;JWS;IB*2.0*592;9/1/17 add Dental Payer ID;IA# 5292
- +28 SET A=$SELECT($PIECE(Z1,U,8)'=2:$PIECE($GET(^DIC(36,Z0,3)),U,$SELECT(IBINST:4,$$FT^IBCEF(IBIFN)=7:15,1:2)),1:"")
- +29 SET A=$$UP^XLFSTR(A)
- +30 ;
- +31 ; RPRNT = CMS-1500 Rx bills
- +32 ; IPRNT = Inst MRA secondary claims
- +33 ; PPRNT = Prof MRA secondary claims
- +34 ; HPRNT = inst printed bills (non-MRA, force print at clearinghouse)
- +35 ; SPRNT = prof printed bills (non-MRA, force print at clearinghouse)
- +36 ;
- +37 ; Default to appropriate 'xPRNT' if Rx bill or COB bill or forced to
- +38 ; print - claims must print at clearinghouse
- +39 ;
- +40 ; Rx bills on CMS-1500
- +41 ;IB*2.0*432/TAZ Claims no longer print at clearinghouse
- +42 ;I 'IBINST,$$ISRX^IBCEF1(IBIFN) S A="RPRNT" Q
- +43 ;
- +44 ; Claim forced to print at clearinghouse (Field #27)
- +45 IF $PIECE(Z1,U,8)=2
- SET A=$SELECT(IBINST:"H",1:"S")_"PRNT"
- QUIT
- +46 ;
- +47 ; EJK *296* Send IBEBI for MRA secondary claims if it exists
- +48 IF Z>1
- IF IBMRA
- IF IBEBI'=""
- SET A=IBEBI
- QUIT
- +49 ;
- +50 ;WCJ;IB*2.0*665;It was making LCOB not match OI6 for secondary payer on teriary claims
- +51 ; MRA secondary claim
- +52 ; I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P")_"PRNT" Q
- +53 ;
- +54 ; Medicare is current payer (MRA request claim)
- +55 IF $$WNRBILL^IBEFUNC(IBIFN,Z)
- SET A=$SELECT(IBINST:"12M61",1:"SMTX1")
- QUIT
- +56 ;
- +57 ; IB*296 - Do not modify the payer ID for CHAMPVA (HAC)
- +58 IF A=84146
- QUIT
- +59 IF A=84147
- QUIT
- +60 ;
- +61 ; If not a primary bill force to print
- +62 ;IB*2.0*432/TAZ secondary bills will now be processed
- +63 ;I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S")_"PRNT" Q
- +64 QUIT
- End DoDot:1
- if A'=""
- SET IBXDATA(Z)=A
- +65 ;
- +66 QUIT
- +67 ;
- PAYERID(IBIFN) ; Returns clearinghouse id for current ins co
- +1 ; IBIFN = bill ien
- +2 NEW NUM,IBSEQ
- +3 ; Determine the current ins co's # to identify at WEBMD
- +4 ; Envoy changed to WEBMD in patch 232
- +5 SET IBSEQ=+$$COBN^IBCEF(IBIFN)
- +6 DO ALLPAYID(IBIFN,.NUM,IBSEQ)
- SET NUM=$GET(NUM(IBSEQ))
- +7 QUIT $GET(NUM)
- +8 ;
- CURR(IBIFN) ; Returns ien of the current insurance
- +1 ; company for bill ien IBIFN
- +2 QUIT $$FINDINS^IBCEF1(IBIFN)
- +3 ;
- ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
- +1 ; Moved for space
- DO ADMDT^IBCEF21(IBIFN,$GET(NOOUTCK))
- +2 QUIT
- +3 ;
- DISDT(IBIFN) ; Calculate discharge date
- +1 ; Moved for space
- DO DISDT^IBCEF21(IBIFN)
- +2 QUIT
- +3 ;
- INDTS(IBIFN) ; Function returns the admit ^ discharge date/time of admission if patient is an inpatient on bill's event date
- +1 NEW Z,Z0,DFN,VAINDT,VAIN
- SET Z0=""
- +2 SET Z=$GET(^DGCR(399,+$GET(IBIFN),0))
- SET DFN=$PIECE(Z,U,2)
- SET VAINDT=$PIECE(Z,U,3)
- +3 IF +DFN
- IF +VAINDT
- DO INP^VADPT
- IF +VAIN(1)
- SET Z0=+VAIN(7)_U_+$GET(^DGPM(+$PIECE($GET(^DGPM(+VAIN(1),0)),U,17),0))
- +4 QUIT Z0
- +5 ;
- TXMT(IBIFN) ; Function moved - use new call in IBCEF4
- +1 QUIT $$TXMT^IBCEF4(IBIFN)
- +2 ;
- +3 ;
- ID(LN,VAL) ; Set EXTRACT GLOBAL for multi-valued record
- +1 ; ids for Austin
- +2 ; LN = the line # being extracted
- +3 ; VAL = the value of the element being extracted
- +4 ;
- +5 ; Assumes IBXPG exists
- +6 ;
- +7 if LN<2
- QUIT
- +8 DO SETGBL^IBCEFG(IBXPG,LN,1,VAL,.IBXSIZE)
- +9 QUIT
- +10 ;
- ID1(LN,DX,CT,DCT,ECT) ;Special entry point for diagnoses to 'save' the fact
- +1 ; a dx code is an e-code.
- +2 ; LN is last entry # output, returned as the entry # (IBXLINE) to assign to this entry
- +3 ; DX = the actual Dx code array(RECORD ID). Pass by reference, DX returned null if
- +4 ; dx was not output
- +5 ; CT = the ct on the 'DC' entry. pass by reference, returned null if
- +6 ; the end of the valid dx codes has been reached
- +7 ; DCT= Count of regular DX codes. UB-04 can have 25 non External Cause codes.
- +8 ; ECT= Count of External Cause codes. UB-04 can have 12 External Cause codes.
- +9 ; External Cause of Injury codes and qualifier changed with ICD-10: E-codes in ICD-9, V,X,W,Y-codes in ICD-10
- +10 NEW IBINS,VAL,CNT,DXIEN,DXQ,EDX,I,POA,ICDV
- +11 SET IBINS=($$FT^IBCEF(IBXIEN)=3)
- +12 SET VAL="DC"_CT
- +13 SET VAL=$EXTRACT(VAL_" ",1,4)
- +14 ;Make sure variables are initialized.
- SET DCT=+$GET(DCT)
- SET ECT=+$GET(ECT)
- +15 ;
- +16 SET EDX=0
- SET DX=$GET(DX)
- +17 SET ICDV=$$ICD9VER^IBACSV(+$GET(DX(CT)))
- +18 ; TRUE if ECI ICD-9 Dx (e-code)
- IF ICDV=1
- IF $EXTRACT(DX)="E"
- SET EDX=1
- +19 ; TRUE if ECI ICD-10 Dx
- IF ICDV=30
- IF "VWXY"[$EXTRACT(DX)
- SET EDX=1
- +20 ;
- +21 SET I=$SELECT(EDX:3,1:2)
- +22 ;
- +23 ; first non e-code DX is principal (qualifier "BK"), the rest have qualifier "BF"
- if 'EDX
- SET DXQ=$SELECT(+$GET(^TMP("DCX",$JOB,2))>0:"BF",1:"BK")
- +24 ;
- +25 IF IBINS
- Begin DoDot:1
- +26 ;I CT>28 S CT="" Q ; Max of 28 codes for institutional/UB
- +27 ;Only 12 E-codes allowed
- IF EDX
- SET ECT=ECT+1
- IF ECT>12
- SET DX=""
- QUIT
- +28 ;Only 25 DX codes allowed
- IF 'EDX
- SET DCT=DCT+1
- IF DCT>25
- SET DX=""
- QUIT
- +29 SET DXIEN=$PIECE(DX(CT),U,2)
- if DXIEN=""
- QUIT
- +30 ; IB*2.0*547 - no longer stuff a 1 for POA, send a blank if null
- +31 ; I POA="",$$INPAT^IBCEF(IBXIEN) S POA=1 ; POA indicator defaults to "1", if not present on inpatient claim
- SET POA=$PIECE($GET(^IBA(362.3,DXIEN,0)),U,4)
- +32 ; e-code DX qualifier
- if EDX
- SET DXQ="BN"
- +33 QUIT
- End DoDot:1
- IF DX=""
- GOTO IDX1
- +34 ;
- +35 ; on CMS-1500 e-code DX qualifiers are "BF" and there's no POA
- IF 'IBINS
- if EDX
- SET DXQ="BF"
- SET POA=""
- +36 ;
- +37 ; adjust Qualifier for ICD-10 codes
- IF ICDV=30
- SET DXQ="A"_DXQ
- +38 ;
- +39 ;Changed 8 to 12 so we can transmit 12 codes. BAA *488*
- +40 IF 'IBINS
- IF CT>12
- SET ^TMP("IBXSAVE",$JOB,"DX",IBXIEN)=$GET(^TMP("IBXSAVE",$JOB,"DX",IBXIEN))+1
- SET ^TMP("IBXSAVE",$JOB,"DX",IBXIEN,$PIECE(DX(+^TMP("IBXSAVE",$JOB,"DX",IBXIEN)),U,2))=$GET(^TMP("IBXSAVE",$JOB,"DX",IBXIEN))
- SET DX=""
- QUIT
- +41 ;
- +42 IF CT'=""
- IF DX'=""
- Begin DoDot:1
- +43 ; populate ^TMP("DCX") scratch global
- +44 SET ^TMP("DCX",$JOB,1)=CT
- SET CNT=$GET(^TMP("DCX",$JOB,I))+1
- SET ^TMP("DCX",$JOB,I)=CNT
- +45 SET (^TMP("DCX",$JOB,I,CNT),^TMP("DCX",$JOB,1,CT))=DX_U_DXQ_U_POA
- +46 SET LN=LN+1
- DO ID(LN,VAL)
- SET ^TMP("IBXSAVE",$JOB,"DX",IBXIEN,$PIECE(DX(LN),U,2))=LN
- SET ^TMP("IBXSAVE",$JOB,"DX",IBXIEN)=CT
- SET CT=CT+1
- +47 QUIT
- End DoDot:1
- +48 ;
- IDX1 ;
- +1 QUIT
- +2 ;
- M(CT) ; Calculate multi-valued field for 837 extract
- +1 ; CT = passed by reference/the record ID counter
- +2 SET CT=CT+1
- +3 ;IB*2.0*547/TAZ Increase counter to 25
- +4 ;Q $E(CT#12+$S(CT#12:0,1:12)_" ",1,2)
- +5 ;IB*2.0*665v1;JWS;4/1/21;Do not mod CT with any value, just return count
- +6 ;;Q $E(CT#25+$S(CT#25:0,1:25)_" ",1,2)
- +7 QUIT CT
- +8 ;
- SVITM(IBA,LINE) ; Saves the linked items from the bill data extract into
- +1 ; an array the formatter will use to link Rxs and prosthetics
- +2 ; to an SV1 or SV2 line item, if possible. Kills off IBA array entries
- +3 ; after they are 'moved'
- +4 ; IBA = array that contains the data to be saved
- +5 ; subscripts are (line #,item type,item pointer)=ct
- +6 NEW Z0,Z1
- +7 SET Z0=""
- FOR
- SET Z0=$ORDER(IBA("OUTPT",LINE,Z0))
- if Z0=""
- QUIT
- IF Z0?1N.N
- SET Z1=""
- FOR
- SET Z1=$ORDER(IBA("OUTPT",LINE,Z0,Z1))
- if Z1=""
- QUIT
- SET ^TMP($JOB,"IBITEM",Z0,Z1,LINE)=IBA("OUTPT",LINE,Z0,Z1)
- KILL IBA("OUTPT",LINE,Z0,Z1)
- +8 QUIT
- +9 ;
- LINK(IBTYP,IBDATA) ; Link the item with a service line, if possible
- +1 ; IBTYP = the code for the type of item
- +2 ; returned incremented if no link is made
- +3 ; IBDATA = the extracted data string that identifies the item.
- +4 ; Returns the line to link to or null if no link
- +5 NEW IBLN,IBKEY,Z
- +6 SET IBLN=""
- +7 SET IBKEY=$SELECT(IBTYP=3:$PIECE(IBDATA,U,9),IBTYP=5:$PIECE(IBDATA,U,4),1:"")
- if IBKEY=""
- QUIT
- +8 IF $DATA(^TMP($JOB,"IBITEM",IBTYP,IBKEY))
- Begin DoDot:1
- +9 SET Z=0
- FOR
- SET Z=$ORDER(^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z))
- if 'Z
- QUIT
- IF ^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)
- SET IBLN=Z
- SET ^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)=^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)-1
- QUIT
- End DoDot:1
- if IBLN
- GOTO LINKQ
- +10 IF $DATA(^TMP($JOB,"IBITEM",IBTYP,0))
- SET IBKEY=0
- Begin DoDot:1
- +11 SET Z=0
- FOR
- SET Z=$ORDER(^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z))
- if 'Z
- QUIT
- IF ^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)
- SET IBLN=Z
- SET ^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)=^TMP($JOB,"IBITEM",IBTYP,IBKEY,Z)-1
- QUIT
- End DoDot:1
- LINKQ QUIT IBLN
- +1 ;
- COID(IBIFN) ; Claim office ID - moved for space
- +1 QUIT $$COID^IBCEF21(IBIFN)
- +2 ;
- PPOL(IBIFN,COB) ; return IFN of patient policy on a bill defined by COB (fields 399,112-114)
- +1 NEW X,Y,PPOL
- SET PPOL=""
- +2 IF +$GET(IBIFN)
- SET X=$GET(^DGCR(399,+IBIFN,"M"))
- IF +$GET(COB)
- IF COB<4
- SET Y=COB+11
- SET PPOL=$PIECE(X,U,Y)
- +3 QUIT PPOL
- +4 ;
- LADJ(SUB,LINE,SEQ1,GRP,IBXSAVE,PIECE) ; Extract line level adjustments
- +1 ; SUB = 1st subscript in IBXSAVE array to use
- +2 ; LINE = 2nd subscript
- +3 ; SEQ1 = 4th subscript
- +4 ; GRP = 5th subscript
- +5 ; IBXSAVE = array that has the data for COB line level adjustments
- +6 ; PIECE = # of the piece on the 0-node of the line level
- +7 ; adjustment reason to be extracted
- +8 ;
- +9 NEW A,B
- +10 SET (A,B)=0
- +11 FOR
- SET A=$ORDER(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A))
- if 'A
- QUIT
- Begin DoDot:1
- +12 SET B=B+1
- SET IBXDATA(B)=$PIECE(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A),U,PIECE)
- End DoDot:1
- +13 QUIT
- +14 ;
- ESGHPST(IBIFN,COB) ; return insureds employ status if bill policy defined by COB is an Employer Sponsored Group Health Plan
- +1 ;Tag moved
- QUIT $$ESGHPST^IBCEF21(IBIFN,COB)
- +2 ;
- ESGHPNL(IBIFN,COB) ; return employer name and location if bill policy defined by COB is an Employer Sponsored Group Health Plan
- +1 ;Tag moved
- QUIT $$ESGHPNL^IBCEF21(IBIFN,COB)
- +2 ;
- AMTOUT(A,B,C,IBXSAVE) ; format output amount
- +1 ;
- +2 NEW Z,K,IBZ,IBARR
- KILL IBXDATA
- SET (IBZ,K)=0
- SET IBARR="IBXSAVE("""_A_""")"
- FOR
- SET IBZ=$ORDER(@IBARR@(IBZ))
- if 'IBZ
- QUIT
- SET K=K+1
- SET Z=0
- FOR
- SET Z=$ORDER(@IBARR@(IBZ,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(@IBARR@(IBZ,Z,B)),U,C)
- SET IBXDATA(K)=$$DOLLAR^IBCEFG1($GET(IBXDATA(K))+$PIECE(@IBARR@(IBZ,Z,B),U,C))
- +3 QUIT
- +4 ;
- +5 ;/Beginning of IB*2.0*608 (US9) - vd
- SNF(IBIFN) ; Check to see if the claim is a SNF (Skilled Nursing Facility) Claim.
- +1 ; Returned Values:
- +2 ; SNF = 0 if claim is not a SNF Claim.
- +3 ; SNF = 1 if claim is a SNF Claim.
- +4 NEW SNF
- +5 SET SNF=0
- +6 ; Claim is a SNF Claim
- IF $$GET1^DIQ(399,IBIFN_", ",.24,"I")=2
- SET SNF=1
- +7 QUIT SNF
- +8 ;
- VC80CK(IBIFN) ; Determine if the Claim is eligible for Value Code 80 Revenue Code Claim Lines.
- +1 NEW BLTYPX,COB,IB0,NUM,PPAYID,RCVRID,VC80SW
- +2 SET VC80SW=0
- +3 ; Not a SNF Claim.
- IF '$$SNF(IBIFN)
- QUIT VC80SW
- +4 ; Not ENVOYH or PARTA
- SET RCVRID=$$RECVR^IBCEF2(IBIFN)
- IF "^ENVOYH^PARTA^"'[(U_RCVRID_U)
- QUIT VC80SW
- +5 ; Payer Responsibility Sequence not equal to "P".
- SET COB=$$COB^IBCEF(IBIFN)
- IF COB'="P"
- QUIT VC80SW
- +6 ; Primary Payer not equal to "12M61"
- DO ALLPAYID(IBIFN,.NUM,1)
- SET PPAYID=$GET(NUM(1))
- if (PPAYID'="12M61")
- QUIT VC80SW
- +7 SET IB0=$GET(^DGCR(399,IBIFN,0))
- +8 SET BLTYPX=$PIECE(IB0,U,24)_$PIECE(IB0,U,5)
- +9 ; Not a valid Bill Type.
- IF BLTYPX<21!(BLTYPX>23)
- QUIT VC80SW
- +10 ; If we got this far.the claim is eligible for Value Code 80 Revenue Code Claim Lines.
- SET VC80SW=1
- +11 QUIT VC80SW
- +12 ;
- INS ; Called by the Output Formatter [#364.7, 176]
- +1 NEW A,Z
- +2 SET Z=0
- SET A=$GET(^TMP($JOB,"IBLCT"))
- +3 FOR
- SET Z=$ORDER(IBXDATA(Z))
- Begin DoDot:1
- +4 if 'Z&($DATA(IBXDATA)=1)
- KILL IBXDATA
- +5 if 'Z
- SET ^TMP($JOB,"IBLCT")=A
- if 'Z
- QUIT
- +6 SET A=A+1
- MERGE IBXSAVE("INPT",Z)=IBXDATA(Z)
- +7 KILL IBXDATA(Z)
- SET IBXDATA(Z)=A
- +8 if Z>1
- DO ID^IBCEF2(Z,"INS ")
- End DoDot:1
- if 'Z
- QUIT
- +9 ;
- +10 IF +$GET(VC80)
- Begin DoDot:1
- +11 SET Z=$ORDER(IBXDATA(""),-1)+1
- +12 DO ID^IBCEF2(Z,"INS ")
- +13 ;D VC80I^IBCEF22(A,$G(IBXSV("VC80",A))) ; Process for 'SNF' claims & the last claim line
- +14 ; Process for 'SNF' claims & the last claim line.
- DO VC80I^IBCEF22(A)
- +15 SET A=A+1
- +16 SET IBXDATA(Z)=A
- End DoDot:1
- +17 QUIT
- +18 ;
- INS05 ; Called by the Output Formatter [#364.7, 178]
- +1 ;K IBXDATA S IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN) N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,4)'="" IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4)
- +2 KILL IBXDATA
- +3 SET IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN)
- +4 NEW LAST,Z
- SET (LAST,Z)=0
- +5 FOR
- SET Z=$ORDER(IBXSAVE("INPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +6 IF +$GET(VC80)
- if $ORDER(IBXSAVE("INPT",Z))=""
- SET LAST=1
- SET IBXDATA(Z)=$PIECE(IBXSAVE("INPT",Z),U,4)
- if LAST
- QUIT
- +7 if $PIECE(IBXSAVE("INPT",Z),U,4)'=""
- SET IBXDATA(Z)=$PIECE(IBXSAVE("INPT",Z),U,4)
- End DoDot:1
- if LAST
- QUIT
- +8 QUIT
- +9 ;
- INS07 ; Called by the Output Formatter [#364.7, 181]
- +1 ;N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,9)'=""&($P(IBXSAVE("INPT",Z),U,2)'="") IBXSAVE("PMOD",Z)=$P(IBXSAVE("INPT",Z),U,9),IBXDATA(Z)=$P(IBXSAVE("PMOD",Z),",")
- +2 NEW LAST,Z
- SET (LAST,Z)=0
- +3 FOR
- SET Z=$ORDER(IBXSAVE("INPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +4 IF +$GET(VC80)
- if $ORDER(IBXSAVE("INPT",Z))=""
- SET LAST=1
- SET IBXDATA(Z)=""
- if LAST
- QUIT
- +5 if $PIECE(IBXSAVE("INPT",Z),U,9)'=""&($PIECE(IBXSAVE("INPT",Z),U,2)'="")
- SET IBXSAVE("PMOD",Z)=$PIECE(IBXSAVE("INPT",Z),U,9)
- SET IBXDATA(Z)=$PIECE(IBXSAVE("PMOD",Z),",")
- End DoDot:1
- if LAST
- QUIT
- +6 QUIT
- +7 ;
- INS09 ; Called by the Output Formatter [#364.7, 180]
- +1 ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,5)))
- +2 KILL IBXDATA
- +3 NEW LAST,Z
- SET (LAST,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("INPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 IF +$GET(VC80)
- if $ORDER(IBXSAVE("INPT",Z))=""
- SET LAST=1
- SET IBXDATA(Z)=0
- if LAST
- QUIT
- +6 SET IBXDATA(Z)=$SELECT($PIECE(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($PIECE(IBXSAVE("INPT",Z),U,5)))
- End DoDot:1
- if LAST
- QUIT
- +7 QUIT
- +8 ;
- INS12 ; Called by the Output Formatter [#364.7, 482]
- +1 ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,6)'="" IBXDATA(Z)=$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,6))
- +2 KILL IBXDATA
- +3 NEW LAST,Z
- SET (LAST,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("INPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 IF +$GET(VC80)
- if $ORDER(IBXSAVE("INPT",Z))=""
- SET LAST=1
- SET IBXDATA(Z)=""
- if LAST
- QUIT
- +6 if $PIECE(IBXSAVE("INPT",Z),U,6)'=""
- SET IBXDATA(Z)=$$DOLLAR^IBCEFG1($PIECE(IBXSAVE("INPT",Z),U,6))
- End DoDot:1
- if LAST
- QUIT
- +7 QUIT
- +8 ;
- INS13 ; Called by the Output Formatter [#364.7, 805]
- +1 ;K IBXDATA N Z,Z0 S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U)'="" Z0=$P(IBXSAVE("INPT",Z),U) S IBXDATA(Z)=$S(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN") K:IBXDATA(Z)="" IBXDATA(Z) K IBXDATA
- +2 KILL IBXDATA
- +3 NEW LAST,Z,Z0
- SET (LAST,Z)=0
- +4 FOR
- SET Z=$ORDER(IBXSAVE("INPT",Z))
- if 'Z
- QUIT
- Begin DoDot:1
- +5 IF +$GET(VC80)
- if $ORDER(IBXSAVE("INPT",Z))=""
- SET LAST=1
- SET IBXDATA(Z)=$PIECE(IBXSAVE("INPT",Z),U,13)
- if LAST
- QUIT
- +6 if $PIECE(IBXSAVE("INPT",Z),U)'=""
- SET Z0=$PIECE(IBXSAVE("INPT",Z),U)
- +7 SET IBXDATA(Z)=$SELECT(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN")
- if IBXDATA(Z)=""
- KILL IBXDATA(Z)
- End DoDot:1
- if LAST
- QUIT
- +8 QUIT
- +9 ;/End IB*2.0*608 (US9) - vd
- +10 ;