IBCRHBRA ;ALB/ARH - RATES: UPLOAD RC V1 CPT 2000 CHARGES ; 10-OCT-2000
;;2.0;INTEGRATED BILLING;**138,169**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; add CPT 2000 Replacement Codes to RC v1
; these are new codes that directly replace codes that have been inactivated, the charges for the old code
; can be used as the charge for the new code
;
CPT2000 ; add CPT replacement codes to RC charge sets, use the current charge of the CPT they are replacing
N IBI,IBLN,IBOLD,IBNEW,IBITM,IBCI,IBCIN,IBCS,IBCSN,IBCNT,IB2000DT,X,Y,DIC,IBENDDT S IBCNT=0
S IB2000DT=3000201
S IBENDDT=$$VERSEDT^IBCRHBRV(1)
;
I '$D(ZTQUEUED) W !!,"Adding CPT 2000 Replacement Charges for RC v1 ... "
F IBI=1:1 S IBLN=$P($T(F2000+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D
. ;
. S IBOLD=$P(IBLN,U,1) I IBOLD'?5N Q
. S IBNEW=$P(IBLN,U,2) I IBNEW'?5N Q
. ;
. S IBITM=IBOLD_";ICPT(",IBCI=0 F S IBCI=$O(^IBA(363.2,"B",IBITM,IBCI)) Q:'IBCI D
.. ;
.. S IBCIN=$G(^IBA(363.2,+IBCI,0)) I $P(IBCIN,U,3)'=2990901,$P(IBCIN,U,3)'=2981001 Q
.. S IBCS=$P(IBCIN,U,2),IBCSN=$G(^IBE(363.1,+IBCS,0)) I '$$CSRC(IBCS) Q
.. ;
.. D DEL(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5))
.. I $$EXISTS(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5)) Q
.. ;
.. I $$ADDCI^IBCREF(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5),$P(IBCIN,U,6),$P(IBCIN,U,7),IBENDDT) S IBCNT=IBCNT+1
;
I '$D(ZTQUEUED) W IBCNT," charges added."
Q
;
EXISTS(IBCS,IBITM,IBEFFDT,IBCHG) ; return ifn of charge item if this charge exists
N IBX,IBCI S IBX=0
I +$G(IBCS),+$G(IBITM),+$G(IBEFFDT),+$G(IBCHG) D
. S IBCI=0 F S IBCI=$O(^IBA(363.2,"AIVDTS"_IBCS,IBITM,-IBEFFDT,IBCI)) Q:'IBCI D Q:+IBX
.. I $P($G(^IBA(363.2,+IBCI,0)),U,5)=IBCHG S IBX=IBCI
Q IBX
;
DEL(IBCS,IBITM,IBEFFDT,IBCHG) ; delete any existing charges the site may have added to the charge sets for the New CPT replacement codes
; the charge to be deleted must be effective before RC v1.1 and it must not be the correct replacement,
; ie. delete any v1 charge for the item in a CS that does not match the date/charge passed in
N IBDT,IBCI,IBCIN,IBCNT,X,Y,DIC,DIK,DA S IBCNT=0 I '$G(IBEFFDT)!('$G(IBCHG)) Q
;
S IBDT="" F S IBDT=$O(^IBA(363.2,"AIVDTS"_+$G(IBCS),+$G(IBITM),IBDT)) Q:IBDT="" D
. I -IBDT>3000701 Q
. ;
. S IBCI=0 F S IBCI=$O(^IBA(363.2,"AIVDTS"_IBCS,IBITM,IBDT,IBCI)) Q:'IBCI D
.. S IBCIN=$G(^IBA(363.2,+IBCI,0)) I -IBDT=IBEFFDT,IBCHG=$P(IBCIN,U,5) Q
.. ;
.. S DA=IBCI,DIK="^IBA(363.2," D ^DIK K DA,DIK S IBCNT=IBCNT+1
;
Q
;
CSRC(IBCS) ; return true if the Charge Set is Reasonable Charges and CPT based
N IBX,IBCSN,IBBRN S IBX=0
I +$G(IBCS) S IBCSN=$G(^IBE(363.1,+IBCS,0))
I $G(IBCSN)'="" S IBBRN=$G(^IBE(363.3,+$P(IBCSN,U,2),0))
;
I $G(IBBRN)'="",$E(IBBRN,1,3)="RC ",$P(IBBRN,U,4)=2 S IBX=1
;
Q IBX
;
;
F2000 ; old^new CPTs
;;32001^32997
;;56300^49320
;;56301^58670
;;56302^58671
;;56303^58662
;;56304^58660
;;56305^49321
;;56306^49322
;;56307^58661
;;56308^58550
;;56309^58551
;;56310^44200
;;56311^38570
;;56312^38571
;;56313^38572
;;56314^49323
;;56315^44970
;;56316^49650
;;56317^49651
;;56318^54690
;;56320^55550
;;56322^43651
;;56323^43652
;;56324^47570
;;56340^47562
;;56341^47563
;;56342^47564
;;56343^58673
;;56344^58672
;;56346^43653
;;56348^44202
;;56349^43280
;;56350^58555
;;56351^58558
;;56352^58559
;;56353^58560
;;56354^58561
;;56355^58562
;;56356^58563
;;56362^47560
;;56363^47561
;;64442^64475
;;64443^64476
;;80049^80048
;;80054^80053
;;80058^80076
;;80059^80074
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBRA 3608 printed Dec 13, 2024@02:19:20 Page 2
IBCRHBRA ;ALB/ARH - RATES: UPLOAD RC V1 CPT 2000 CHARGES ; 10-OCT-2000
+1 ;;2.0;INTEGRATED BILLING;**138,169**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; add CPT 2000 Replacement Codes to RC v1
+5 ; these are new codes that directly replace codes that have been inactivated, the charges for the old code
+6 ; can be used as the charge for the new code
+7 ;
CPT2000 ; add CPT replacement codes to RC charge sets, use the current charge of the CPT they are replacing
+1 NEW IBI,IBLN,IBOLD,IBNEW,IBITM,IBCI,IBCIN,IBCS,IBCSN,IBCNT,IB2000DT,X,Y,DIC,IBENDDT
SET IBCNT=0
+2 SET IB2000DT=3000201
+3 SET IBENDDT=$$VERSEDT^IBCRHBRV(1)
+4 ;
+5 IF '$DATA(ZTQUEUED)
WRITE !!,"Adding CPT 2000 Replacement Charges for RC v1 ... "
+6 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(F2000+IBI),";;",2)
if IBLN=""
QUIT
IF $EXTRACT(IBLN,1)'=" "
Begin DoDot:1
+7 ;
+8 SET IBOLD=$PIECE(IBLN,U,1)
IF IBOLD'?5N
QUIT
+9 SET IBNEW=$PIECE(IBLN,U,2)
IF IBNEW'?5N
QUIT
+10 ;
+11 SET IBITM=IBOLD_";ICPT("
SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,"B",IBITM,IBCI))
if 'IBCI
QUIT
Begin DoDot:2
+12 ;
+13 SET IBCIN=$GET(^IBA(363.2,+IBCI,0))
IF $PIECE(IBCIN,U,3)'=2990901
IF $PIECE(IBCIN,U,3)'=2981001
QUIT
+14 SET IBCS=$PIECE(IBCIN,U,2)
SET IBCSN=$GET(^IBE(363.1,+IBCS,0))
IF '$$CSRC(IBCS)
QUIT
+15 ;
+16 DO DEL(IBCS,IBNEW,IB2000DT,$PIECE(IBCIN,U,5))
+17 IF $$EXISTS(IBCS,IBNEW,IB2000DT,$PIECE(IBCIN,U,5))
QUIT
+18 ;
+19 IF $$ADDCI^IBCREF(IBCS,IBNEW,IB2000DT,$PIECE(IBCIN,U,5),$PIECE(IBCIN,U,6),$PIECE(IBCIN,U,7),IBENDDT)
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
+20 ;
+21 IF '$DATA(ZTQUEUED)
WRITE IBCNT," charges added."
+22 QUIT
+23 ;
EXISTS(IBCS,IBITM,IBEFFDT,IBCHG) ; return ifn of charge item if this charge exists
+1 NEW IBX,IBCI
SET IBX=0
+2 IF +$GET(IBCS)
IF +$GET(IBITM)
IF +$GET(IBEFFDT)
IF +$GET(IBCHG)
Begin DoDot:1
+3 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,"AIVDTS"_IBCS,IBITM,-IBEFFDT,IBCI))
if 'IBCI
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^IBA(363.2,+IBCI,0)),U,5)=IBCHG
SET IBX=IBCI
End DoDot:2
if +IBX
QUIT
End DoDot:1
+5 QUIT IBX
+6 ;
DEL(IBCS,IBITM,IBEFFDT,IBCHG) ; delete any existing charges the site may have added to the charge sets for the New CPT replacement codes
+1 ; the charge to be deleted must be effective before RC v1.1 and it must not be the correct replacement,
+2 ; ie. delete any v1 charge for the item in a CS that does not match the date/charge passed in
+3 NEW IBDT,IBCI,IBCIN,IBCNT,X,Y,DIC,DIK,DA
SET IBCNT=0
IF '$GET(IBEFFDT)!('$GET(IBCHG))
QUIT
+4 ;
+5 SET IBDT=""
FOR
SET IBDT=$ORDER(^IBA(363.2,"AIVDTS"_+$GET(IBCS),+$GET(IBITM),IBDT))
if IBDT=""
QUIT
Begin DoDot:1
+6 IF -IBDT>3000701
QUIT
+7 ;
+8 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,"AIVDTS"_IBCS,IBITM,IBDT,IBCI))
if 'IBCI
QUIT
Begin DoDot:2
+9 SET IBCIN=$GET(^IBA(363.2,+IBCI,0))
IF -IBDT=IBEFFDT
IF IBCHG=$PIECE(IBCIN,U,5)
QUIT
+10 ;
+11 SET DA=IBCI
SET DIK="^IBA(363.2,"
DO ^DIK
KILL DA,DIK
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
+12 ;
+13 QUIT
+14 ;
CSRC(IBCS) ; return true if the Charge Set is Reasonable Charges and CPT based
+1 NEW IBX,IBCSN,IBBRN
SET IBX=0
+2 IF +$GET(IBCS)
SET IBCSN=$GET(^IBE(363.1,+IBCS,0))
+3 IF $GET(IBCSN)'=""
SET IBBRN=$GET(^IBE(363.3,+$PIECE(IBCSN,U,2),0))
+4 ;
+5 IF $GET(IBBRN)'=""
IF $EXTRACT(IBBRN,1,3)="RC "
IF $PIECE(IBBRN,U,4)=2
SET IBX=1
+6 ;
+7 QUIT IBX
+8 ;
+9 ;
F2000 ; old^new CPTs
+1 ;;32001^32997
+2 ;;56300^49320
+3 ;;56301^58670
+4 ;;56302^58671
+5 ;;56303^58662
+6 ;;56304^58660
+7 ;;56305^49321
+8 ;;56306^49322
+9 ;;56307^58661
+10 ;;56308^58550
+11 ;;56309^58551
+12 ;;56310^44200
+13 ;;56311^38570
+14 ;;56312^38571
+15 ;;56313^38572
+16 ;;56314^49323
+17 ;;56315^44970
+18 ;;56316^49650
+19 ;;56317^49651
+20 ;;56318^54690
+21 ;;56320^55550
+22 ;;56322^43651
+23 ;;56323^43652
+24 ;;56324^47570
+25 ;;56340^47562
+26 ;;56341^47563
+27 ;;56342^47564
+28 ;;56343^58673
+29 ;;56344^58672
+30 ;;56346^43653
+31 ;;56348^44202
+32 ;;56349^43280
+33 ;;56350^58555
+34 ;;56351^58558
+35 ;;56352^58559
+36 ;;56353^58560
+37 ;;56354^58561
+38 ;;56355^58562
+39 ;;56356^58563
+40 ;;56362^47560
+41 ;;56363^47561
+42 ;;64442^64475
+43 ;;64443^64476
+44 ;;80049^80048
+45 ;;80054^80053
+46 ;;80058^80076
+47 ;;80059^80074
+48 ;;
