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

IBCU7A1.m

Go to the documentation of this file.
  1. IBCU7A1 ;ALB/ARH - BILL PROCEDURE MANIPULATIONS (BUNDLED) ; 10-OCT-03
  1. ;;2.0;INTEGRATED BILLING;**245,270,598**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. 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
  1. ; on freestanding bills component codes should be billed as global
  1. ; - on facility bill, if a global code is found in the clinical data and on the bill then
  1. ; replace it on the bill with the institutional components
  1. ; - on professional bill, if the global code is found in the clinical data and the institutional components
  1. ; are found on the bill then replace the institutional components with the professional components
  1. ; - on a freestanding bill if all institutional and professional components are found then
  1. ; replace them with the global code
  1. ; maximum of 10 is insurance against infinite loops
  1. N IB0,IBCT,IBDVTY,IBTYPE,IBI,IBJ,IBLN,IBGLB,IBNLN,IBNEW,IBDEL,IBRPL,IBX,IBMSG,IBCHANGE,IB029,IBMCPT S IBCHANGE=0
  1. S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""
  1. S IBCT=$P(IB0,U,27) Q:'IBCT S IBDVTY=$P($$RCDV^IBCRU8($P(IB0,U,22)),U,3)
  1. S IBTYPE=$S(IBDVTY=3:3,1:+IBCT)
  1. ;
  1. I +$O(^DGCR(399,+$G(IBIFN),"CP","B","94017;ICPT("),-1)<93000 Q ; none of the bundled codes on bill
  1. ;
  1. I IBDVTY'=3 D GETSD^IBCU7U(IBIFN) ; for provider based sites global charge should be in clincal data
  1. ;
  1. ; loop through list of bundled procedures and find any on bill
  1. F IBI=1:1 S IBLN=$P($T(IPBI+IBI),";;",2) Q:IBLN="" D
  1. . S IBGLB=$P(IBLN,":",1),IBCHANGE=0
  1. .
  1. . ; *598 procedures split for 0295T
  1. . S IB029=0
  1. . I IBGLB="0295T" S IB029=1,IBLN=$$IB029A(IBGLB,IBLN),IBGLB=$P(IBLN,":",1)
  1. . ;
  1. . S IBNLN=$$IPB(IBLN,IBTYPE) Q:'IBNLN S IBNEW=$P(IBNLN,":",2),IBDEL=$P(IBNLN,":",1)
  1. . ;
  1. . I IBDVTY'=3,'$D(^UTILITY($J,"CPT-CLN",+IBGLB)) Q
  1. . ;
  1. . ; search the bill for the list of procedures to be replaced
  1. . F IBJ=1:1 S IBRPL=$$FND(IBIFN,IBDEL) Q:'IBRPL D Q:IBJ>10
  1. .. ;
  1. .. I IBDVTY'=3,'$D(^UTILITY($J,"CPT-CLN",+IBGLB,+IBRPL)) Q
  1. .. S IBRPL=$P(IBRPL,U,2,999) I $L(IBRPL,U)'=$L(IBDEL,U) Q
  1. .. ;
  1. .. I +$$RPL(IBIFN,IBNEW,IBRPL) S IBCHANGE=1 ; replace procedures
  1. . ;
  1. . I +IBCHANGE,IB029 S IBDEL=$$IB029C(IBDEL),IBNEW=$$IB029C(IBNEW)
  1. . I +IBCHANGE S IBMSG(IBI)=$TR(IBDEL,"^",",")_" replaced by "_$TR(IBNEW,"^",",")
  1. ;
  1. I '$D(ZTQUEUED),'$G(IBAUTO),+$O(IBMSG(0)) S IBI=0 F S IBI=$O(IBMSG(IBI)) Q:'IBI W !,IBMSG(IBI)
  1. Q
  1. ;
  1. RPL(IBIFN,NEWCPTS,OLDLIST) ; replace procedures on the bill
  1. ; Input: NEWCPTS - list of CPT codes to add to the bill
  1. ; OLDLIST - list of procedure ifn's on the bill to be replaced
  1. ; Output: returns true if changes made
  1. ; the list of new and replaced may not be the same length
  1. ; - if more CPT's to be added than exist then the first existing procedure is copied for the new CPT
  1. ; - if fewer CPT's to be added than exist then the extra entries on the bill are deleted
  1. N IBJ,IBFFN,IBRFN,IBNCPT,IBFND S IBFND=0
  1. ;
  1. S NEWCPTS=$G(NEWCPTS),OLDLIST=$G(OLDLIST),IBFFN=+OLDLIST
  1. ;
  1. F IBJ=1:1 S IBRFN=$P(OLDLIST,U,IBJ),IBNCPT=$P(NEWCPTS,U,IBJ) Q:('IBRFN)&('IBNCPT) D Q:'IBFND
  1. . I +IBRFN,'IBNCPT S IBFND=$$DELCPT^IBCU7U(IBIFN,IBRFN) Q
  1. . I 'IBRFN,+IBNCPT S IBFND=$$COPYCPT^IBCU7U(IBIFN,IBFFN,IBNCPT) Q
  1. . I +IBRFN,+IBNCPT D
  1. .. I '$G(IB029) S IBFND=$$EDITCPT^IBCU7U(IBIFN,IBRFN,IBNCPT) Q
  1. .. S IBFND=$$IB029B(IBIFN,IBRFN,IBNCPT)
  1. Q IBFND
  1. ;
  1. IB029A(IBGLB,IBLN) ; return ien of cpt code
  1. ; input: IBGLB = 0295T
  1. ; IBLN = 0295T:0296T^0297T:0298T
  1. N IBTXT,IBTCPT S IBTCPT=0
  1. S IBTXT=$P(IBLN,":",2)
  1. S IBTCPT=+$$CPT^ICPTCOD(IBGLB)_":"_+$$CPT^ICPTCOD($P(IBTXT,U,1))_U_+$$CPT^ICPTCOD($P(IBTXT,U,2))_":"_+$$CPT^ICPTCOD($P(IBLN,":",3))
  1. Q IBTCPT
  1. ;
  1. IB029B(IBIFN,OLDDA,NEWCPT) ; replace cpt with another
  1. ; input: OLDDA = ien of cpt in bill cpt multiple to be replaced
  1. ; NEWCPT = ien of cpt code to be added
  1. N DA,DIE,IBTCPT,IBFND,IBZ,X,Y S IBFND=0,DA(1)=+$G(IBIFN),DA=+$G(OLDDA),NEWCPT=+$G(NEWCPT),IBTCPT=NEWCPT
  1. 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
  1. Q IBFND
  1. ;
  1. IB029C(IBMCPT) ; return cpt code(s) for display
  1. ; input: IBMCPT = ien of cpt to be replaced
  1. ; output: IBTCPT = cpt code(s) separated by '^'
  1. N IBZ,IBTXT,IBTCPT S IBTCPT=""
  1. S IBTXT=$P(IBMCPT,U,1),IBTCPT=$P($$CPT^ICPTCOD(IBTXT),U,2)
  1. F IBZ=2:1 S IBTXT=$P(IBMCPT,U,IBZ) Q:IBTXT="" S IBTCPT=IBTCPT_U_$P($$CPT^ICPTCOD(IBTXT),U,2)
  1. Q IBTCPT
  1. ;
  1. 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
  1. ; Input: list of CPT's to be replaced separated by '^', internal format
  1. ; Output: procedure date ^ ifn of procedures in bill CP multiple
  1. N IBJ,IBC1,IBC1N,IBC1D,IBC2,IBC2N,IBC2D,IBFND,IBNLIST S (IBFND,IBNLIST)=0 I '$G(LIST) G FNDQ
  1. ;
  1. ; start with the first procedure to be replaced if it is on the bill then search for the rest on same date
  1. S IBC1=$P(LIST,U,1)
  1. S IBC1N=0 F S IBC1N=$O(^DGCR(399,+$G(IBIFN),"CP","B",IBC1_";ICPT(",IBC1N)) Q:'IBC1N D Q:IBFND
  1. . S IBC1D=$P($G(^DGCR(399,IBIFN,"CP",IBC1N,0)),U,2)
  1. . S IBFND=1,IBNLIST=IBC1D_U_IBC1N
  1. . ;
  1. . ; find other procedures to be replaced for same date
  1. . F IBJ=2:1 S IBC2=$P(LIST,U,IBJ) Q:'IBC2 S IBFND=0 D Q:'IBFND
  1. .. S IBC2N=0 F S IBC2N=$O(^DGCR(399,IBIFN,"CP","B",IBC2_";ICPT(",IBC2N)) Q:'IBC2N D Q:IBFND
  1. ... S IBC2D=$P($G(^DGCR(399,IBIFN,"CP",IBC2N,0)),U,2) I IBC1D'=IBC2D S IBFND=0 Q
  1. ... S IBFND=1,IBNLIST=IBNLIST_U_IBC2N
  1. . ;
  1. . I 'IBFND S IBNLIST=0
  1. ;
  1. FNDQ Q IBNLIST
  1. ;
  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
  1. ; Output: Procedures to be replaced ':' Procedures they are replaced with
  1. N IBX,IBI,IBLN,IBRPL S IBX="",CPT=$G(CPT),TYPE=+$G(TYPE)
  1. I +TYPE,CPT>92999,CPT<94017 F IBI=1:1 S IBLN=$P($T(IPBI+IBI),";;",2) Q:IBLN="" D Q:+IBX
  1. . S IBRPL=$$IPB(IBLN,TYPE) I $P(IBRPL,":",1)[CPT S IBX=IBRPL
  1. Q IBX
  1. ;
  1. ;
  1. 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
  1. ; TYPE - 1 for institutional, 2 for professional, 3 for Non-Provider Based
  1. ; Output: Procedures to be replaced ':' Procedures they are replaced with
  1. ; - institutional type the global is replaced by the technical componentes
  1. ; - professional type: the institutional components are replaced by the professional components
  1. ; - non-provider based: the institutional and professional components are preplaced by the global
  1. ;
  1. N IBNEW,IBDEL,IBX S (IBX,IBDEL,IBNEW)="",TYPE=$G(TYPE),LINE=$G(LINE)
  1. I TYPE=1 S IBNEW=$P(LINE,":",2),IBDEL=$P(LINE,":",1)
  1. I TYPE=2 S IBNEW=$P(LINE,":",3),IBDEL=$P(LINE,":",2)
  1. I TYPE=3 S IBNEW=$P(LINE,":",1),IBDEL=$P(LINE,":",2)_U_$P(LINE,":",3)
  1. S IBX=IBDEL_":"_IBNEW
  1. Q IBX
  1. ;
  1. IPBI ; Facility Provider Based Replace Global by Technical Component: global:technical:professional
  1. ;;93000:93005:93010
  1. ;;93015:93017:93016^93018
  1. ;;93040:93041:93042
  1. ;;93224:93225^93226:93227
  1. ;;93230:93231^93232:93233
  1. ;;93235:93236:93237
  1. ;;93268:93270^93271:93272
  1. ;;93720:93721:93722
  1. ;;93784:93786^93788:93790
  1. ;;94014:94015:94016
  1. ;;0295T:0296T^0297T:0298T
  1. ;;