source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU73.m@ 1203

Last change on this file since 1203 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1IBCU73 ;ALB/ARH - ADD/DELETE MODIFIER 26 TO SPECIFIED CPTS ; 1-SEP-00
2 ;;2.0;INTEGRATED BILLING;**138,51,148,169,245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Based on Reasonable Charges v1.1, certain CPT codes should be reported with a modifier 26, indicating the
6 ; charge is only the professional portion of the charge for the procedure.
7 ;
8 ; Auto add/remove modifier 26 for specific CPT codes on a bill
9 ; - must be a Reasonable Charges v1.1 bill or greater
10 ; - the CPT must be part of a specific set of CPT's (MOD26)
11 ; - there must be both institutional and professional RC charges for the CPT
12 ; - if the bill is an institutional bill then modifier 26 is deleted, if it is defined for the CPT
13 ; - if the bill is a professional bill then modifier 26 is added, if it is not already defined for the CPT
14 ;
15CPTMOD26(IBIFN) ; add/remove modifier 26 from specific CPT codes on Reasonable Charges bills
16 N IB0,IBEVDT,IBBCT,IBCSI,IBCSP,IBBCPT,IBLN,IBMODS,IB26,IBX,IBCHANGE,IBBU,IBEND S IBCHANGE=0
17 I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) Q
18 S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBBCT=$P(IB0,U,27) Q:'IBBCT
19 S IBBU=$G(^DGCR(399,+IBIFN,"U")),IBEND=$$VERSDT^IBCRU8(2)
20 I 3001102>$P(IBBU,U,2) Q ; starts with v1.1
21 I +IBBU>IBEND Q ; ends with v2
22 I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q
23 ;
24 S IBX=$O(^IBE(363.1,"B","RC-OPT FAC")),IBCSI=$O(^IBE(363.1,"B",IBX,0)) Q:'IBCSI S IBCSI="AIVDTS"_IBCSI
25 S IBX=$O(^IBE(363.1,"B","RC-PHYSICI")),IBCSP=$O(^IBE(363.1,"B",IBX,0)) Q:'IBCSP S IBCSP="AIVDTS"_IBCSP
26 ;
27 S IBBCPT=0 F S IBBCPT=$O(^DGCR(399,IBIFN,"CP",IBBCPT)) Q:'IBBCPT D
28 . S IBLN=$G(^DGCR(399,IBIFN,"CP",IBBCPT,0)),IBEVDT=$P(IBLN,U,2) Q:IBLN'[";ICPT("
29 . I 3001102>IBEVDT Q
30 . I IBEVDT'<IBEND Q
31 . ;
32 . I '$$MOD26(+IBLN,IBEVDT) Q
33 . ;
34 . S IBX=$O(^IBA(363.2,IBCSI,+IBLN,-IBEVDT)) Q:'IBX I IBX'=$O(^IBA(363.2,IBCSP,+IBLN,-IBEVDT)) Q
35 . ;
36 . S IB26=",7,",IBMODS=","_$$GETMOD^IBEFUNC(IBIFN,IBBCPT)_","
37 . ;
38 . I IBBCT=1,IBMODS[IB26 D DELMOD(IBIFN,IBBCPT,7) S IBCHANGE=1
39 . I IBBCT=2,IBMODS'[IB26 D ADDMOD(IBIFN,IBBCPT,7) S IBCHANGE=2
40 ;
41 I '$D(ZTQUEUED),'$G(IBAUTO),+IBCHANGE W !,"Modifier 26 "_$S(IBCHANGE=1:"Deleted from",1:"Added to")_" CPT procedures."
42 Q
43 ;
44MOD26(CPT,IBDT) ; returns true if CPT should have a 26-modifier for professional bill
45 ;
46 N IBX,IBCPTX S IBX=0,IBCPTX=","_$G(CPT)_",",IBDT=$S(+$G(IBDT):IBDT,1:DT) I '$G(CPT) G MOD26Q
47 I CPT'<70000,CPT'>79999 S IBX=1
48 I CPT'<90000,CPT'>99199 S IBX=1
49 I CPT'<51725,CPT'>51797 S IBX=1
50 I ",54240,54250,59020,59025,62252,62367,62368,"[IBCPTX S IBX=1
51 ;
52 I ",75952,75953,78990,90870,90871,91100,91105,92018,92019,92502,"[IBCPTX S IBX=0
53 I ",92950,92953,92960,92961,93503,93536,93650,93651,93652,94660,94662,"[IBCPTX S IBX=0
54 I ",96405,96406,96440,96445,96450,96542,96570,96571,96902,"[IBCPTX S IBX=0
55 I CPT'<90918,CPT'>90997 S IBX=0
56 ;
57 I IBDT>3030428,",75952,75953,"[IBCPTX S IBX=1 ; should have modifier 26 in v1.4 but not v1.2
58MOD26Q Q IBX
59 ;
60DELMOD(IBIFN,BCPT,MOD) ; delete the modifier from the CPT
61 ; Input: BCPT - the ifn of the CPT in the 304 multiple
62 ; MOD - internal form of the modifier to delete
63 N DA,DR,DIE,DIC,IBLN,X,Y Q:'$G(MOD)
64 S IBLN=+$O(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),"MOD","C",MOD,0)) Q:'IBLN
65 ;
66 S DA(2)=IBIFN,DA(1)=BCPT,DA=IBLN,DIE="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"",",DR=".01///@" D ^DIE
67 Q
68 ;
69ADDMOD(IBIFN,BCPT,MOD) ; add the modifier to the CPT
70 ; Input: BCPT - the ifn of the CPT in the 304 multiple
71 ; MOD - internal form of the modifier to add
72 N DA,DR,DIE,DINUM,DIC,IBLN,IBM,IBCPM,X,Y Q:'$G(MOD)
73 S IBLN=+$O(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),"MOD","C",MOD,0)) Q:IBLN
74 ;I $$MODP^ICPTMOD(+$G(^DGCR(399,+$G(IBIFN),"CP",+$G(BCPT),0)),MOD,"I")<1 Q ; CPT 2001 too restrictive for RC
75 ;
76 I $D(^DGCR(399,IBIFN,"CP",BCPT,"MOD",1)) D ;Move modifiers out of 1
77 . S IBCPM="A"
78 . 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
79 .. N DA,DO,DD,X,Y,DINUM
80 .. S DA(2)=IBIFN,DA(1)=BCPT,DIC="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD"","
81 .. S DINUM=IBCPM+1,X=IBM+1,DIC("DR")=".02////"_$P(IBM,U,2),DIC(0)="L" D FILE^DICN K DO,DD
82 .. I Y>0 S DIE=DIC,DA(2)=IBIFN,DA(1)=BCPT,DA=IBCPM,DR=".01///@" D ^DIE
83 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
84 Q
Note: See TracBrowser for help on using the repository browser.