IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389,432,488,516,577,608,623,641,727,759**;21-MAR-94;Build 24
;;Per VA Directive 6402, this routine should not be modified.
;
; OVERFLOW FROM ROUTINE IBCEF2
HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA
; IBIFN = bill ien
; Format: IBXDATA(n) =
; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge
; ^ tot uncov ^ FL49 value
; ^ ien of rev code multiple entry(s) (separated by ";")
; ^ modifiers specific to rev code/proc (separated by ",")
; ^ rev code date, if it can be determined by a corresponding proc
; ^ NDC from "CP" node of claim ^ Units/Quantity from "CP" node - vd/IB*2*577
; ^ Units/Basis of Measurement for Drugs - vd/IB*2*577
;
; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
; item found in an accepted EOB for the bill and = the reference
; line in the first '^' piece followed by the '0' node of file
; 361.115 (LINE LEVEL ADJUSTMENTS)
; COB = COB seq # of adjustment's ins co, m = seq #
; -- AND --
; IBXDATA(IBI,"COB",COB,m,z,p)=
; the '0' node for each subordinate entry of file
; 361.11511 (REASONS) (Only first 3 pieces for 837)
; z = group code, sometimes preceeded by a space p = seq #
;
; -- AND --
; IBXDATA(n,"CPLNK") = soft link to corresponding entry in PROCEDURES multiple of file 399
;
N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD,LST
S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
S IBDEF=$G(IBZ),LST=""
;
; Loop through lines of claim beneath ^DGCR(399,IBIFN,"CP") and build
; the array IBP to be used below.
; IBP(Procedure ^ Modifiers, Print Order, Line#) = Procedure Date
;
S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ D
. S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2)
;
; Loop through the revenue codes beneath ^DGCR(399,IBIFN,"RC") and
; build the array IBX to be used below.
; IBX(" "_Revenue Code, Print Order, Revenue Line#) =
; ^DGCR(399.2, Revenue Code IEN, 0)
; IBX(" "_Revenue Code, Print Order, Revenue Line#, "DT") = Procedure Date
; IBX(" "_Revenue Code, Print Order, Revenue Line#, "MOD") = Modifiers
;
S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D
. S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0
. ; Auto-added procedure charge
. I $P(IBZ,U,10)=4,$P(IBZ,U,11) D ; Soft link to proc
.. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0))
.. Q:Z=""
.. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1)
.. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0))
.. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6))
.. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0)))
.. S:'Z0 Z0=999
.. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11)))
.. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11))
.. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2)
. ; Manually added charge with a procedure
. I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D
.. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers
.. S ZX=$O(IBP($P(IBZ,U,6)))
.. F QQ=1,2 Q:IBPO S Z="" F S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO) S Z0=0 F S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0 S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D Q:IBPO
... ; Ignore if not a CPT or a modifier exists and this is first pass
... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1)
... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0)
... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2)
... K IBP(+Z1_U_IBMOD,Z,Z0)
. ;
. I IBX'="" D ; revenue code is valid
.. S LST=$S(LST="":900,1:LST+1)
.. F Z=LST:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S (LST,IBPO)=Z0 Q
.. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD
;
; Loop through revenue codes in IBX and build the array IBX1.
;
S IBS="" F S IBS=$O(IBX(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO D
. S IBDA=0 F S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D
.. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD"))
.. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate
.. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA
.. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ
.. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3)
.. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4)
.. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA
;
S IBS="" F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=899 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO D ; Check to combine like rev codes without print order
. N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2
. S Z=""
. N IBACC
. F S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z="" S Q=IBPO F S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D
.. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1))
.. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2))
.. F Q0=1,5:1:7,10:1:13,15 D Q:'Q1
... I IBACC Q:Q0=5!(Q0>6)
... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q
... I Q0=5,'IBINPAT Q
... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0
.. Q:'Q1
.. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3)
.. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4)
.. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9)
.. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4)
.. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN")
.. K IBX1(IBS,Q,Z)
;
D SPLIT ; 488 ; baa
;
; Loop through IBX1 and build the array IBXDATA. Everything in the
; array IBXDATA comes from the array IBX1.
;
S IBS="",IBLN=0
F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO S IBSS="" F S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS="" D
. S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2))
. S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT"))
. ;S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2)
. S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,4) ;TPF;IB*2.0*727;EBILL-932;INCREASE CPT MODIFIER TO FOUR;04/10/2022
. S IBXDATA(IBLN,"CPLNK")=$$RC2CP(IBIFN,$P($P(IBXDATA(IBLN),U,8),";"))
. ;
. ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim.
. ;I IBXDATA(IBLN,"CPLNK") S $P(IBXDATA(IBLN),U,11,12)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),1)),U,7,8),"-")
. ; VAD;IB*2.0*577 - Added Unit/Basis of Measurement to line level of claim.
. I IBXDATA(IBLN,"CPLNK") D
. . S $P(IBXDATA(IBLN),U,11,13)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),1)),U,7,8),"-")_U_$P($G(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),2)),U)
. . I +$P(IBXDATA(IBLN),U,12) S $P(IBXDATA(IBLN),U,12)=$S($P(IBXDATA(IBLN),U,12)#1:+$J($P(IBXDATA(IBLN),U,12),0,3),1:$P(IBXDATA(IBLN),U,12))
. ;
. ; Extract line lev COB data for sec or tert bill
. I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled
;
I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D
. N IBARRAY,IBX,IBZ,IBRX,IBLCNT
. S IBLCNT=0
. ; Print prescriptions, prosthetics on front of UB-04
. D SET^IBCSC5A(IBIFN,.IBARRAY)
. I $P(IBARRAY,U,2) D
.. S IBX=+$P(IBARRAY,U,2)+2
.. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=""
.. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2
.. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBRX=IBARRAY(IBX,IBY) D
... D ZERO^IBRXUTL(+$P(IBRX,U,2))
... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01))
... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
... K ^TMP($J,"IBDRUG")
... Q
. ;
. D SET^IBCSC5B(IBIFN,.IBARRAY)
. I $P(IBARRAY,U,2) D
.. S IBLCNT=0
.. S IBX=+$P(IBARRAY,U,2)+2
.. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=""
.. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2
.. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D
... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)
Q
;
ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not
Q ((X'<100&(X'>219))!(X=224))
;
RC2CP(IBIFN,IBRCIEN) ; returns "CP" multiple pointer that corresponds to a given "RC" multiple pointer in file 399
; IBIFN - ien in file 399, top level
; IBRCIEN, ien in sub-file 399.042 (REVENUE CODE)
;
; returns pointer to sub-file 399.0304 (PROCEDURES) or 0 if no valid pointer can be found.
;
N IBRC0,IBCPIEN
I +IBIFN'>0 Q 0
I +IBRCIEN'>0 Q 0
S IBRC0=$G(^DGCR(399,IBIFN,"RC",IBRCIEN,0)),IBCPIEN=0
I $P(IBRC0,U,10)=4 S IBCPIEN=+$P(IBRC0,U,11) ; type = CPT
I $P(IBRC0,U,10)=3 S IBCPIEN=+$P(IBRC0,U,15) ; type = RX
I 'IBCPIEN D
. S IBRC=$P(IBRC0,U,6)
. N IBCPTIEN S IBCPTIEN=IBRC
. F S IBCPTIEN=$O(^DGCR(399,IBIFN,"CP","B",IBCPTIEN)) Q:(+IBCPTIEN'=IBRC)!IBCPIEN D
.. N OK,Z S OK="",Z=""
.. S Z=$O(^DGCR(399,IBIFN,"CP","B",IBCPTIEN,Z)) Q:'Z!OK D
... N CNTR S CNTR=0
... F S CNTR=$O(IBXDATA(CNTR)) Q:'CNTR!'OK D
.... I $G(IBXDATA(CNTR,"CPLNK"))=Z S OK=0 Q
... I OK="" S OK=1,IBCPIEN=Z
I IBCPIEN,'$D(^DGCR(399,IBIFN,"CP",IBCPIEN)) S IBCPIEN=0
Q IBCPIEN
;
SPLIT ; Split codes into multiple lines as needed => baa ; 488
; The max line $ amount for a printed claim is less than the max line $ amount for an electronically transmitted claim.
; However, since the clearinghouse can drop to print for a myriad of reasons at any time, the lines may need to be split
; so they can all fit on a printed claim line just in case. In addition, since some claims are sent to primary payers as
; electronic claims but printed for secondary claims, the lines numbers need to be the same going out to ensure the
; COB data is correct applied (previous payments adj, etc are applied to the correct line.)
N IBS,IBSS,DATA,CHRG,UNTS,TOT,LNS,MOD,CPT,LNK,RLNK,IBSS1,LTOT,LUNT,REC,LST,FST
S IBS="",IBLN=0
F S IBS=$O(IBX1(IBS)) Q:IBS="" D
. S LST=$O(IBX1(IBS,""),-1) ;we have to go through each level so must reset for each
. S LNK=0
. F S LNK=$O(IBX1(IBS,LNK)) Q:('LNK!(LNK>LST)) S IBSS="" F S IBSS=$O(IBX1(IBS,LNK,IBSS)) Q:IBSS="" D
.. S DATA=IBX1(IBS,LNK,IBSS,2)
.. S CHRG=$P(DATA,U,2)
.. S UNTS=$P(DATA,U,3)
.. I UNTS=1 Q ; if only one unit can't split
.. S TOT=UNTS*CHRG
.. I TOT<=9999999.99 Q ; if the total is less tham max we don't need to split
.. S LNS=TOT\9999999.99
.. S MOD=TOT#9999999.99
.. I MOD S LNS=LNS+1
.. I CHRG>4999999.995 S LNS=UNTS ; if the charge is greater than half the mas can't put more than one on a line.
.. S LUNT=UNTS\LNS
.. S MOD=UNTS#LNS
.. I MOD S LUNT=LUNT+1
.. F L=1:1:LNS D
... N Q
... S Q=$O(IBX1(IBS,""),-1)+1
... I L=1 S Q=LNK
... M IBX1(IBS,Q,IBSS)=IBX1(IBS,LNK,IBSS)
... S $P(IBX1(IBS,Q,IBSS,2),U,3)=LUNT,$P(IBX1(IBS,Q,IBSS,2),U,4)=LUNT*CHRG
... S $P(IBX1(IBS,Q,IBSS),U,1)=LUNT,$P(IBX1(IBS,Q,IBSS),U,2)=LUNT*CHRG
... I L>1 S $P(IBX1(IBS,Q,IBSS,2),U,9)=""
... S UNTS=UNTS-LUNT,LUNT=$S(UNTS>LUNT:LUNT,1:UNTS)
Q
;
; /Begin IB*2.0*608 - US9 - vd
VC80I(LN) ; Extracts the data for the "INS" record for VALUE CODE 80 Line item.
; INPUT: LN = Line counter
;
; Value Code 80 is no longer required and no longer significant to this US.
; however, the code and comments throughout make it appear as though it is.
; forgetaboutem!!!
; those don't hurt anything and with this being identified so late in the build, it was too much risk to rewrite.
; those changes would have added at least two more routines to the build plus a number of output formatter entries
; and all it would have gained is clarity for the next team that touches this
;
N VC80REC,IBLOOP,IBDOS
S (VC80REC,IBLOOP)=""
F S IBLOOP=$O(IBXSV("VC80",IBLOOP)) Q:IBLOOP="" Q:$P(IBXSV("VC80",IBLOOP),U)=80
I IBLOOP]"" S VC80REC=IBXSV("VC80",IBLOOP)
;
N UNIT,VC80LN
S UNIT=$P(VC80REC,U,2) ; Service Unit Count
S VC80LN=LN+1 ; Get the next available line number.
;
S $P(IBXSAVE("INPT",VC80LN),U,1)="0022"
;JWS;US8323;IB*2.0*623;change Procedure Code value from AAA000 to ZZZZZ on or after 10/1/2019
; used for X12 SV202-02, Loop 2400, segment SV2, institutional claims only
;WCJ;IB641;v12;check statement from date;if it's not there use the admission date (EVENT DATE)
S IBDOS=$P($$GET1^DIQ(399,IBXIEN_",",151,"I"),".")
I IBDOS="" S IBDOS=$P($$GET1^DIQ(399,IBXIEN_",",.03,"I"),".")
S $P(IBXSAVE("INPT",VC80LN),U,2)=$S(IBDOS<3191001:"AAA00",1:"ZZZZZ")
;
; WCJ;IB759;EBILL-3517; beginnning of changes
; S $P(IBXSAVE("INPT",VC80LN),U,4)=$S(+IBLOOP:UNIT,1:0) ; out with the old
; LENGTH OF STAY for purpose of this INS record is just the STATEMENT COVERS FROM to the STATEMENT COVERS TO
; do not include the through dates unless this is an interim bill (DISCHARGE STATUS=30 (STILL A PATIENT))
; and if ADMIT/DISCHARGE is same day, it's a 1.
;
; Left the code in there to only add this to INS if there is a Value Code 80 (Covered Days), but I don't actually use the value associated with VC 80 anywhere.
; That's just in the VC record, not the INS record.
N IBLOS,IBUNODE,IBCTLAST
S IBCTLAST=($$GET1^DIQ(399,IBXIEN,"162:.02")=30)
S IBUNODE=$G(^DGCR(399,IBXIEN,"U"))
S IBLOS=$$FMDIFF^XLFDT($P(IBUNODE,U,2),$P(IBUNODE,U))
I IBLOS=0!(IBCTLAST) S IBLOS=IBLOS+1
;always LOS per defect EBILL-3594
;S $P(IBXSAVE("INPT",VC80LN),U,4)=$S(+IBLOOP:IBLOS,1:0)
S $P(IBXSAVE("INPT",VC80LN),U,4)=IBLOS
;
S $P(IBXSAVE("INPT",VC80LN),U,9)=0
;always DAys per defect EBILL-3594
;S $P(IBXSAVE("INPT",VC80LN),U,13)=$S(+IBLOOP:"DA",1:"UN")
S $P(IBXSAVE("INPT",VC80LN),U,13)="DA"
; WCJ;IB759;EBILL-3517; end of changes
Q
; /End IB*2.0*608
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF22 15567 printed Mar 13, 2025@21:14:51 Page 2
IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
+1 ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389,432,488,516,577,608,623,641,727,759**;21-MAR-94;Build 24
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; OVERFLOW FROM ROUTINE IBCEF2
HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA
+1 ; IBIFN = bill ien
+2 ; Format: IBXDATA(n) =
+3 ; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge
+4 ; ^ tot uncov ^ FL49 value
+5 ; ^ ien of rev code multiple entry(s) (separated by ";")
+6 ; ^ modifiers specific to rev code/proc (separated by ",")
+7 ; ^ rev code date, if it can be determined by a corresponding proc
+8 ; ^ NDC from "CP" node of claim ^ Units/Quantity from "CP" node - vd/IB*2*577
+9 ; ^ Units/Basis of Measurement for Drugs - vd/IB*2*577
+10 ;
+11 ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
+12 ; item found in an accepted EOB for the bill and = the reference
+13 ; line in the first '^' piece followed by the '0' node of file
+14 ; 361.115 (LINE LEVEL ADJUSTMENTS)
+15 ; COB = COB seq # of adjustment's ins co, m = seq #
+16 ; -- AND --
+17 ; IBXDATA(IBI,"COB",COB,m,z,p)=
+18 ; the '0' node for each subordinate entry of file
+19 ; 361.11511 (REASONS) (Only first 3 pieces for 837)
+20 ; z = group code, sometimes preceeded by a space p = seq #
+21 ;
+22 ; -- AND --
+23 ; IBXDATA(n,"CPLNK") = soft link to corresponding entry in PROCEDURES multiple of file 399
+24 ;
+25 NEW IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD,LST
+26 SET IBINPAT=$$INPAT^IBCEF(IBIFN,1)
+27 IF 'IBINPAT
DO F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
+28 SET IBDEF=$GET(IBZ)
SET LST=""
+29 ;
+30 ; Loop through lines of claim beneath ^DGCR(399,IBIFN,"CP") and build
+31 ; the array IBP to be used below.
+32 ; IBP(Procedure ^ Modifiers, Print Order, Line#) = Procedure Date
+33 ;
+34 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399,IBIFN,"CP",IBDA))
if 'IBDA
QUIT
SET IBZ=$GET(^(IBDA,0))
IF IBZ
Begin DoDot:1
+35 SET IBP(+$PIECE(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$SELECT($PIECE(IBZ,U,4):$PIECE(IBZ,U,4),1:999),IBDA)=$PIECE(IBZ,U,2)
End DoDot:1
+36 ;
+37 ; Loop through the revenue codes beneath ^DGCR(399,IBIFN,"RC") and
+38 ; build the array IBX to be used below.
+39 ; IBX(" "_Revenue Code, Print Order, Revenue Line#) =
+40 ; ^DGCR(399.2, Revenue Code IEN, 0)
+41 ; IBX(" "_Revenue Code, Print Order, Revenue Line#, "DT") = Procedure Date
+42 ; IBX(" "_Revenue Code, Print Order, Revenue Line#, "MOD") = Modifiers
+43 ;
+44 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399,IBIFN,"RC",IBDA))
if 'IBDA
QUIT
SET IBZ=$GET(^(IBDA,0))
IF IBZ
SET IBMOD=""
Begin DoDot:1
+45 SET IBX=$GET(^DGCR(399.2,+IBZ,0))
SET IBX1=""
SET IBPO=0
+46 ; Auto-added procedure charge
+47 ; Soft link to proc
IF $PIECE(IBZ,U,10)=4
IF $PIECE(IBZ,U,11)
Begin DoDot:2
+48 SET Z=$GET(^DGCR(399,IBIFN,"CP",$PIECE(IBZ,U,11),0))
+49 if Z=""
QUIT
+50 SET ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$PIECE(IBZ,U,11),1)
+51 if '$ORDER(IBP(ZX,0))&'$ORDER(IBP1(ZX,0))
QUIT
+52 IF $PIECE(IBZ,U,6)
if $SELECT($PIECE(Z,U)'["ICPT"
QUIT
+53 SET Z0=$SELECT($DATA(IBP(ZX)):$ORDER(IBP(ZX,0)),1:$ORDER(IBP1(ZX,0)))
+54 if 'Z0
SET Z0=999
+55 if '$DATA(IBP(ZX,+Z0,$PIECE(IBZ,U,11)))&'$DATA(IBP1(ZX,+Z0,$PIECE(IBZ,U,11)))
QUIT
+56 IF '$DATA(IBP1(ZX,+Z0,$PIECE(IBZ,U,11)))
SET IBP1(ZX,+Z0,$PIECE(IBZ,U,11))=IBP(ZX,+Z0,$PIECE(IBZ,U,11))
KILL IBP(ZX,+Z0,$PIECE(IBZ,U,11))
+57 SET IBX1=$PIECE(Z,U,2)
SET IBPO=+Z0
SET IBMOD=$PIECE(ZX,U,2)
End DoDot:2
+58 ; Manually added charge with a procedure
+59 IF $PIECE(IBZ,U,6)
IF $SELECT($PIECE(IBZ,U,10)=4:'$PIECE(IBZ,U,11),1:1)
IF +$ORDER(IBP($PIECE(IBZ,U,6)))=$PIECE(IBZ,U,6)
Begin DoDot:2
+60 ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers
+61 SET ZX=$ORDER(IBP($PIECE(IBZ,U,6)))
+62 FOR QQ=1,2
if IBPO
QUIT
SET Z=""
FOR
SET Z=$ORDER(IBP(ZX,Z),-1)
if 'Z!(IBPO)
QUIT
SET Z0=0
FOR
SET Z0=$ORDER(IBP(ZX,Z,Z0))
if 'Z0
QUIT
SET Z1=$GET(^DGCR(399,IBIFN,"CP",Z0,0))
Begin DoDot:3
+63 ; Ignore if not a CPT or a modifier exists and this is first pass
+64 SET IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1)
+65 if $SELECT($PIECE(Z1,U)'["ICPT"
QUIT
+66 SET IBPO=+$PIECE(Z1,U,4)
SET IBX1=$PIECE(Z1,U,2)
+67 KILL IBP(+Z1_U_IBMOD,Z,Z0)
End DoDot:3
if IBPO
QUIT
End DoDot:2
+68 ;
+69 ; revenue code is valid
IF IBX'=""
Begin DoDot:2
+70 SET LST=$SELECT(LST="":900,1:LST+1)
+71 FOR Z=LST:1
SET Z0=$SELECT(IBPO:IBPO,$DATA(IBX(" "_$PIECE(IBX,U),Z)):0,1:Z)
IF Z0
SET (LST,IBPO)=Z0
QUIT
+72 SET IBX(" "_$PIECE(IBX,U),IBPO,IBDA)=IBX
SET IBX(" "_$PIECE(IBX,U),IBPO,IBDA,"DT")=$SELECT(IBX1:IBX1,1:IBDEF)
SET IBX(" "_$PIECE(IBX,U),IBPO,IBDA,"MOD")=IBMOD
End DoDot:2
End DoDot:1
+73 ;
+74 ; Loop through revenue codes in IBX and build the array IBX1.
+75 ;
+76 SET IBS=""
FOR
SET IBS=$ORDER(IBX(IBS))
if IBS=""
QUIT
SET IBPO=0
FOR
SET IBPO=$ORDER(IBX(IBS,IBPO))
if 'IBPO
QUIT
Begin DoDot:1
+77 SET IBDA=0
FOR
SET IBDA=$ORDER(IBX(IBS,IBPO,IBDA))
if 'IBDA
QUIT
SET IBX=$GET(IBX(IBS,IBPO,IBDA))
SET IBZ=$GET(^DGCR(399,IBIFN,"RC",IBDA,0))
IF IBX'=""
Begin DoDot:2
+78 ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD"))
+79 ;combine same proc and modifiers regardless of rate
SET IBXS=U_$PIECE(IBZ,U,6)_U_$GET(IBX(IBS,IBPO,IBDA,"MOD"))
+80 if IBPO'<900&'$$ACCRV($PIECE(IBS," ",2))&$SELECT(IBINPAT
SET IBCOMB(IBS,IBXS,IBPO)=IBDA
+81 if '$DATA(IBX1(IBS,IBPO,IBXS,1))
SET IBX1(IBS,IBPO,IBXS,1)=IBX
SET IBX1(IBS,IBPO,IBXS,2)=IBZ
+82 SET $PIECE(IBX1(IBS,IBPO,IBXS),U)=$PIECE($GET(IBX1(IBS,IBPO,IBXS)),U)+$PIECE(IBZ,U,3)
+83 SET $PIECE(IBX1(IBS,IBPO,IBXS),U,2)=$PIECE($GET(IBX1(IBS,IBPO,IBXS)),U,2)+$PIECE(IBZ,U,4)
+84 SET IBX1(IBS,IBPO,IBXS,"DT")=$GET(IBX(IBS,IBPO,IBDA,"DT"))
SET IBX1(IBS,IBPO,IBXS,"IEN")=$GET(IBX1(IBS,IBPO,IBXS,"IEN"))_$SELECT($GET(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA
End DoDot:2
End DoDot:1
+85 ;
+86 ; Check to combine like rev codes without print order
SET IBS=""
FOR
SET IBS=$ORDER(IBX1(IBS))
if IBS=""
QUIT
SET IBPO=899
FOR
SET IBPO=$ORDER(IBX1(IBS,IBPO))
if 'IBPO
QUIT
Begin DoDot:1
+87 NEW Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2
+88 SET Z=""
+89 NEW IBACC
+90 FOR
SET Z=$ORDER(IBX1(IBS,IBPO,Z))
if Z=""
QUIT
SET Q=IBPO
FOR
SET Q=$ORDER(IBCOMB(IBS,Z,Q))
if 'Q
QUIT
IF Q'=IBPO
SET IBZ1=$GET(IBX1(IBS,IBPO,Z,1))
SET IBZ2=$GET(IBX1(IBS,IBPO,Z,2))
Begin DoDot:2
+91 if $GET(IBX1(IBS,IBPO,Z,1))'=$GET(IBX1(IBS,Q,Z,1))
QUIT
+92 SET Q1=1
SET IBACC=$$ACCRV(+$PIECE(IBS," ",2))
+93 FOR Q0=1,5:1:7,10:1:13,15
Begin DoDot:3
+94 IF IBACC
if Q0=5!(Q0>6)
QUIT
+95 IF (Q0=11!(Q0=15))&($PIECE($GET(IBX1(IBS,Q,Z,2)),U,10)=3)
QUIT
+96 IF Q0=5
IF 'IBINPAT
QUIT
+97 IF $PIECE($GET(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$PIECE($GET(IBX1(IBS,Q,Z,2)),U,Q0)
SET Q1=0
End DoDot:3
if 'Q1
QUIT
+98 if 'Q1
QUIT
+99 SET $PIECE(IBX1(IBS,IBPO,Z,2),U,3)=$PIECE(IBX1(IBS,IBPO,Z,2),U,3)+$PIECE(IBX1(IBS,Q,Z,2),U,3)
+100 SET $PIECE(IBX1(IBS,IBPO,Z,2),U,4)=$PIECE(IBX1(IBS,IBPO,Z,2),U,4)+$PIECE(IBX1(IBS,Q,Z,2),U,4)
+101 SET $PIECE(IBX1(IBS,IBPO,Z,2),U,9)=$PIECE(IBX1(IBS,IBPO,Z,2),U,9)+$PIECE(IBX1(IBS,Q,Z,2),U,9)
+102 SET IBX1(IBS,IBPO,Z)=$PIECE(IBX1(IBS,IBPO,Z,2),U,3)_U_$PIECE(IBX1(IBS,IBPO,Z,2),U,4)
+103 SET IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN")
+104 KILL IBX1(IBS,Q,Z)
End DoDot:2
End DoDot:1
+105 ;
+106 ; 488 ; baa
DO SPLIT
+107 ;
+108 ; Loop through IBX1 and build the array IBXDATA. Everything in the
+109 ; array IBXDATA comes from the array IBX1.
+110 ;
+111 SET IBS=""
SET IBLN=0
+112 FOR
SET IBS=$ORDER(IBX1(IBS))
if IBS=""
QUIT
SET IBPO=0
FOR
SET IBPO=$ORDER(IBX1(IBS,IBPO))
if 'IBPO
QUIT
SET IBSS=""
FOR
SET IBSS=$ORDER(IBX1(IBS,IBPO,IBSS))
if IBSS=""
QUIT
Begin DoDot:1
+113 SET IBX=$GET(IBX1(IBS,IBPO,IBSS,1))
SET IBZ=$GET(IBX1(IBS,IBPO,IBSS,2))
+114 SET IBLN=$GET(IBLN)+1
SET IBXDATA(IBLN)=$PIECE(IBX,U)_U_$PIECE(IBZ,U,6)_U_$PIECE(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$PIECE(IBX1(IBS,IBPO,IBSS),U,2)
SET $PIECE(IBXDATA(IBLN),U,10)=$GET(IBX1(IBS,IBPO,IBSS,"DT"))
+115 ;S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2)
+116 ;TPF;IB*2.0*727;EBILL-932;INCREASE CPT MODIFIER TO FOUR;04/10/2022
SET $PIECE(IBXDATA(IBLN),U,6)=$PIECE(IBZ,U,9)
SET $PIECE(IBXDATA(IBLN),U,7)=$PIECE(IBZ,U,13)
SET $PIECE(IBXDATA(IBLN),U,8)=$GET(IBX1(IBS,IBPO,IBSS,"IEN"))
SET $PIECE(IBXDATA(IBLN),U,9)=$PIECE($PIECE(IBSS,U,3),",",1,4)
+117 SET IBXDATA(IBLN,"CPLNK")=$$RC2CP(IBIFN,$PIECE($PIECE(IBXDATA(IBLN),U,8),";"))
+118 ;
+119 ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim.
+120 ;I IBXDATA(IBLN,"CPLNK") S $P(IBXDATA(IBLN),U,11,12)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),1)),U,7,8),"-")
+121 ; VAD;IB*2.0*577 - Added Unit/Basis of Measurement to line level of claim.
+122 IF IBXDATA(IBLN,"CPLNK")
Begin DoDot:2
+123 SET $PIECE(IBXDATA(IBLN),U,11,13)=$TRANSLATE($PIECE($GET(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),1)),U,7,8),"-")_U_$PIECE($GET(^DGCR(399,IBIFN,"CP",IBXDATA(IBLN,"CPLNK"),2)),U)
+124 IF +$PIECE(IBXDATA(IBLN),U,12)
SET $PIECE(IBXDATA(IBLN),U,12)=$SELECT($PIECE(IBXDATA(IBLN),U,12)#1:+$JUSTIFY($PIECE(IBXDATA(IBLN),U,12),0,3),1:$PIECE(IBXDATA(IBLN),U,12))
End DoDot:2
+125 ;
+126 ; Extract line lev COB data for sec or tert bill
+127 ;Handle bundled/unbundled
IF $$COBN^IBCEF(IBIFN)>1
DO COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA)
IF $DATA(IBXTRA)
DO COMBO^IBCEU2(.IBXDATA,.IBXTRA,1)
End DoDot:1
+128 ;
+129 IF $DATA(^IBA(362.4,"AIFN"_IBIFN))!$DATA(^IBA(362.5,"AIFN"_IBIFN))
Begin DoDot:1
+130 NEW IBARRAY,IBX,IBZ,IBRX,IBLCNT
+131 SET IBLCNT=0
+132 ; Print prescriptions, prosthetics on front of UB-04
+133 DO SET^IBCSC5A(IBIFN,.IBARRAY)
+134 IF $PIECE(IBARRAY,U,2)
Begin DoDot:2
+135 SET IBX=+$PIECE(IBARRAY,U,2)+2
+136 SET IBLCNT=IBLCNT+1
SET IBXSAVE("RX-UB-04",IBLCNT)=""
+137 SET IBLCNT=IBLCNT+1
SET IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:"
SET IBLCNT=2
+138 SET IBX=0
FOR
SET IBX=$ORDER(IBARRAY(IBX))
if IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(IBARRAY(IBX,IBY))
if 'IBY
QUIT
SET IBRX=IBARRAY(IBX,IBY)
Begin DoDot:3
+139 DO ZERO^IBRXUTL(+$PIECE(IBRX,U,2))
+140 SET IBLCNT=IBLCNT+1
SET IBXSAVE("RX-UB-04",IBLCNT)=IBX_$JUSTIFY(" ",(11-$LENGTH(IBX)))_" "_$JUSTIFY($SELECT($PIECE(IBRX,U,6):"$"_$FNUMBER($PIECE(IBRX,U,6),",",2),1:""),10)_" "_$JUSTIFY($$FMTE^XLFDT(IBY,2),8)_" "_$GET(^TMP($JOB,"IBDRUG
",+$PIECE(IBRX,U,2),.01))
+141 SET IBZ=$SELECT(+$PIECE(IBRX,U,4):"QTY: "_$PIECE(IBRX,U,4)_" ",1:"")_$SELECT(+$PIECE(IBRX,U,3):"for "_$PIECE(IBRX,U,3)_" days supply ",1:"")
IF IBZ'=""
SET IBLCNT=IBLCNT+1
SET IBXSAVE("RX-UB-04",IBLCNT)=$JUSTIFY(" ",35)_IBZ
+142 SET IBZ=$SELECT($PIECE(IBRX,U,5)'="":"NDC #: "_$PIECE(IBRX,U,5),1:"")
IF IBZ'=""
SET IBLCNT=IBLCNT+1
SET IBXSAVE("RX-UB-04",IBLCNT)=$JUSTIFY(" ",35)_IBZ
+143 KILL ^TMP($JOB,"IBDRUG")
+144 QUIT
End DoDot:3
End DoDot:2
+145 ;
+146 DO SET^IBCSC5B(IBIFN,.IBARRAY)
+147 IF $PIECE(IBARRAY,U,2)
Begin DoDot:2
+148 SET IBLCNT=0
+149 SET IBX=+$PIECE(IBARRAY,U,2)+2
+150 SET IBLCNT=IBLCNT+1
SET IBXSAVE("PROS-UB-04",IBLCNT)=""
+151 SET IBLCNT=IBLCNT+1
SET IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:"
SET IBLCNT=2
+152 SET IBX=0
FOR
SET IBX=$ORDER(IBARRAY(IBX))
if IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(IBARRAY(IBX,IBY))
if 'IBY
QUIT
Begin DoDot:3
+153 SET IBLCNT=IBLCNT+1
SET IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$JUSTIFY($SELECT($PIECE(IBARRAY(IBX,IBY),U,2):"$"_$FNUMBER($PIECE(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$EXTRACT($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)
End DoDot:3
End DoDot:2
End DoDot:1
+154 QUIT
+155 ;
ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not
+1 QUIT ((X'<100&(X'>219))!(X=224))
+2 ;
RC2CP(IBIFN,IBRCIEN) ; returns "CP" multiple pointer that corresponds to a given "RC" multiple pointer in file 399
+1 ; IBIFN - ien in file 399, top level
+2 ; IBRCIEN, ien in sub-file 399.042 (REVENUE CODE)
+3 ;
+4 ; returns pointer to sub-file 399.0304 (PROCEDURES) or 0 if no valid pointer can be found.
+5 ;
+6 NEW IBRC0,IBCPIEN
+7 IF +IBIFN'>0
QUIT 0
+8 IF +IBRCIEN'>0
QUIT 0
+9 SET IBRC0=$GET(^DGCR(399,IBIFN,"RC",IBRCIEN,0))
SET IBCPIEN=0
+10 ; type = CPT
IF $PIECE(IBRC0,U,10)=4
SET IBCPIEN=+$PIECE(IBRC0,U,11)
+11 ; type = RX
IF $PIECE(IBRC0,U,10)=3
SET IBCPIEN=+$PIECE(IBRC0,U,15)
+12 IF 'IBCPIEN
Begin DoDot:1
+13 SET IBRC=$PIECE(IBRC0,U,6)
+14 NEW IBCPTIEN
SET IBCPTIEN=IBRC
+15 FOR
SET IBCPTIEN=$ORDER(^DGCR(399,IBIFN,"CP","B",IBCPTIEN))
if (+IBCPTIEN'=IBRC)!IBCPIEN
QUIT
Begin DoDot:2
+16 NEW OK,Z
SET OK=""
SET Z=""
+17 SET Z=$ORDER(^DGCR(399,IBIFN,"CP","B",IBCPTIEN,Z))
if 'Z!OK
QUIT
Begin DoDot:3
+18 NEW CNTR
SET CNTR=0
+19 FOR
SET CNTR=$ORDER(IBXDATA(CNTR))
if 'CNTR!'OK
QUIT
Begin DoDot:4
+20 IF $GET(IBXDATA(CNTR,"CPLNK"))=Z
SET OK=0
QUIT
End DoDot:4
+21 IF OK=""
SET OK=1
SET IBCPIEN=Z
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF IBCPIEN
IF '$DATA(^DGCR(399,IBIFN,"CP",IBCPIEN))
SET IBCPIEN=0
+23 QUIT IBCPIEN
+24 ;
SPLIT ; Split codes into multiple lines as needed => baa ; 488
+1 ; The max line $ amount for a printed claim is less than the max line $ amount for an electronically transmitted claim.
+2 ; However, since the clearinghouse can drop to print for a myriad of reasons at any time, the lines may need to be split
+3 ; so they can all fit on a printed claim line just in case. In addition, since some claims are sent to primary payers as
+4 ; electronic claims but printed for secondary claims, the lines numbers need to be the same going out to ensure the
+5 ; COB data is correct applied (previous payments adj, etc are applied to the correct line.)
+6 NEW IBS,IBSS,DATA,CHRG,UNTS,TOT,LNS,MOD,CPT,LNK,RLNK,IBSS1,LTOT,LUNT,REC,LST,FST
+7 SET IBS=""
SET IBLN=0
+8 FOR
SET IBS=$ORDER(IBX1(IBS))
if IBS=""
QUIT
Begin DoDot:1
+9 ;we have to go through each level so must reset for each
SET LST=$ORDER(IBX1(IBS,""),-1)
+10 SET LNK=0
+11 FOR
SET LNK=$ORDER(IBX1(IBS,LNK))
if ('LNK!(LNK>LST))
QUIT
SET IBSS=""
FOR
SET IBSS=$ORDER(IBX1(IBS,LNK,IBSS))
if IBSS=""
QUIT
Begin DoDot:2
+12 SET DATA=IBX1(IBS,LNK,IBSS,2)
+13 SET CHRG=$PIECE(DATA,U,2)
+14 SET UNTS=$PIECE(DATA,U,3)
+15 ; if only one unit can't split
IF UNTS=1
QUIT
+16 SET TOT=UNTS*CHRG
+17 ; if the total is less tham max we don't need to split
IF TOT<=9999999.99
QUIT
+18 SET LNS=TOT\9999999.99
+19 SET MOD=TOT#9999999.99
+20 IF MOD
SET LNS=LNS+1
+21 ; if the charge is greater than half the mas can't put more than one on a line.
IF CHRG>4999999.995
SET LNS=UNTS
+22 SET LUNT=UNTS\LNS
+23 SET MOD=UNTS#LNS
+24 IF MOD
SET LUNT=LUNT+1
+25 FOR L=1:1:LNS
Begin DoDot:3
+26 NEW Q
+27 SET Q=$ORDER(IBX1(IBS,""),-1)+1
+28 IF L=1
SET Q=LNK
+29 MERGE IBX1(IBS,Q,IBSS)=IBX1(IBS,LNK,IBSS)
+30 SET $PIECE(IBX1(IBS,Q,IBSS,2),U,3)=LUNT
SET $PIECE(IBX1(IBS,Q,IBSS,2),U,4)=LUNT*CHRG
+31 SET $PIECE(IBX1(IBS,Q,IBSS),U,1)=LUNT
SET $PIECE(IBX1(IBS,Q,IBSS),U,2)=LUNT*CHRG
+32 IF L>1
SET $PIECE(IBX1(IBS,Q,IBSS,2),U,9)=""
+33 SET UNTS=UNTS-LUNT
SET LUNT=$SELECT(UNTS>LUNT:LUNT,1:UNTS)
End DoDot:3
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
+36 ; /Begin IB*2.0*608 - US9 - vd
VC80I(LN) ; Extracts the data for the "INS" record for VALUE CODE 80 Line item.
+1 ; INPUT: LN = Line counter
+2 ;
+3 ; Value Code 80 is no longer required and no longer significant to this US.
+4 ; however, the code and comments throughout make it appear as though it is.
+5 ; forgetaboutem!!!
+6 ; those don't hurt anything and with this being identified so late in the build, it was too much risk to rewrite.
+7 ; those changes would have added at least two more routines to the build plus a number of output formatter entries
+8 ; and all it would have gained is clarity for the next team that touches this
+9 ;
+10 NEW VC80REC,IBLOOP,IBDOS
+11 SET (VC80REC,IBLOOP)=""
+12 FOR
SET IBLOOP=$ORDER(IBXSV("VC80",IBLOOP))
if IBLOOP=""
QUIT
if $PIECE(IBXSV("VC80",IBLOOP),U)=80
QUIT
+13 IF IBLOOP]""
SET VC80REC=IBXSV("VC80",IBLOOP)
+14 ;
+15 NEW UNIT,VC80LN
+16 ; Service Unit Count
SET UNIT=$PIECE(VC80REC,U,2)
+17 ; Get the next available line number.
SET VC80LN=LN+1
+18 ;
+19 SET $PIECE(IBXSAVE("INPT",VC80LN),U,1)="0022"
+20 ;JWS;US8323;IB*2.0*623;change Procedure Code value from AAA000 to ZZZZZ on or after 10/1/2019
+21 ; used for X12 SV202-02, Loop 2400, segment SV2, institutional claims only
+22 ;WCJ;IB641;v12;check statement from date;if it's not there use the admission date (EVENT DATE)
+23 SET IBDOS=$PIECE($$GET1^DIQ(399,IBXIEN_",",151,"I"),".")
+24 IF IBDOS=""
SET IBDOS=$PIECE($$GET1^DIQ(399,IBXIEN_",",.03,"I"),".")
+25 SET $PIECE(IBXSAVE("INPT",VC80LN),U,2)=$SELECT(IBDOS<3191001:"AAA00",1:"ZZZZZ")
+26 ;
+27 ; WCJ;IB759;EBILL-3517; beginnning of changes
+28 ; S $P(IBXSAVE("INPT",VC80LN),U,4)=$S(+IBLOOP:UNIT,1:0) ; out with the old
+29 ; LENGTH OF STAY for purpose of this INS record is just the STATEMENT COVERS FROM to the STATEMENT COVERS TO
+30 ; do not include the through dates unless this is an interim bill (DISCHARGE STATUS=30 (STILL A PATIENT))
+31 ; and if ADMIT/DISCHARGE is same day, it's a 1.
+32 ;
+33 ; Left the code in there to only add this to INS if there is a Value Code 80 (Covered Days), but I don't actually use the value associated with VC 80 anywhere.
+34 ; That's just in the VC record, not the INS record.
+35 NEW IBLOS,IBUNODE,IBCTLAST
+36 SET IBCTLAST=($$GET1^DIQ(399,IBXIEN,"162:.02")=30)
+37 SET IBUNODE=$GET(^DGCR(399,IBXIEN,"U"))
+38 SET IBLOS=$$FMDIFF^XLFDT($PIECE(IBUNODE,U,2),$PIECE(IBUNODE,U))
+39 IF IBLOS=0!(IBCTLAST)
SET IBLOS=IBLOS+1
+40 ;always LOS per defect EBILL-3594
+41 ;S $P(IBXSAVE("INPT",VC80LN),U,4)=$S(+IBLOOP:IBLOS,1:0)
+42 SET $PIECE(IBXSAVE("INPT",VC80LN),U,4)=IBLOS
+43 ;
+44 SET $PIECE(IBXSAVE("INPT",VC80LN),U,9)=0
+45 ;always DAys per defect EBILL-3594
+46 ;S $P(IBXSAVE("INPT",VC80LN),U,13)=$S(+IBLOOP:"DA",1:"UN")
+47 SET $PIECE(IBXSAVE("INPT",VC80LN),U,13)="DA"
+48 ; WCJ;IB759;EBILL-3517; end of changes
+49 QUIT
+50 ; /End IB*2.0*608
+51 ;
