- 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 Apr 23, 2025@18:33:53 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 ;;
