IBCU7A1 ;ALB/ARH - BILL PROCEDURE MANIPULATIONS (BUNDLED) ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245,270,598**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;
BNDL(IBIFN) ; manipulate a bill's CPT codes, replace bundled codes
; on facility and profesional bills global codes should be billed using their components
; on freestanding bills component codes should be billed as global
; - on facility bill, if a global code is found in the clinical data and on the bill then
; replace it on the bill with the institutional components
; - on professional bill, if the global code is found in the clinical data and the institutional components
; are found on the bill then replace the institutional components with the professional components
; - on a freestanding bill if all institutional and professional components are found then
; replace them with the global code
; maximum of 10 is insurance against infinite loops
N IB0,IBCT,IBDVTY,IBTYPE,IBI,IBJ,IBLN,IBGLB,IBNLN,IBNEW,IBDEL,IBRPL,IBX,IBMSG,IBCHANGE,IB029,IBMCPT S IBCHANGE=0
S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""
S IBCT=$P(IB0,U,27) Q:'IBCT S IBDVTY=$P($$RCDV^IBCRU8($P(IB0,U,22)),U,3)
S IBTYPE=$S(IBDVTY=3:3,1:+IBCT)
;
I +$O(^DGCR(399,+$G(IBIFN),"CP","B","94017;ICPT("),-1)<93000 Q ; none of the bundled codes on bill
;
I IBDVTY'=3 D GETSD^IBCU7U(IBIFN) ; for provider based sites global charge should be in clincal data
;
; loop through list of bundled procedures and find any on bill
F IBI=1:1 S IBLN=$P($T(IPBI+IBI),";;",2) Q:IBLN="" D
. S IBGLB=$P(IBLN,":",1),IBCHANGE=0
.
. ; *598 procedures split for 0295T
. S IB029=0
. I IBGLB="0295T" S IB029=1,IBLN=$$IB029A(IBGLB,IBLN),IBGLB=$P(IBLN,":",1)
. ;
. S IBNLN=$$IPB(IBLN,IBTYPE) Q:'IBNLN S IBNEW=$P(IBNLN,":",2),IBDEL=$P(IBNLN,":",1)
. ;
. I IBDVTY'=3,'$D(^UTILITY($J,"CPT-CLN",+IBGLB)) Q
. ;
. ; search the bill for the list of procedures to be replaced
. F IBJ=1:1 S IBRPL=$$FND(IBIFN,IBDEL) Q:'IBRPL D Q:IBJ>10
.. ;
.. I IBDVTY'=3,'$D(^UTILITY($J,"CPT-CLN",+IBGLB,+IBRPL)) Q
.. S IBRPL=$P(IBRPL,U,2,999) I $L(IBRPL,U)'=$L(IBDEL,U) Q
.. ;
.. I +$$RPL(IBIFN,IBNEW,IBRPL) S IBCHANGE=1 ; replace procedures
. ;
. I +IBCHANGE,IB029 S IBDEL=$$IB029C(IBDEL),IBNEW=$$IB029C(IBNEW)
. I +IBCHANGE S IBMSG(IBI)=$TR(IBDEL,"^",",")_" replaced by "_$TR(IBNEW,"^",",")
;
I '$D(ZTQUEUED),'$G(IBAUTO),+$O(IBMSG(0)) S IBI=0 F S IBI=$O(IBMSG(IBI)) Q:'IBI W !,IBMSG(IBI)
Q
;
RPL(IBIFN,NEWCPTS,OLDLIST) ; replace procedures on the bill
; Input: NEWCPTS - list of CPT codes to add to the bill
; OLDLIST - list of procedure ifn's on the bill to be replaced
; Output: returns true if changes made
; the list of new and replaced may not be the same length
; - if more CPT's to be added than exist then the first existing procedure is copied for the new CPT
; - if fewer CPT's to be added than exist then the extra entries on the bill are deleted
N IBJ,IBFFN,IBRFN,IBNCPT,IBFND S IBFND=0
;
S NEWCPTS=$G(NEWCPTS),OLDLIST=$G(OLDLIST),IBFFN=+OLDLIST
;
F IBJ=1:1 S IBRFN=$P(OLDLIST,U,IBJ),IBNCPT=$P(NEWCPTS,U,IBJ) Q:('IBRFN)&('IBNCPT) D Q:'IBFND
. I +IBRFN,'IBNCPT S IBFND=$$DELCPT^IBCU7U(IBIFN,IBRFN) Q
. I 'IBRFN,+IBNCPT S IBFND=$$COPYCPT^IBCU7U(IBIFN,IBFFN,IBNCPT) Q
. I +IBRFN,+IBNCPT D
.. I '$G(IB029) S IBFND=$$EDITCPT^IBCU7U(IBIFN,IBRFN,IBNCPT) Q
.. S IBFND=$$IB029B(IBIFN,IBRFN,IBNCPT)
Q IBFND
;
IB029A(IBGLB,IBLN) ; return ien of cpt code
; input: IBGLB = 0295T
; IBLN = 0295T:0296T^0297T:0298T
N IBTXT,IBTCPT S IBTCPT=0
S IBTXT=$P(IBLN,":",2)
S IBTCPT=+$$CPT^ICPTCOD(IBGLB)_":"_+$$CPT^ICPTCOD($P(IBTXT,U,1))_U_+$$CPT^ICPTCOD($P(IBTXT,U,2))_":"_+$$CPT^ICPTCOD($P(IBLN,":",3))
Q IBTCPT
;
IB029B(IBIFN,OLDDA,NEWCPT) ; replace cpt with another
; input: OLDDA = ien of cpt in bill cpt multiple to be replaced
; NEWCPT = ien of cpt code to be added
N DA,DIE,IBTCPT,IBFND,IBZ,X,Y S IBFND=0,DA(1)=+$G(IBIFN),DA=+$G(OLDDA),NEWCPT=+$G(NEWCPT),IBTCPT=NEWCPT
I NEWCPT,$D(^DGCR(399,DA(1),"CP",DA,0)) D FDA^DILF(399.0304,.DA,.01,,IBTCPT_";ICPT(","IBZ"),FILE^DIE(,"IBZ") S IBFND=1
Q IBFND
;
IB029C(IBMCPT) ; return cpt code(s) for display
; input: IBMCPT = ien of cpt to be replaced
; output: IBTCPT = cpt code(s) separated by '^'
N IBZ,IBTXT,IBTCPT S IBTCPT=""
S IBTXT=$P(IBMCPT,U,1),IBTCPT=$P($$CPT^ICPTCOD(IBTXT),U,2)
F IBZ=2:1 S IBTXT=$P(IBMCPT,U,IBZ) Q:IBTXT="" S IBTCPT=IBTCPT_U_$P($$CPT^ICPTCOD(IBTXT),U,2)
Q IBTCPT
;
FND(IBIFN,LIST) ; find first set of the procedures on the bill to be replaced
; if all found then returns procedure date followed by 'CP' ifn list
; Input: list of CPT's to be replaced separated by '^', internal format
; Output: procedure date ^ ifn of procedures in bill CP multiple
N IBJ,IBC1,IBC1N,IBC1D,IBC2,IBC2N,IBC2D,IBFND,IBNLIST S (IBFND,IBNLIST)=0 I '$G(LIST) G FNDQ
;
; start with the first procedure to be replaced if it is on the bill then search for the rest on same date
S IBC1=$P(LIST,U,1)
S IBC1N=0 F S IBC1N=$O(^DGCR(399,+$G(IBIFN),"CP","B",IBC1_";ICPT(",IBC1N)) Q:'IBC1N D Q:IBFND
. S IBC1D=$P($G(^DGCR(399,IBIFN,"CP",IBC1N,0)),U,2)
. S IBFND=1,IBNLIST=IBC1D_U_IBC1N
. ;
. ; find other procedures to be replaced for same date
. F IBJ=2:1 S IBC2=$P(LIST,U,IBJ) Q:'IBC2 S IBFND=0 D Q:'IBFND
.. S IBC2N=0 F S IBC2N=$O(^DGCR(399,IBIFN,"CP","B",IBC2_";ICPT(",IBC2N)) Q:'IBC2N D Q:IBFND
... S IBC2D=$P($G(^DGCR(399,IBIFN,"CP",IBC2N,0)),U,2) I IBC1D'=IBC2D S IBFND=0 Q
... S IBFND=1,IBNLIST=IBNLIST_U_IBC2N
. ;
. I 'IBFND S IBNLIST=0
;
FNDQ Q IBNLIST
;
CHKIPB(CPT,TYPE) ; return procedures that may replace procedure passed in
; Input: TYPE - 1 for institutional, 2 for professional, 3 for Non-Provider Based
; Output: Procedures to be replaced ':' Procedures they are replaced with
N IBX,IBI,IBLN,IBRPL S IBX="",CPT=$G(CPT),TYPE=+$G(TYPE)
I +TYPE,CPT>92999,CPT<94017 F IBI=1:1 S IBLN=$P($T(IPBI+IBI),";;",2) Q:IBLN="" D Q:+IBX
. S IBRPL=$$IPB(IBLN,TYPE) I $P(IBRPL,":",1)[CPT S IBX=IBRPL
Q IBX
;
;
IPB(LINE,TYPE) ; return procedures to be replaced and those they are replaced by for the type of bill
; Input: LINE - line of bundled procedures from IPBI
; TYPE - 1 for institutional, 2 for professional, 3 for Non-Provider Based
; Output: Procedures to be replaced ':' Procedures they are replaced with
; - institutional type the global is replaced by the technical componentes
; - professional type: the institutional components are replaced by the professional components
; - non-provider based: the institutional and professional components are preplaced by the global
;
N IBNEW,IBDEL,IBX S (IBX,IBDEL,IBNEW)="",TYPE=$G(TYPE),LINE=$G(LINE)
I TYPE=1 S IBNEW=$P(LINE,":",2),IBDEL=$P(LINE,":",1)
I TYPE=2 S IBNEW=$P(LINE,":",3),IBDEL=$P(LINE,":",2)
I TYPE=3 S IBNEW=$P(LINE,":",1),IBDEL=$P(LINE,":",2)_U_$P(LINE,":",3)
S IBX=IBDEL_":"_IBNEW
Q IBX
;
IPBI ; Facility Provider Based Replace Global by Technical Component: global:technical:professional
;;93000:93005:93010
;;93015:93017:93016^93018
;;93040:93041:93042
;;93224:93225^93226:93227
;;93230:93231^93232:93233
;;93235:93236:93237
;;93268:93270^93271:93272
;;93720:93721:93722
;;93784:93786^93788:93790
;;94014:94015:94016
;;0295T:0296T^0297T:0298T
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU7A1 7421 printed Sep 23, 2025@19:57:09 Page 2
IBCU7A1 ;ALB/ARH - BILL PROCEDURE MANIPULATIONS (BUNDLED) ; 10-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245,270,598**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
BNDL(IBIFN) ; manipulate a bill's CPT codes, replace bundled codes
+1 ; on facility and profesional bills global codes should be billed using their components
+2 ; on freestanding bills component codes should be billed as global
+3 ; - on facility bill, if a global code is found in the clinical data and on the bill then
+4 ; replace it on the bill with the institutional components
+5 ; - on professional bill, if the global code is found in the clinical data and the institutional components
+6 ; are found on the bill then replace the institutional components with the professional components
+7 ; - on a freestanding bill if all institutional and professional components are found then
+8 ; replace them with the global code
+9 ; maximum of 10 is insurance against infinite loops
+10 NEW IB0,IBCT,IBDVTY,IBTYPE,IBI,IBJ,IBLN,IBGLB,IBNLN,IBNEW,IBDEL,IBRPL,IBX,IBMSG,IBCHANGE,IB029,IBMCPT
SET IBCHANGE=0
+11 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
if IB0=""
QUIT
+12 SET IBCT=$PIECE(IB0,U,27)
if 'IBCT
QUIT
SET IBDVTY=$PIECE($$RCDV^IBCRU8($PIECE(IB0,U,22)),U,3)
+13 SET IBTYPE=$SELECT(IBDVTY=3:3,1:+IBCT)
+14 ;
+15 ; none of the bundled codes on bill
IF +$ORDER(^DGCR(399,+$GET(IBIFN),"CP","B","94017;ICPT("),-1)<93000
QUIT
+16 ;
+17 ; for provider based sites global charge should be in clincal data
IF IBDVTY'=3
DO GETSD^IBCU7U(IBIFN)
+18 ;
+19 ; loop through list of bundled procedures and find any on bill
+20 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(IPBI+IBI),";;",2)
if IBLN=""
QUIT
Begin DoDot:1
+21 SET IBGLB=$PIECE(IBLN,":",1)
SET IBCHANGE=0
+22 +23 ; *598 procedures split for 0295T
+24 SET IB029=0
+25 IF IBGLB="0295T"
SET IB029=1
SET IBLN=$$IB029A(IBGLB,IBLN)
SET IBGLB=$PIECE(IBLN,":",1)
+26 ;
+27 SET IBNLN=$$IPB(IBLN,IBTYPE)
if 'IBNLN
QUIT
SET IBNEW=$PIECE(IBNLN,":",2)
SET IBDEL=$PIECE(IBNLN,":",1)
+28 ;
+29 IF IBDVTY'=3
IF '$DATA(^UTILITY($JOB,"CPT-CLN",+IBGLB))
QUIT
+30 ;
+31 ; search the bill for the list of procedures to be replaced
+32 FOR IBJ=1:1
SET IBRPL=$$FND(IBIFN,IBDEL)
if 'IBRPL
QUIT
Begin DoDot:2
+33 ;
+34 IF IBDVTY'=3
IF '$DATA(^UTILITY($JOB,"CPT-CLN",+IBGLB,+IBRPL))
QUIT
+35 SET IBRPL=$PIECE(IBRPL,U,2,999)
IF $LENGTH(IBRPL,U)'=$LENGTH(IBDEL,U)
QUIT
+36 ;
+37 ; replace procedures
IF +$$RPL(IBIFN,IBNEW,IBRPL)
SET IBCHANGE=1
End DoDot:2
if IBJ>10
QUIT
+38 ;
+39 IF +IBCHANGE
IF IB029
SET IBDEL=$$IB029C(IBDEL)
SET IBNEW=$$IB029C(IBNEW)
+40 IF +IBCHANGE
SET IBMSG(IBI)=$TRANSLATE(IBDEL,"^",",")_" replaced by "_$TRANSLATE(IBNEW,"^",",")
End DoDot:1
+41 ;
+42 IF '$DATA(ZTQUEUED)
IF '$GET(IBAUTO)
IF +$ORDER(IBMSG(0))
SET IBI=0
FOR
SET IBI=$ORDER(IBMSG(IBI))
if 'IBI
QUIT
WRITE !,IBMSG(IBI)
+43 QUIT
+44 ;
RPL(IBIFN,NEWCPTS,OLDLIST) ; replace procedures on the bill
+1 ; Input: NEWCPTS - list of CPT codes to add to the bill
+2 ; OLDLIST - list of procedure ifn's on the bill to be replaced
+3 ; Output: returns true if changes made
+4 ; the list of new and replaced may not be the same length
+5 ; - if more CPT's to be added than exist then the first existing procedure is copied for the new CPT
+6 ; - if fewer CPT's to be added than exist then the extra entries on the bill are deleted
+7 NEW IBJ,IBFFN,IBRFN,IBNCPT,IBFND
SET IBFND=0
+8 ;
+9 SET NEWCPTS=$GET(NEWCPTS)
SET OLDLIST=$GET(OLDLIST)
SET IBFFN=+OLDLIST
+10 ;
+11 FOR IBJ=1:1
SET IBRFN=$PIECE(OLDLIST,U,IBJ)
SET IBNCPT=$PIECE(NEWCPTS,U,IBJ)
if ('IBRFN)&('IBNCPT)
QUIT
Begin DoDot:1
+12 IF +IBRFN
IF 'IBNCPT
SET IBFND=$$DELCPT^IBCU7U(IBIFN,IBRFN)
QUIT
+13 IF 'IBRFN
IF +IBNCPT
SET IBFND=$$COPYCPT^IBCU7U(IBIFN,IBFFN,IBNCPT)
QUIT
+14 IF +IBRFN
IF +IBNCPT
Begin DoDot:2
+15 IF '$GET(IB029)
SET IBFND=$$EDITCPT^IBCU7U(IBIFN,IBRFN,IBNCPT)
QUIT
+16 SET IBFND=$$IB029B(IBIFN,IBRFN,IBNCPT)
End DoDot:2
End DoDot:1
if 'IBFND
QUIT
+17 QUIT IBFND
+18 ;
IB029A(IBGLB,IBLN) ; return ien of cpt code
+1 ; input: IBGLB = 0295T
+2 ; IBLN = 0295T:0296T^0297T:0298T
+3 NEW IBTXT,IBTCPT
SET IBTCPT=0
+4 SET IBTXT=$PIECE(IBLN,":",2)
+5 SET IBTCPT=+$$CPT^ICPTCOD(IBGLB)_":"_+$$CPT^ICPTCOD($PIECE(IBTXT,U,1))_U_+$$CPT^ICPTCOD($PIECE(IBTXT,U,2))_":"_+$$CPT^ICPTCOD($PIECE(IBLN,":",3))
+6 QUIT IBTCPT
+7 ;
IB029B(IBIFN,OLDDA,NEWCPT) ; replace cpt with another
+1 ; input: OLDDA = ien of cpt in bill cpt multiple to be replaced
+2 ; NEWCPT = ien of cpt code to be added
+3 NEW DA,DIE,IBTCPT,IBFND,IBZ,X,Y
SET IBFND=0
SET DA(1)=+$GET(IBIFN)
SET DA=+$GET(OLDDA)
SET NEWCPT=+$GET(NEWCPT)
SET IBTCPT=NEWCPT
+4 IF NEWCPT
IF $DATA(^DGCR(399,DA(1),"CP",DA,0))
DO FDA^DILF(399.0304,.DA,.01,,IBTCPT_";ICPT(","IBZ")
DO FILE^DIE(,"IBZ")
SET IBFND=1
+5 QUIT IBFND
+6 ;
IB029C(IBMCPT) ; return cpt code(s) for display
+1 ; input: IBMCPT = ien of cpt to be replaced
+2 ; output: IBTCPT = cpt code(s) separated by '^'
+3 NEW IBZ,IBTXT,IBTCPT
SET IBTCPT=""
+4 SET IBTXT=$PIECE(IBMCPT,U,1)
SET IBTCPT=$PIECE($$CPT^ICPTCOD(IBTXT),U,2)
+5 FOR IBZ=2:1
SET IBTXT=$PIECE(IBMCPT,U,IBZ)
if IBTXT=""
QUIT
SET IBTCPT=IBTCPT_U_$PIECE($$CPT^ICPTCOD(IBTXT),U,2)
+6 QUIT IBTCPT
+7 ;
FND(IBIFN,LIST) ; find first set of the procedures on the bill to be replaced
+1 ; if all found then returns procedure date followed by 'CP' ifn list
+2 ; Input: list of CPT's to be replaced separated by '^', internal format
+3 ; Output: procedure date ^ ifn of procedures in bill CP multiple
+4 NEW IBJ,IBC1,IBC1N,IBC1D,IBC2,IBC2N,IBC2D,IBFND,IBNLIST
SET (IBFND,IBNLIST)=0
IF '$GET(LIST)
GOTO FNDQ
+5 ;
+6 ; start with the first procedure to be replaced if it is on the bill then search for the rest on same date
+7 SET IBC1=$PIECE(LIST,U,1)
+8 SET IBC1N=0
FOR
SET IBC1N=$ORDER(^DGCR(399,+$GET(IBIFN),"CP","B",IBC1_";ICPT(",IBC1N))
if 'IBC1N
QUIT
Begin DoDot:1
+9 SET IBC1D=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBC1N,0)),U,2)
+10 SET IBFND=1
SET IBNLIST=IBC1D_U_IBC1N
+11 ;
+12 ; find other procedures to be replaced for same date
+13 FOR IBJ=2:1
SET IBC2=$PIECE(LIST,U,IBJ)
if 'IBC2
QUIT
SET IBFND=0
Begin DoDot:2
+14 SET IBC2N=0
FOR
SET IBC2N=$ORDER(^DGCR(399,IBIFN,"CP","B",IBC2_";ICPT(",IBC2N))
if 'IBC2N
QUIT
Begin DoDot:3
+15 SET IBC2D=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBC2N,0)),U,2)
IF IBC1D'=IBC2D
SET IBFND=0
QUIT
+16 SET IBFND=1
SET IBNLIST=IBNLIST_U_IBC2N
End DoDot:3
if IBFND
QUIT
End DoDot:2
if 'IBFND
QUIT
+17 ;
+18 IF 'IBFND
SET IBNLIST=0
End DoDot:1
if IBFND
QUIT
+19 ;
FNDQ QUIT IBNLIST
+1 ;
CHKIPB(CPT,TYPE) ; return procedures that may replace procedure passed in
+1 ; Input: TYPE - 1 for institutional, 2 for professional, 3 for Non-Provider Based
+2 ; Output: Procedures to be replaced ':' Procedures they are replaced with
+3 NEW IBX,IBI,IBLN,IBRPL
SET IBX=""
SET CPT=$GET(CPT)
SET TYPE=+$GET(TYPE)
+4 IF +TYPE
IF CPT>92999
IF CPT<94017
FOR IBI=1:1
SET IBLN=$PIECE($TEXT(IPBI+IBI),";;",2)
if IBLN=""
QUIT
Begin DoDot:1
+5 SET IBRPL=$$IPB(IBLN,TYPE)
IF $PIECE(IBRPL,":",1)[CPT
SET IBX=IBRPL
End DoDot:1
if +IBX
QUIT
+6 QUIT IBX
+7 ;
+8 ;
IPB(LINE,TYPE) ; return procedures to be replaced and those they are replaced by for the type of bill
+1 ; Input: LINE - line of bundled procedures from IPBI
+2 ; TYPE - 1 for institutional, 2 for professional, 3 for Non-Provider Based
+3 ; Output: Procedures to be replaced ':' Procedures they are replaced with
+4 ; - institutional type the global is replaced by the technical componentes
+5 ; - professional type: the institutional components are replaced by the professional components
+6 ; - non-provider based: the institutional and professional components are preplaced by the global
+7 ;
+8 NEW IBNEW,IBDEL,IBX
SET (IBX,IBDEL,IBNEW)=""
SET TYPE=$GET(TYPE)
SET LINE=$GET(LINE)
+9 IF TYPE=1
SET IBNEW=$PIECE(LINE,":",2)
SET IBDEL=$PIECE(LINE,":",1)
+10 IF TYPE=2
SET IBNEW=$PIECE(LINE,":",3)
SET IBDEL=$PIECE(LINE,":",2)
+11 IF TYPE=3
SET IBNEW=$PIECE(LINE,":",1)
SET IBDEL=$PIECE(LINE,":",2)_U_$PIECE(LINE,":",3)
+12 SET IBX=IBDEL_":"_IBNEW
+13 QUIT IBX
+14 ;
IPBI ; Facility Provider Based Replace Global by Technical Component: global:technical:professional
+1 ;;93000:93005:93010
+2 ;;93015:93017:93016^93018
+3 ;;93040:93041:93042
+4 ;;93224:93225^93226:93227
+5 ;;93230:93231^93232:93233
+6 ;;93235:93236:93237
+7 ;;93268:93270^93271:93272
+8 ;;93720:93721:93722
+9 ;;93784:93786^93788:93790
+10 ;;94014:94015:94016
+11 ;;0295T:0296T^0297T:0298T
+12 ;;
