source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRA.m@ 891

Last change on this file since 891 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1IBCRHBRA ;ALB/ARH - RATES: UPLOAD RC V1 CPT 2000 CHARGES ; 10-OCT-2000
2 ;;2.0;INTEGRATED BILLING;**138,169**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; add CPT 2000 Replacement Codes to RC v1
6 ; these are new codes that directly replace codes that have been inactivated, the charges for the old code
7 ; can be used as the charge for the new code
8 ;
9CPT2000 ; add CPT replacement codes to RC charge sets, use the current charge of the CPT they are replacing
10 N IBI,IBLN,IBOLD,IBNEW,IBITM,IBCI,IBCIN,IBCS,IBCSN,IBCNT,IB2000DT,X,Y,DIC,IBENDDT S IBCNT=0
11 S IB2000DT=3000201
12 S IBENDDT=$$VERSEDT^IBCRHBRV(1)
13 ;
14 I '$D(ZTQUEUED) W !!,"Adding CPT 2000 Replacement Charges for RC v1 ... "
15 F IBI=1:1 S IBLN=$P($T(F2000+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D
16 . ;
17 . S IBOLD=$P(IBLN,U,1) I IBOLD'?5N Q
18 . S IBNEW=$P(IBLN,U,2) I IBNEW'?5N Q
19 . ;
20 . S IBITM=IBOLD_";ICPT(",IBCI=0 F S IBCI=$O(^IBA(363.2,"B",IBITM,IBCI)) Q:'IBCI D
21 .. ;
22 .. S IBCIN=$G(^IBA(363.2,+IBCI,0)) I $P(IBCIN,U,3)'=2990901,$P(IBCIN,U,3)'=2981001 Q
23 .. S IBCS=$P(IBCIN,U,2),IBCSN=$G(^IBE(363.1,+IBCS,0)) I '$$CSRC(IBCS) Q
24 .. ;
25 .. D DEL(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5))
26 .. I $$EXISTS(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5)) Q
27 .. ;
28 .. I $$ADDCI^IBCREF(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5),$P(IBCIN,U,6),$P(IBCIN,U,7),IBENDDT) S IBCNT=IBCNT+1
29 ;
30 I '$D(ZTQUEUED) W IBCNT," charges added."
31 Q
32 ;
33EXISTS(IBCS,IBITM,IBEFFDT,IBCHG) ; return ifn of charge item if this charge exists
34 N IBX,IBCI S IBX=0
35 I +$G(IBCS),+$G(IBITM),+$G(IBEFFDT),+$G(IBCHG) D
36 . S IBCI=0 F S IBCI=$O(^IBA(363.2,"AIVDTS"_IBCS,IBITM,-IBEFFDT,IBCI)) Q:'IBCI D Q:+IBX
37 .. I $P($G(^IBA(363.2,+IBCI,0)),U,5)=IBCHG S IBX=IBCI
38 Q IBX
39 ;
40DEL(IBCS,IBITM,IBEFFDT,IBCHG) ; delete any existing charges the site may have added to the charge sets for the New CPT replacement codes
41 ; the charge to be deleted must be effective before RC v1.1 and it must not be the correct replacement,
42 ; ie. delete any v1 charge for the item in a CS that does not match the date/charge passed in
43 N IBDT,IBCI,IBCIN,IBCNT,X,Y,DIC,DIK,DA S IBCNT=0 I '$G(IBEFFDT)!('$G(IBCHG)) Q
44 ;
45 S IBDT="" F S IBDT=$O(^IBA(363.2,"AIVDTS"_+$G(IBCS),+$G(IBITM),IBDT)) Q:IBDT="" D
46 . I -IBDT>3000701 Q
47 . ;
48 . S IBCI=0 F S IBCI=$O(^IBA(363.2,"AIVDTS"_IBCS,IBITM,IBDT,IBCI)) Q:'IBCI D
49 .. S IBCIN=$G(^IBA(363.2,+IBCI,0)) I -IBDT=IBEFFDT,IBCHG=$P(IBCIN,U,5) Q
50 .. ;
51 .. S DA=IBCI,DIK="^IBA(363.2," D ^DIK K DA,DIK S IBCNT=IBCNT+1
52 ;
53 Q
54 ;
55CSRC(IBCS) ; return true if the Charge Set is Reasonable Charges and CPT based
56 N IBX,IBCSN,IBBRN S IBX=0
57 I +$G(IBCS) S IBCSN=$G(^IBE(363.1,+IBCS,0))
58 I $G(IBCSN)'="" S IBBRN=$G(^IBE(363.3,+$P(IBCSN,U,2),0))
59 ;
60 I $G(IBBRN)'="",$E(IBBRN,1,3)="RC ",$P(IBBRN,U,4)=2 S IBX=1
61 ;
62 Q IBX
63 ;
64 ;
65F2000 ; old^new CPTs
66 ;;32001^32997
67 ;;56300^49320
68 ;;56301^58670
69 ;;56302^58671
70 ;;56303^58662
71 ;;56304^58660
72 ;;56305^49321
73 ;;56306^49322
74 ;;56307^58661
75 ;;56308^58550
76 ;;56309^58551
77 ;;56310^44200
78 ;;56311^38570
79 ;;56312^38571
80 ;;56313^38572
81 ;;56314^49323
82 ;;56315^44970
83 ;;56316^49650
84 ;;56317^49651
85 ;;56318^54690
86 ;;56320^55550
87 ;;56322^43651
88 ;;56323^43652
89 ;;56324^47570
90 ;;56340^47562
91 ;;56341^47563
92 ;;56342^47564
93 ;;56343^58673
94 ;;56344^58672
95 ;;56346^43653
96 ;;56348^44202
97 ;;56349^43280
98 ;;56350^58555
99 ;;56351^58558
100 ;;56352^58559
101 ;;56353^58560
102 ;;56354^58561
103 ;;56355^58562
104 ;;56356^58563
105 ;;56362^47560
106 ;;56363^47561
107 ;;64442^64475
108 ;;64443^64476
109 ;;80049^80048
110 ;;80054^80053
111 ;;80058^80076
112 ;;80059^80074
113 ;;
Note: See TracBrowser for help on using the repository browser.