Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCU65

IBCU65.m

Go to the documentation of this file.
  1. IBCU65 ;ALB/ARH - BILL CHARGE UTILITY: COMBINE E&M ; 12/01/04
  1. ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; Combine (E&M) Charges on one bill:
  1. ; 90801-90815, 90845-90899, 99201-99215, 99241-99245, 99271-99288, 99385-99387, 99395-99429, 99499
  1. ; For each of the procedures update the first line item to include both the professional and facility charge
  1. ; If there is another line item for the procedure then delete it (no bill CT)
  1. ;
  1. ASKCMB(IBIFN) ; if the user requests, combine (E&M) charges on the bill
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y S IBIFN=+$G(IBIFN) Q:'IBIFN
  1. ;
  1. I '$$CHKBILL(IBIFN) Q ; provider based bill with combinable procedures
  1. ;
  1. W !! S DIR("?")="Enter Yes to add both Institutional and Professional charge for E&M codes"
  1. S DIR("?",1)="The Professional and Facility charges of certain E&M codes may be combined onto"
  1. S DIR("?",2)="one line item on this bill.",DIR("?",3)=" "
  1. S DIR("B")="NO",DIR("A")="Combine Institutional and Professional Charges for E&M Procedures"
  1. S DIR(0)="Y" D ^DIR Q:$D(DIRUT) Q:'Y
  1. ;
  1. I Y=1 D CHGCMB(IBIFN)
  1. Q
  1. ;
  1. CHGCMB(IBIFN) ; combine certain E&M codes on the bill
  1. N IBRC,IBRC0,IBCPT,IBRCCT,IBMATCH,IBCHGS,IBTCHG,IBDONE,IBX K ^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
  1. ;
  1. D BILLCHG(IBIFN) I '$D(^TMP($J,"IBCU65 CMB")) Q
  1. ;
  1. S IBRC=0 F S IBRC=$O(^DGCR(399,IBIFN,"RC",IBRC)) Q:'IBRC D
  1. . S IBRC0=$G(^DGCR(399,IBIFN,"RC",IBRC,0))
  1. . ;
  1. . S IBCPT=$P(IBRC0,U,6) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; charge must be for a combinable cpt
  1. . S IBRCCT=$P(IBRC0,U,12) I IBRCCT'=1,IBRCCT'=2 Q ; must be a component charge
  1. . I '$P(IBRC0,U,8) Q ; charge must be auto created
  1. . ;
  1. . S IBMATCH=$P(IBRC0,U,3)_U_IBCPT_U_$P(IBRC0,U,7)_U_$P(IBRC0,U,10)_U_$P(IBRC0,U,11)
  1. . ;
  1. . S IBCHGS=$G(^TMP($J,"IBCU65 CMB",IBMATCH)) Q:IBCHGS="" ; find match
  1. . ;
  1. . I +$G(IBDONE(IBMATCH)) I $$RVDEL(IBIFN,IBRC) D Q ; if already combined delete line item
  1. .. S IBX(IBCPT_" "_IBRC)=$S(IBRCCT=1:"Facility",1:"Professional")_" Charge for "_IBCPT_" deleted "_$P(IBRC0,U,2)
  1. . ;
  1. . S IBTCHG=$P(IBCHGS,U,3) Q:'IBTCHG
  1. . ;
  1. . I $$RVCHG(IBIFN,IBRC,IBTCHG) S IBDONE(IBMATCH)=1 D ; match found, combine charges
  1. .. S IBX(IBCPT_" "_IBRC)="Charge for "_IBCPT_" combined: "_$P(IBCHGS,U,1)_"+"_$P(IBCHGS,U,2)_"="_IBTCHG
  1. ;
  1. I '$D(ZTQUEUED),'$G(IBAUTO) S IBX="" F S IBX=$O(IBX(IBX)) Q:IBX="" W !,IBX(IBX)
  1. K ^TMP($J,"IBCU65 CMB")
  1. Q
  1. ;
  1. ;
  1. ;
  1. RVDEL(IBIFN,RCIFN) ; delete charge line item, Output: 0/1
  1. ; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple
  1. N IBX,DIK,DIC,X,Y,Z,Z1,DA,D0,D1,DG,DICR,DIG,DIH,DIW,DGXRF1 S IBX=0
  1. I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
  1. . S DA(1)=+IBIFN,DA=+RCIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK K DIK
  1. Q IBX
  1. ;
  1. 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
  1. N IBX,DA,DIE,DIC,DR,X,Y,Z,Z1,D,D0,D1,DI,DQ,DGXRF1 S IBX=0
  1. I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
  1. . S DA(1)=+IBIFN,DIE="^DGCR(399,"_DA(1)_",""RC"",",DR=".12///@;.02////"_+$G(CHG),DA=+RCIFN D ^DIE
  1. Q IBX
  1. ;
  1. ;
  1. CHKCODE(CPT) ; return true if CPT code combinable
  1. N IBOUT S CPT=+$G(CPT) S IBOUT=0
  1. I (CPT<90800)!(CPT>99500) S IBOUT=0 G CHKCODQ
  1. ;
  1. I CPT>90800,CPT<90816 S IBOUT=1 G CHKCODQ
  1. I CPT>90844,CPT<90900 S IBOUT=1 G CHKCODQ
  1. I CPT>99200,CPT<99216 S IBOUT=1 G CHKCODQ
  1. I CPT>99240,CPT<99246 S IBOUT=1 G CHKCODQ
  1. I CPT>99270,CPT<99289 S IBOUT=1 G CHKCODQ
  1. I CPT>99384,CPT<99388 S IBOUT=1 G CHKCODQ
  1. I CPT>99394,CPT<99430 S IBOUT=1 G CHKCODQ
  1. I CPT=99499 S IBOUT=1
  1. ;
  1. CHKCODQ Q IBOUT
  1. ;
  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
  1. N IBOUT,IBX,IBY S IBOUT=0 S IBIFN=+$G(IBIFN) I 'IBIFN G CHKBILQ
  1. ;
  1. 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
  1. ;
  1. S IBX="90800;" F S IBX=$O(^DGCR(399,IBIFN,"CP","B",IBX)) Q:('IBX)!(+IBX>99499) I +$$CHKCODE(+IBX) S IBOUT=1 Q
  1. ;
  1. CHKBILQ Q IBOUT
  1. ;
  1. ;
  1. BILLCHG(IBIFN) ; get all possible charges for bill with discounts applied
  1. ; output array of charges for combinable procedures
  1. ; Output: ^TMP($J,"IBCU65 CMB", "units ^ cpt ^ div ^ itm type ^ itm ptr") = inst chg ^ prof chg ^ total chg
  1. ;
  1. N IBX,IB0,IBU,IBBRT,IBBTYPE,IBCBARR,IBLN,IBCPT,IBCMP,IBSBCR,IBCHGI,IBCHGP
  1. K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
  1. K ^TMP($J,"IBCU65 TMP"),^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
  1. I '$O(^DGCR(399,+IBIFN,"RC",0)) Q
  1. ;
  1. S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
  1. S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3)
  1. ;
  1. ; get standard set of charge sets available for bill, including all Instutional and Professional charge sets
  1. D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBCBARR,"PROCEDURE") I 'IBCBARR Q
  1. ;
  1. ; get all possible charges and sort as they would be added to the bill, including all discounts applied
  1. D BILL^IBCRBH1(IBIFN,1,.IBCBARR),SORTCI^IBCRBH1(IBIFN)
  1. ;
  1. ;
  1. ; compile like charges for procedures that are combinable
  1. S IBX=0 F S IBX=$O(^TMP($J,"IBCRCSX",IBX)) Q:'IBX D
  1. . S IBLN=$G(^TMP($J,"IBCRCSX",IBX))
  1. . ;
  1. . S IBCPT=$P(IBLN,U,5) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; CPT must be defined and combinable
  1. . S IBCMP=+$P(IBLN,U,9) Q:'IBCMP ; must be a component charge
  1. . I '$P(IBLN,U,8) Q ; item pointer must be defined
  1. . I $P(IBLN,U,7)'=4 Q ; item type must be cpt
  1. . ;
  1. . S IBSBCR=$P(IBLN,U,4,8)
  1. . S ^TMP($J,"IBCU65 TMP",IBSBCR)=+$G(^TMP($J,"IBCU65 TMP",IBSBCR))+1
  1. . S ^TMP($J,"IBCU65 TMP",IBSBCR,IBCMP)=IBLN
  1. ;
  1. ;
  1. ; compile array of combinable charges by procedure, must be combinable cpt and have both charges available
  1. S IBSBCR="" F S IBSBCR=$O(^TMP($J,"IBCU65 TMP",IBSBCR)) Q:IBSBCR="" D
  1. . I +$G(^TMP($J,"IBCU65 TMP",IBSBCR))'=2 Q
  1. . ;
  1. . S IBCHGI=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,1)),U,3) Q:'IBCHGI
  1. . S IBCHGP=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,2)),U,3) Q:'IBCHGP
  1. . ;
  1. . S ^TMP($J,"IBCU65 CMB",IBSBCR)=IBCHGI_U_IBCHGP_U_(IBCHGI+IBCHGP)
  1. ;
  1. ;
  1. K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN"),^TMP($J,"IBCU65 TMP")
  1. Q