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