IBCU65 ;ALB/ARH - BILL CHARGE UTILITY: COMBINE E&M ; 12/01/04
;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Combine (E&M) Charges on one bill:
; 90801-90815, 90845-90899, 99201-99215, 99241-99245, 99271-99288, 99385-99387, 99395-99429, 99499
; For each of the procedures update the first line item to include both the professional and facility charge
; If there is another line item for the procedure then delete it (no bill CT)
;
ASKCMB(IBIFN) ; if the user requests, combine (E&M) charges on the bill
N DIR,DIRUT,DTOUT,DUOUT,X,Y S IBIFN=+$G(IBIFN) Q:'IBIFN
;
I '$$CHKBILL(IBIFN) Q ; provider based bill with combinable procedures
;
W !! S DIR("?")="Enter Yes to add both Institutional and Professional charge for E&M codes"
S DIR("?",1)="The Professional and Facility charges of certain E&M codes may be combined onto"
S DIR("?",2)="one line item on this bill.",DIR("?",3)=" "
S DIR("B")="NO",DIR("A")="Combine Institutional and Professional Charges for E&M Procedures"
S DIR(0)="Y" D ^DIR Q:$D(DIRUT) Q:'Y
;
I Y=1 D CHGCMB(IBIFN)
Q
;
CHGCMB(IBIFN) ; combine certain E&M codes on the bill
N IBRC,IBRC0,IBCPT,IBRCCT,IBMATCH,IBCHGS,IBTCHG,IBDONE,IBX K ^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
;
D BILLCHG(IBIFN) I '$D(^TMP($J,"IBCU65 CMB")) Q
;
S IBRC=0 F S IBRC=$O(^DGCR(399,IBIFN,"RC",IBRC)) Q:'IBRC D
. S IBRC0=$G(^DGCR(399,IBIFN,"RC",IBRC,0))
. ;
. S IBCPT=$P(IBRC0,U,6) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; charge must be for a combinable cpt
. S IBRCCT=$P(IBRC0,U,12) I IBRCCT'=1,IBRCCT'=2 Q ; must be a component charge
. I '$P(IBRC0,U,8) Q ; charge must be auto created
. ;
. S IBMATCH=$P(IBRC0,U,3)_U_IBCPT_U_$P(IBRC0,U,7)_U_$P(IBRC0,U,10)_U_$P(IBRC0,U,11)
. ;
. S IBCHGS=$G(^TMP($J,"IBCU65 CMB",IBMATCH)) Q:IBCHGS="" ; find match
. ;
. I +$G(IBDONE(IBMATCH)) I $$RVDEL(IBIFN,IBRC) D Q ; if already combined delete line item
.. S IBX(IBCPT_" "_IBRC)=$S(IBRCCT=1:"Facility",1:"Professional")_" Charge for "_IBCPT_" deleted "_$P(IBRC0,U,2)
. ;
. S IBTCHG=$P(IBCHGS,U,3) Q:'IBTCHG
. ;
. I $$RVCHG(IBIFN,IBRC,IBTCHG) S IBDONE(IBMATCH)=1 D ; match found, combine charges
.. S IBX(IBCPT_" "_IBRC)="Charge for "_IBCPT_" combined: "_$P(IBCHGS,U,1)_"+"_$P(IBCHGS,U,2)_"="_IBTCHG
;
I '$D(ZTQUEUED),'$G(IBAUTO) S IBX="" F S IBX=$O(IBX(IBX)) Q:IBX="" W !,IBX(IBX)
K ^TMP($J,"IBCU65 CMB")
Q
;
;
;
RVDEL(IBIFN,RCIFN) ; delete charge line item, Output: 0/1
; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple
N IBX,DIK,DIC,X,Y,Z,Z1,DA,D0,D1,DG,DICR,DIG,DIH,DIW,DGXRF1 S IBX=0
I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
. S DA(1)=+IBIFN,DA=+RCIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK K DIK
Q IBX
;
RVCHG(IBIFN,RCIFN,CHG) ; update line item charge and remove component, Output: 0/1
; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple, CHG = New Charge Amount
N IBX,DA,DIE,DIC,DR,X,Y,Z,Z1,D,D0,D1,DI,DQ,DGXRF1 S IBX=0
I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
. S DA(1)=+IBIFN,DIE="^DGCR(399,"_DA(1)_",""RC"",",DR=".12///@;.02////"_+$G(CHG),DA=+RCIFN D ^DIE
Q IBX
;
;
CHKCODE(CPT) ; return true if CPT code combinable
N IBOUT S CPT=+$G(CPT) S IBOUT=0
I (CPT<90800)!(CPT>99500) S IBOUT=0 G CHKCODQ
;
I CPT>90800,CPT<90816 S IBOUT=1 G CHKCODQ
I CPT>90844,CPT<90900 S IBOUT=1 G CHKCODQ
I CPT>99200,CPT<99216 S IBOUT=1 G CHKCODQ
I CPT>99240,CPT<99246 S IBOUT=1 G CHKCODQ
I CPT>99270,CPT<99289 S IBOUT=1 G CHKCODQ
I CPT>99384,CPT<99388 S IBOUT=1 G CHKCODQ
I CPT>99394,CPT<99430 S IBOUT=1 G CHKCODQ
I CPT=99499 S IBOUT=1
;
CHKCODQ Q IBOUT
;
CHKBILL(IBIFN) ; return true if combining charges is applicable or available for bill
; bill must be Provider Based and have at least one combinable procedure
N IBOUT,IBX,IBY S IBOUT=0 S IBIFN=+$G(IBIFN) I 'IBIFN G CHKBILQ
;
S IBX=$P($G(^DGCR(399,+IBIFN,0)),U,22) S IBY=$P($$RCDV^IBCRU8(IBX),U,3) I IBY'=1,IBY'=2 S IBOUT=0 G CHKBILQ
;
S IBX="90800;" F S IBX=$O(^DGCR(399,IBIFN,"CP","B",IBX)) Q:('IBX)!(+IBX>99499) I +$$CHKCODE(+IBX) S IBOUT=1 Q
;
CHKBILQ Q IBOUT
;
;
BILLCHG(IBIFN) ; get all possible charges for bill with discounts applied
; output array of charges for combinable procedures
; Output: ^TMP($J,"IBCU65 CMB", "units ^ cpt ^ div ^ itm type ^ itm ptr") = inst chg ^ prof chg ^ total chg
;
N IBX,IB0,IBU,IBBRT,IBBTYPE,IBCBARR,IBLN,IBCPT,IBCMP,IBSBCR,IBCHGI,IBCHGP
K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
K ^TMP($J,"IBCU65 TMP"),^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
I '$O(^DGCR(399,+IBIFN,"RC",0)) Q
;
S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3)
;
; get standard set of charge sets available for bill, including all Instutional and Professional charge sets
D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBCBARR,"PROCEDURE") I 'IBCBARR Q
;
; get all possible charges and sort as they would be added to the bill, including all discounts applied
D BILL^IBCRBH1(IBIFN,1,.IBCBARR),SORTCI^IBCRBH1(IBIFN)
;
;
; compile like charges for procedures that are combinable
S IBX=0 F S IBX=$O(^TMP($J,"IBCRCSX",IBX)) Q:'IBX D
. S IBLN=$G(^TMP($J,"IBCRCSX",IBX))
. ;
. S IBCPT=$P(IBLN,U,5) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; CPT must be defined and combinable
. S IBCMP=+$P(IBLN,U,9) Q:'IBCMP ; must be a component charge
. I '$P(IBLN,U,8) Q ; item pointer must be defined
. I $P(IBLN,U,7)'=4 Q ; item type must be cpt
. ;
. S IBSBCR=$P(IBLN,U,4,8)
. S ^TMP($J,"IBCU65 TMP",IBSBCR)=+$G(^TMP($J,"IBCU65 TMP",IBSBCR))+1
. S ^TMP($J,"IBCU65 TMP",IBSBCR,IBCMP)=IBLN
;
;
; compile array of combinable charges by procedure, must be combinable cpt and have both charges available
S IBSBCR="" F S IBSBCR=$O(^TMP($J,"IBCU65 TMP",IBSBCR)) Q:IBSBCR="" D
. I +$G(^TMP($J,"IBCU65 TMP",IBSBCR))'=2 Q
. ;
. S IBCHGI=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,1)),U,3) Q:'IBCHGI
. S IBCHGP=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,2)),U,3) Q:'IBCHGP
. ;
. S ^TMP($J,"IBCU65 CMB",IBSBCR)=IBCHGI_U_IBCHGP_U_(IBCHGI+IBCHGP)
;
;
K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN"),^TMP($J,"IBCU65 TMP")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU65 6362 printed Dec 13, 2024@02:20:47 Page 2
IBCU65 ;ALB/ARH - BILL CHARGE UTILITY: COMBINE E&M ; 12/01/04
+1 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Combine (E&M) Charges on one bill:
+5 ; 90801-90815, 90845-90899, 99201-99215, 99241-99245, 99271-99288, 99385-99387, 99395-99429, 99499
+6 ; For each of the procedures update the first line item to include both the professional and facility charge
+7 ; If there is another line item for the procedure then delete it (no bill CT)
+8 ;
ASKCMB(IBIFN) ; if the user requests, combine (E&M) charges on the bill
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
SET IBIFN=+$GET(IBIFN)
if 'IBIFN
QUIT
+2 ;
+3 ; provider based bill with combinable procedures
IF '$$CHKBILL(IBIFN)
QUIT
+4 ;
+5 WRITE !!
SET DIR("?")="Enter Yes to add both Institutional and Professional charge for E&M codes"
+6 SET DIR("?",1)="The Professional and Facility charges of certain E&M codes may be combined onto"
+7 SET DIR("?",2)="one line item on this bill."
SET DIR("?",3)=" "
+8 SET DIR("B")="NO"
SET DIR("A")="Combine Institutional and Professional Charges for E&M Procedures"
+9 SET DIR(0)="Y"
DO ^DIR
if $DATA(DIRUT)
QUIT
if 'Y
QUIT
+10 ;
+11 IF Y=1
DO CHGCMB(IBIFN)
+12 QUIT
+13 ;
CHGCMB(IBIFN) ; combine certain E&M codes on the bill
+1 NEW IBRC,IBRC0,IBCPT,IBRCCT,IBMATCH,IBCHGS,IBTCHG,IBDONE,IBX
KILL ^TMP($JOB,"IBCU65 CMB")
if '$GET(IBIFN)
QUIT
+2 ;
+3 DO BILLCHG(IBIFN)
IF '$DATA(^TMP($JOB,"IBCU65 CMB"))
QUIT
+4 ;
+5 SET IBRC=0
FOR
SET IBRC=$ORDER(^DGCR(399,IBIFN,"RC",IBRC))
if 'IBRC
QUIT
Begin DoDot:1
+6 SET IBRC0=$GET(^DGCR(399,IBIFN,"RC",IBRC,0))
+7 ;
+8 ; charge must be for a combinable cpt
SET IBCPT=$PIECE(IBRC0,U,6)
if 'IBCPT
QUIT
IF '$$CHKCODE(IBCPT)
QUIT
+9 ; must be a component charge
SET IBRCCT=$PIECE(IBRC0,U,12)
IF IBRCCT'=1
IF IBRCCT'=2
QUIT
+10 ; charge must be auto created
IF '$PIECE(IBRC0,U,8)
QUIT
+11 ;
+12 SET IBMATCH=$PIECE(IBRC0,U,3)_U_IBCPT_U_$PIECE(IBRC0,U,7)_U_$PIECE(IBRC0,U,10)_U_$PIECE(IBRC0,U,11)
+13 ;
+14 ; find match
SET IBCHGS=$GET(^TMP($JOB,"IBCU65 CMB",IBMATCH))
if IBCHGS=""
QUIT
+15 ;
+16 ; if already combined delete line item
IF +$GET(IBDONE(IBMATCH))
IF $$RVDEL(IBIFN,IBRC)
Begin DoDot:2
+17 SET IBX(IBCPT_" "_IBRC)=$SELECT(IBRCCT=1:"Facility",1:"Professional")_" Charge for "_IBCPT_" deleted "_$PIECE(IBRC0,U,2)
End DoDot:2
QUIT
+18 ;
+19 SET IBTCHG=$PIECE(IBCHGS,U,3)
if 'IBTCHG
QUIT
+20 ;
+21 ; match found, combine charges
IF $$RVCHG(IBIFN,IBRC,IBTCHG)
SET IBDONE(IBMATCH)=1
Begin DoDot:2
+22 SET IBX(IBCPT_" "_IBRC)="Charge for "_IBCPT_" combined: "_$PIECE(IBCHGS,U,1)_"+"_$PIECE(IBCHGS,U,2)_"="_IBTCHG
End DoDot:2
End DoDot:1
+23 ;
+24 IF '$DATA(ZTQUEUED)
IF '$GET(IBAUTO)
SET IBX=""
FOR
SET IBX=$ORDER(IBX(IBX))
if IBX=""
QUIT
WRITE !,IBX(IBX)
+25 KILL ^TMP($JOB,"IBCU65 CMB")
+26 QUIT
+27 ;
+28 ;
+29 ;
RVDEL(IBIFN,RCIFN) ; delete charge line item, Output: 0/1
+1 ; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple
+2 NEW IBX,DIK,DIC,X,Y,Z,Z1,DA,D0,D1,DG,DICR,DIG,DIH,DIW,DGXRF1
SET IBX=0
+3 IF $DATA(^DGCR(399,+$GET(IBIFN),"RC",+$GET(RCIFN),0))
Begin DoDot:1
+4 SET DA(1)=+IBIFN
SET DA=+RCIFN
SET DIK="^DGCR(399,"_DA(1)_",""RC"","
DO ^DIK
KILL DIK
End DoDot:1
SET IBX=1
+5 QUIT IBX
+6 ;
RVCHG(IBIFN,RCIFN,CHG) ; update line item charge and remove component, Output: 0/1
+1 ; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple, CHG = New Charge Amount
+2 NEW IBX,DA,DIE,DIC,DR,X,Y,Z,Z1,D,D0,D1,DI,DQ,DGXRF1
SET IBX=0
+3 IF $DATA(^DGCR(399,+$GET(IBIFN),"RC",+$GET(RCIFN),0))
Begin DoDot:1
+4 SET DA(1)=+IBIFN
SET DIE="^DGCR(399,"_DA(1)_",""RC"","
SET DR=".12///@;.02////"_+$GET(CHG)
SET DA=+RCIFN
DO ^DIE
End DoDot:1
SET IBX=1
+5 QUIT IBX
+6 ;
+7 ;
CHKCODE(CPT) ; return true if CPT code combinable
+1 NEW IBOUT
SET CPT=+$GET(CPT)
SET IBOUT=0
+2 IF (CPT<90800)!(CPT>99500)
SET IBOUT=0
GOTO CHKCODQ
+3 ;
+4 IF CPT>90800
IF CPT<90816
SET IBOUT=1
GOTO CHKCODQ
+5 IF CPT>90844
IF CPT<90900
SET IBOUT=1
GOTO CHKCODQ
+6 IF CPT>99200
IF CPT<99216
SET IBOUT=1
GOTO CHKCODQ
+7 IF CPT>99240
IF CPT<99246
SET IBOUT=1
GOTO CHKCODQ
+8 IF CPT>99270
IF CPT<99289
SET IBOUT=1
GOTO CHKCODQ
+9 IF CPT>99384
IF CPT<99388
SET IBOUT=1
GOTO CHKCODQ
+10 IF CPT>99394
IF CPT<99430
SET IBOUT=1
GOTO CHKCODQ
+11 IF CPT=99499
SET IBOUT=1
+12 ;
CHKCODQ QUIT IBOUT
+1 ;
CHKBILL(IBIFN) ; return true if combining charges is applicable or available for bill
+1 ; bill must be Provider Based and have at least one combinable procedure
+2 NEW IBOUT,IBX,IBY
SET IBOUT=0
SET IBIFN=+$GET(IBIFN)
IF 'IBIFN
GOTO CHKBILQ
+3 ;
+4 SET IBX=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,22)
SET IBY=$PIECE($$RCDV^IBCRU8(IBX),U,3)
IF IBY'=1
IF IBY'=2
SET IBOUT=0
GOTO CHKBILQ
+5 ;
+6 SET IBX="90800;"
FOR
SET IBX=$ORDER(^DGCR(399,IBIFN,"CP","B",IBX))
if ('IBX)!(+IBX>99499)
QUIT
IF +$$CHKCODE(+IBX)
SET IBOUT=1
QUIT
+7 ;
CHKBILQ QUIT IBOUT
+1 ;
+2 ;
BILLCHG(IBIFN) ; get all possible charges for bill with discounts applied
+1 ; output array of charges for combinable procedures
+2 ; Output: ^TMP($J,"IBCU65 CMB", "units ^ cpt ^ div ^ itm type ^ itm ptr") = inst chg ^ prof chg ^ total chg
+3 ;
+4 NEW IBX,IB0,IBU,IBBRT,IBBTYPE,IBCBARR,IBLN,IBCPT,IBCMP,IBSBCR,IBCHGI,IBCHGP
+5 KILL ^TMP($JOB,"IBCRCC"),^TMP($JOB,"IBCRCSX"),^TMP($JOB,"IBCRCSXR"),^TMP($JOB,"IBCRCSXN")
+6 KILL ^TMP($JOB,"IBCU65 TMP"),^TMP($JOB,"IBCU65 CMB")
if '$GET(IBIFN)
QUIT
+7 IF '$ORDER(^DGCR(399,+IBIFN,"RC",0))
QUIT
+8 ;
+9 SET IB0=$GET(^DGCR(399,+IBIFN,0))
if IB0=""
QUIT
SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
if 'IBU
QUIT
+10 SET IBBRT=+$PIECE(IB0,U,7)
SET IBBTYPE=$SELECT($PIECE(IB0,U,5)<3:1,1:3)
+11 ;
+12 ; get standard set of charge sets available for bill, including all Instutional and Professional charge sets
+13 DO RT^IBCRU3(IBBRT,IBBTYPE,$PIECE(IBU,U,1,2),.IBCBARR,"PROCEDURE")
IF 'IBCBARR
QUIT
+14 ;
+15 ; get all possible charges and sort as they would be added to the bill, including all discounts applied
+16 DO BILL^IBCRBH1(IBIFN,1,.IBCBARR)
DO SORTCI^IBCRBH1(IBIFN)
+17 ;
+18 ;
+19 ; compile like charges for procedures that are combinable
+20 SET IBX=0
FOR
SET IBX=$ORDER(^TMP($JOB,"IBCRCSX",IBX))
if 'IBX
QUIT
Begin DoDot:1
+21 SET IBLN=$GET(^TMP($JOB,"IBCRCSX",IBX))
+22 ;
+23 ; CPT must be defined and combinable
SET IBCPT=$PIECE(IBLN,U,5)
if 'IBCPT
QUIT
IF '$$CHKCODE(IBCPT)
QUIT
+24 ; must be a component charge
SET IBCMP=+$PIECE(IBLN,U,9)
if 'IBCMP
QUIT
+25 ; item pointer must be defined
IF '$PIECE(IBLN,U,8)
QUIT
+26 ; item type must be cpt
IF $PIECE(IBLN,U,7)'=4
QUIT
+27 ;
+28 SET IBSBCR=$PIECE(IBLN,U,4,8)
+29 SET ^TMP($JOB,"IBCU65 TMP",IBSBCR)=+$GET(^TMP($JOB,"IBCU65 TMP",IBSBCR))+1
+30 SET ^TMP($JOB,"IBCU65 TMP",IBSBCR,IBCMP)=IBLN
End DoDot:1
+31 ;
+32 ;
+33 ; compile array of combinable charges by procedure, must be combinable cpt and have both charges available
+34 SET IBSBCR=""
FOR
SET IBSBCR=$ORDER(^TMP($JOB,"IBCU65 TMP",IBSBCR))
if IBSBCR=""
QUIT
Begin DoDot:1
+35 IF +$GET(^TMP($JOB,"IBCU65 TMP",IBSBCR))'=2
QUIT
+36 ;
+37 SET IBCHGI=$PIECE($GET(^TMP($JOB,"IBCU65 TMP",IBSBCR,1)),U,3)
if 'IBCHGI
QUIT
+38 SET IBCHGP=$PIECE($GET(^TMP($JOB,"IBCU65 TMP",IBSBCR,2)),U,3)
if 'IBCHGP
QUIT
+39 ;
+40 SET ^TMP($JOB,"IBCU65 CMB",IBSBCR)=IBCHGI_U_IBCHGP_U_(IBCHGI+IBCHGP)
End DoDot:1
+41 ;
+42 ;
+43 KILL ^TMP($JOB,"IBCRCC"),^TMP($JOB,"IBCRCSX"),^TMP($JOB,"IBCRCSXR"),^TMP($JOB,"IBCRCSXN"),^TMP($JOB,"IBCU65 TMP")
+44 QUIT
