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

IBCU73.m

Go to the documentation of this file.
  1. IBCU73 ;ALB/ARH - ADD/DELETE MODIFIER 26 TO SPECIFIED CPTS ; 1-SEP-00
  1. ;;2.0;INTEGRATED BILLING;**138,51,148,169,245**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; Based on Reasonable Charges v1.1, certain CPT codes should be reported with a modifier 26, indicating the
  1. ; charge is only the professional portion of the charge for the procedure.
  1. ;
  1. ; Auto add/remove modifier 26 for specific CPT codes on a bill
  1. ; - must be a Reasonable Charges v1.1 bill or greater
  1. ; - the CPT must be part of a specific set of CPT's (MOD26)
  1. ; - there must be both institutional and professional RC charges for the CPT
  1. ; - if the bill is an institutional bill then modifier 26 is deleted, if it is defined for the CPT
  1. ; - if the bill is a professional bill then modifier 26 is added, if it is not already defined for the CPT
  1. ;
  1. CPTMOD26(IBIFN) ; add/remove modifier 26 from specific CPT codes on Reasonable Charges bills
  1. N IB0,IBEVDT,IBBCT,IBCSI,IBCSP,IBBCPT,IBLN,IBMODS,IB26,IBX,IBCHANGE,IBBU,IBEND S IBCHANGE=0
  1. I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) Q
  1. S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBBCT=$P(IB0,U,27) Q:'IBBCT
  1. S IBBU=$G(^DGCR(399,+IBIFN,"U")),IBEND=$$VERSDT^IBCRU8(2)
  1. I 3001102>$P(IBBU,U,2) Q ; starts with v1.1
  1. I +IBBU>IBEND Q ; ends with v2
  1. I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q
  1. ;
  1. S IBX=$O(^IBE(363.1,"B","RC-OPT FAC")),IBCSI=$O(^IBE(363.1,"B",IBX,0)) Q:'IBCSI S IBCSI="AIVDTS"_IBCSI
  1. S IBX=$O(^IBE(363.1,"B","RC-PHYSICI")),IBCSP=$O(^IBE(363.1,"B",IBX,0)) Q:'IBCSP S IBCSP="AIVDTS"_IBCSP
  1. ;
  1. S IBBCPT=0 F S IBBCPT=$O(^DGCR(399,IBIFN,"CP",IBBCPT)) Q:'IBBCPT D
  1. . S IBLN=$G(^DGCR(399,IBIFN,"CP",IBBCPT,0)),IBEVDT=$P(IBLN,U,2) Q:IBLN'[";ICPT("
  1. . I 3001102>IBEVDT Q
  1. . I IBEVDT'<IBEND Q
  1. . ;
  1. . I '$$MOD26(+IBLN,IBEVDT) Q
  1. . ;
  1. . S IBX=$O(^IBA(363.2,IBCSI,+IBLN,-IBEVDT)) Q:'IBX I IBX'=$O(^IBA(363.2,IBCSP,+IBLN,-IBEVDT)) Q
  1. . ;
  1. . S IB26=",7,",IBMODS=","_$$GETMOD^IBEFUNC(IBIFN,IBBCPT)_","
  1. . ;
  1. . I IBBCT=1,IBMODS[IB26 D DELMOD(IBIFN,IBBCPT,7) S IBCHANGE=1
  1. . I IBBCT=2,IBMODS'[IB26 D ADDMOD(IBIFN,IBBCPT,7) S IBCHANGE=2
  1. ;
  1. I '$D(ZTQUEUED),'$G(IBAUTO),+IBCHANGE W !,"Modifier 26 "_$S(IBCHANGE=1:"Deleted from",1:"Added to")_" CPT procedures."
  1. Q
  1. ;
  1. MOD26(CPT,IBDT) ; returns true if CPT should have a 26-modifier for professional bill
  1. ;
  1. N IBX,IBCPTX S IBX=0,IBCPTX=","_$G(CPT)_",",IBDT=$S(+$G(IBDT):IBDT,1:DT) I '$G(CPT) G MOD26Q
  1. I CPT'<70000,CPT'>79999 S IBX=1
  1. I CPT'<90000,CPT'>99199 S IBX=1
  1. I CPT'<51725,CPT'>51797 S IBX=1
  1. I ",54240,54250,59020,59025,62252,62367,62368,"[IBCPTX S IBX=1
  1. ;
  1. I ",75952,75953,78990,90870,90871,91100,91105,92018,92019,92502,"[IBCPTX S IBX=0
  1. I ",92950,92953,92960,92961,93503,93536,93650,93651,93652,94660,94662,"[IBCPTX S IBX=0
  1. I ",96405,96406,96440,96445,96450,96542,96570,96571,96902,"[IBCPTX S IBX=0
  1. I CPT'<90918,CPT'>90997 S IBX=0
  1. ;
  1. I IBDT>3030428,",75952,75953,"[IBCPTX S IBX=1 ; should have modifier 26 in v1.4 but not v1.2
  1. MOD26Q Q IBX
  1. ;
  1. DELMOD(IBIFN,BCPT,MOD) ; delete the modifier from the CPT
  1. ; Input: BCPT - the ifn of the CPT in the 304 multiple
  1. ; MOD - internal form of the modifier to delete
  1. N DA,DR,DIE,DIC,IBLN,X,Y Q:'$G(MOD)
  1. S IBLN=+$O(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),"MOD","C",MOD,0)) Q:'IBLN
  1. ;
  1. S DA(2)=IBIFN,DA(1)=BCPT,DA=IBLN,DIE="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"",",DR=".01///@" D ^DIE
  1. Q
  1. ;
  1. ADDMOD(IBIFN,BCPT,MOD) ; add the modifier to the CPT
  1. ; Input: BCPT - the ifn of the CPT in the 304 multiple
  1. ; MOD - internal form of the modifier to add
  1. N DA,DR,DIE,DINUM,DIC,IBLN,IBM,IBCPM,X,Y Q:'$G(MOD)
  1. S IBLN=+$O(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),"MOD","C",MOD,0)) Q:IBLN
  1. ;I $$MODP^ICPTMOD(+$G(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),0)),MOD,"I")<1 Q ; CPT 2001 too restrictive for RC
  1. ;
  1. I $D(^DGCR(399,IBIFN,"CP",BCPT,"MOD",1)) D ;Move modifiers out of 1
  1. . S IBCPM="A"
  1. . F S IBCPM=$O(^DGCR(399,IBIFN,"CP",BCPT,"MOD",IBCPM),-1) Q:'IBCPM S IBM=$G(^(IBCPM,0)) I $P(IBM,U,2) D
  1. .. N DA,DO,DD,X,Y,DINUM
  1. .. S DA(2)=IBIFN,DA(1)=BCPT,DIC="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"","
  1. .. S DINUM=IBCPM+1,X=IBM+1,DIC("DR")=".02////"_$P(IBM,U,2),DIC(0)="L" D FILE^DICN K DO,DD
  1. .. I Y>0 S DIE=DIC,DA(2)=IBIFN,DA(1)=BCPT,DA=IBCPM,DR=".01///@" D ^DIE
  1. S DINUM=1,DA(2)=IBIFN,DA(1)=BCPT,DIC="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"",",DIC("DR")=".02////"_MOD,X=1,DIC(0)="L" D FILE^DICN
  1. Q