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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1IBYPSA ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 ; 10-OCT-2003
2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6 Q
7 ;
8POST ;
9 N IBA
10 S IBA(1)="",IBA(2)=" Reasonable Charges v2.0 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
11 ;
12 D RSINDT ; add Rate Schedule Inactive dates (363, .06)
13 ;
14 D UPDBR ; update Billing Rate Names for v2.0 (363.3)
15 ;
16 D ADDRB^IBYPSA1 ; add Billable Service (399.1, .2)
17 D ADDBS^IBYPSA1 ; add Bedsections (399.1,.12)
18 D ADDBI^IBYPSA1 ; add Billable Items (363.21)
19 D ADDRS^IBYPSA1 ; add Rate Schedule (363)
20 D ADDBR^IBYPSA1 ; add Billing Rates (363.3)
21 ;
22 D SGBR ; add Billing Rates to Special Groups (363.32,11,.01)
23 D RVACT ; activate 3 Revenue Codes (399.2,2)
24 ;
25 D CHGINA^IBYPSA2("") ; inactivate all RC charges in #363.2
26 ;
27 S IBA(1)="",IBA(2)=" Reasonable Charges v2.0 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
28 ;
29 Q
30 ;
31 ;
32RSINDT ; add an inactive date to rate schedules if this is the first time the load is completed (363, .06)
33 ; Reimbursable Ins, No Fault, and Workers Comp only
34 ; if test account use 9/30/98, if production account use 8/31/99
35 N IBA,IBRSFN,IBRS0,IBRSN,IBCNT,IBSTDT,DD,DO,DIC,DIE,DA,DR,X,Y S IBSTDT="",IBCNT=0
36 ;
37 I $O(^IBE(363.3,"B","RC PHYSICIAN MN",0)) G RSINQ
38 ;
39 S IBSTDT=$$VERSEDT^IBCRHBRV(1.4) ;I '$$PROD^IBCORC S IBSTDT=2980930
40 ;
41 S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D
42 . S IBRS0=$G(^IBE(363,IBRSFN,0)),IBRSN=$E(IBRS0,1,3)
43 . I IBRSN'="RI-",IBRSN'="NF-",IBRSN'="WC-" Q
44 . I $P(IBRS0,U,5)'<IBSTDT Q
45 . I $P(IBRS0,U,6)'="" Q
46 . ;
47 . S IBCNT=IBCNT+1,DR=".06////"_IBSTDT,DIE="^IBE(363,",DA=+IBRSFN D ^DIE K DIE,DA,DR,X,Y
48 ;
49RSINQ S IBA(1)=" >> "_IBCNT_" Rate Schedules inactivated on "_$E(IBSTDT,4,5)_"/"_$E(IBSTDT,6,7)_"/"_$E(IBSTDT,2,3)_" (363)..."
50 D MES^XPDUTL(.IBA)
51 Q
52 ;
53UPDBR ; Update Billing Rate Names
54 N IBA,IBDA,IBCNT,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
55 ;
56 S DA=$O(^IBE(363.3,"B","RC OUTPATIENT FACILITY","")) I +DA D
57 . S DR=".01///RC FACILITY PR;.02///RC F/PR" S DIE="^IBE(363.3," D ^DIE K DIE,DA,DR,X,Y
58 . D MSG(" RC OUTPATIENT FACILITY to RC FACILITY PR") S IBCNT=IBCNT+1
59 ;
60 S DA=$O(^IBE(363.3,"B","RC PHYSICIAN","")) I +DA D
61 . S DR=".01///RC PHYSICIAN PR;.02///RC P/PR" S DIE="^IBE(363.3," D ^DIE K DIE,DA,DR,X,Y
62 . D MSG(" RC PHYSICIAN to RC PHYSICIAN PR") S IBCNT=IBCNT+1
63 ;
64 S IBA(1)=" >> "_IBCNT_" Billing Rate Names Updated (363.3)..."
65 D MES^XPDUTL(.IBA)
66 Q
67 ;
68SGBR ; add new Billing Rates to the Special Groups (363.32,11,.01)
69 N IBA,IBSET,IBSG,IBSGFN,IBBR,IBBRFN,IBCNT,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBBRNM S IBCNT=0
70 ;
71 F IBSET="STANDARD RVCD LINKS^RC FACILITY","STANDARD RVCD LINKS^RC PHYSICIAN","RC PROVIDER DISCOUNTS^RC PHYSICIAN" D
72 . S IBSG=$P(IBSET,U,1) Q:IBSG="" S IBSGFN=$O(^IBE(363.32,"B",IBSG,0)) Q:'IBSGFN
73 . S IBBR=$P(IBSET,U,2) Q:IBBR=""
74 . ;
75 . S IBBRNM=IBBR F S IBBRNM=$O(^IBE(363.3,"B",IBBRNM)) Q:IBBRNM'[IBBR D
76 .. ;
77 .. S IBBRFN=$O(^IBE(363.3,"B",IBBRNM,0)) Q:'IBBRFN
78 .. I +$P($G(^IBE(363.3,+IBBRFN,0)),U,4)'=2 Q ; cpt charges only
79 .. ;
80 .. I $O(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0)) Q
81 .. ;
82 .. S DLAYGO=363.32,DA(1)=+IBSGFN,DIC="^IBE(363.32,"_DA(1)_",11,",DIC(0)="L",X=IBBRNM,DIC("P")="363.3211PA" D ^DIC K DIC,DIE S IBCNT=IBCNT+1
83 ;
84SGBRQ S IBA(1)=" >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."
85 D MES^XPDUTL(.IBA)
86 Q
87 ;
88RVACT ; activate (3) Revenue Codes exported in as defaults for new Charge Sets (399.2,2)
89 N IBA,IBLN,IBI,IBRVFN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBACT=""
90 ;
91 S IBLN=$P($T(RVF+1),";;",2)
92 ;
93 F IBI=1:1 S IBRVFN=$P(IBLN,",",IBI) Q:'IBRVFN D
94 . ;
95 . I +$P($G(^DGCR(399.2,IBRVFN,0)),U,3) Q
96 . ;
97 . S IBACT=IBACT_IBRVFN_","
98 . S IBCNT=IBCNT+1,DR="2////1",DIE="^DGCR(399.2,",DA=+IBRVFN D ^DIE K DIE,DA,DR,X,Y
99 ;
100 I IBCNT>0 S IBJ=0 F IBI=1:15 S IBJ=IBJ+15 S IBLN=$P(IBACT,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
101 ;
102RVAQ S IBA(1)=" >> "_IBCNT_" Revenue Codes activated (399.2)..."
103 D MES^XPDUTL(.IBA)
104 Q
105 ;
106MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
107 N IBX,IBY S IBY=""
108 I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
109 Q IBY
110 ;
111MSG(X) ;
112 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
113 S IBA(IBX)=$G(X)
114 Q
115 ;
116RVF ; Revenue Codes to (3) Activate (399.2,2)
117 ;;190,200,912,
118 ;;
Note: See TracBrowser for help on using the repository browser.