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

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1IB20IN ;ALB/CPM - IB V2.0 INITIALIZATION ROUTINE ; 01-SEP-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;
4 ; Perform one-time installation items
5 I +$G(^DD(350,0,"VR"))<2 D
6 .D SC7H ; delete IB SCREEN7H input template
7 .D AVC ; delete 'AVC' x-ref
8 .D AVP ; delete 'AVP' x-ref
9 .D OBSLT ; delete obsolete list template
10 .D BCP ; delete obsolete print template
11 .D OBSPRO ; delete obsolete protocols
12 .D EDOPT ; change name of option IB UB-82 MENU
13 ;
14 ; Run at every installation
15 D DEL ; delete file #350.8 and data
16 D CHGPRO ; delete IBACM1 MENU protocol
17 D DD ; delete field decriptions and cross references
18 ;
19 Q
20 ;
21 ;
22SC7H W !!,">>> Removing IB SCREEN7H input template..."
23 S IBX=0 F S IBX=$O(^DIE("B","IB SCREEN7H",IBX)) Q:IBX<1 S DA=IBX,DIE="^DIE(",DR=".01////@" D ^DIE
24 K IBX
25 Q
26 ;
27AVC W !!,">>> Removing 'AVC' cross-reference on REVENUE CODE field... "
28 S DA=0
29 F S DA=$O(^DD(399.042,.01,1,DA)) Q:DA<1 I $G(^(DA,0))="399.042^AVC^MUMPS" S DIK="^DD(399.042,.01,1,",DA(2)=399.042,DA(1)=.01 W "." D ^DIK W "." K DIK
30 K DA
31 Q
32 ;
33AVP W !!,">>> Removing 'AVP' cross-reference on PROCEDURES field..."
34 S DA=0
35 F S DA=$O(^DD(399.0304,.01,1,DA)) Q:DA<1 I $G(^(DA,0))="399.0304^AVP^MUMPS" S DIK="^DD(399.0304,.01,1,",DA(2)=399.0304,DA(1)=.01 W "." D ^DIK W "." K DIK
36 K DA
37 Q
38 ;
39DEL W !!,">>> Deleting IB ERROR file (350.8) with data."
40 W !," It will be restored."
41 S DIU(0)="D",DIU="^IBE(350.8," D EN^DIU2 K DIU Q
42 Q
43 ;
44CHGPRO ; Delete the 'IBACM1 MENU' protocol (to be added later by IBONIT)
45 S DIC="^ORD(101,",DIC(0)="FN",X="IBACM1 MENU" D ^DIC K DIC S DA=+Y
46 I DA>0 W !!,">>> Deleting protocol 'IBACM1 MENU'...",!?4,"It will be restored." S DIK="^ORD(101," D ^DIK
47 K DA,DIK,X,Y
48 Q
49 ;
50OBSLT ; Delete the obsolete List Template 'IB BILLABLE EVENT'
51 S DA=$O(^SD(409.61,"B","IB BILLABLE EVENT",0))
52 I DA W !!,">>> Deleting Obsolete List Template 'IB BILLABLE EVENT'..." S DIK="^SD(409.61," D ^DIK
53 K DA,DIK
54 Q
55 ;
56BCP ; Delete obsolete print template 'IB BILLING CYCLE PRINT'
57 S DA=$O(^DIPT("B","IB BILLING CYCLE PRINT",0))
58 I DA W !!,">>> Deleting Obsolete Print Template 'IB BILLING CYCLE PRINT'..." S DIK="^DIPT(" D ^DIK
59 K DA,DIK
60 Q
61 ;
62OBSPRO ; Delete obsolete protocols.
63 W !!,">>> Deleting obsolete protocols..."
64 F IBI=1:1 S IBN=$P($T(OBSP+IBI),";;",2) Q:IBN="" D
65 .W !?5,"deleting protocol '",IBN,"'... "
66 .S DIC="^ORD(101,",DIC(0)="FN",X=IBN D ^DIC K DIC S DA=+Y
67 .I DA<0 W "not found." Q
68 .S DIK="^ORD(101," D ^DIK W "done."
69 K DA,DIK,IBI,IBN,X,Y
70 Q
71 ;
72EDOPT ; Change name of option IB UB-82 MENU to IB THIRD PARTY BILLING MENU
73 S DA=$O(^DIC(19,"B","IB UB-82 MENU",0))
74 I DA W !!,">>> Changing the option 'IB UB-82 MENU' to 'IB THIRD PARTY BILLING MENU'..." S DIE="^DIC(19,",DR=".01///IB THIRD PARTY BILLING MENU" D ^DIE
75 K DIE,DA,DR
76 Q
77 ;
78DD ; Delete field descriptions and cross references
79 K ^DD(399,.01,21),^DD(399,2,21),^DD(399,205,21),^DD(399,213,23),^DD(399,303,21)
80 ;
81 S IB=0 F S IB=$O(^DD(399.1,.11,1,IB)) Q:IB<1 S DIK="^DD(399.1,.11,1,",DA(2)=399.1,DA(1)=.11,DA=IB D ^DIK K DIK
82 S IB=0 F S IB=$O(^DD(399.1,.13,1,IB)) Q:IB<1 S DIK="^DD(399.1,.13,1,",DA(2)=399.1,DA(1)=.13,DA=IB D ^DIK K DIK
83 S IB=0 F S IB=$O(^DD(399.2,.01,1,IB)) Q:IB<1 S DIK="^DD(399.2,.01,1,",DA(2)=399.2,DA(1)=.01,DA=IB D ^DIK K DIK
84 ;
85 S IB=0 F S IB=$O(^DD(399.042,.02,1,IB)) Q:IB<1 S DIK="^DD(399.042,.02,1,",DA(2)=399.042,DA(1)=.02,DA=IB D ^DIK K DIK
86 S IB=0 F S IB=$O(^DD(399.042,.03,1,IB)) Q:IB<1 S DIK="^DD(399.042,.03,1,",DA(2)=399.042,DA(1)=.03,DA=IB D ^DIK K DIK
87 ;
88 K ^DGCR(399.1,"OCC"),^DGCR(399.1,"DIS"),^DGCR(399.2,"D")
89 ;
90 S DIK="^DD(399,101,1,",DA(2)=399,DA(1)=101,DA=3 D ^DIK
91 ;
92 K IB,DA,DIK
93 Q
94 ;
95OBSP ; Obsolete protocols to be deleted
96 ;;IBACM ENTRY SELECT
97 ;;IBACM MENU
98 ;;IBACM BLANK 1
99 ;;IBACM BLANK 10
100 ;;IBACM BLANK 11
101 ;;IBACM BLANK 12
102 ;;IBACM BLANK 2
103 ;;IBACM BLANK 3
104 ;;IBACM BLANK 4
105 ;;IBACM BLANK 5
106 ;;IBACM BLANK 6
107 ;;IBACM BLANK 7
108 ;;IBACM BLANK 8
109 ;;IBACM BLANK 9
110 ;
Note: See TracBrowser for help on using the repository browser.