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 Apr 09, 2024@21:14:30 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 ;
