- 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 Jan 18, 2025@03:21:59 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