IB20IN ;ALB/CPM - IB V2.0 INITIALIZATION ROUTINE ; 01-SEP-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
; Perform one-time installation items
I +$G(^DD(350,0,"VR"))<2 D
.D SC7H ; delete IB SCREEN7H input template
.D AVC ; delete 'AVC' x-ref
.D AVP ; delete 'AVP' x-ref
.D OBSLT ; delete obsolete list template
.D BCP ; delete obsolete print template
.D OBSPRO ; delete obsolete protocols
.D EDOPT ; change name of option IB UB-82 MENU
;
; Run at every installation
D DEL ; delete file #350.8 and data
D CHGPRO ; delete IBACM1 MENU protocol
D DD ; delete field decriptions and cross references
;
Q
;
;
SC7H W !!,">>> Removing IB SCREEN7H input template..."
S IBX=0 F S IBX=$O(^DIE("B","IB SCREEN7H",IBX)) Q:IBX<1 S DA=IBX,DIE="^DIE(",DR=".01////@" D ^DIE
K IBX
Q
;
AVC W !!,">>> Removing 'AVC' cross-reference on REVENUE CODE field... "
S DA=0
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
K DA
Q
;
AVP W !!,">>> Removing 'AVP' cross-reference on PROCEDURES field..."
S DA=0
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
K DA
Q
;
DEL W !!,">>> Deleting IB ERROR file (350.8) with data."
W !," It will be restored."
S DIU(0)="D",DIU="^IBE(350.8," D EN^DIU2 K DIU Q
Q
;
CHGPRO ; Delete the 'IBACM1 MENU' protocol (to be added later by IBONIT)
S DIC="^ORD(101,",DIC(0)="FN",X="IBACM1 MENU" D ^DIC K DIC S DA=+Y
I DA>0 W !!,">>> Deleting protocol 'IBACM1 MENU'...",!?4,"It will be restored." S DIK="^ORD(101," D ^DIK
K DA,DIK,X,Y
Q
;
OBSLT ; Delete the obsolete List Template 'IB BILLABLE EVENT'
S DA=$O(^SD(409.61,"B","IB BILLABLE EVENT",0))
I DA W !!,">>> Deleting Obsolete List Template 'IB BILLABLE EVENT'..." S DIK="^SD(409.61," D ^DIK
K DA,DIK
Q
;
BCP ; Delete obsolete print template 'IB BILLING CYCLE PRINT'
S DA=$O(^DIPT("B","IB BILLING CYCLE PRINT",0))
I DA W !!,">>> Deleting Obsolete Print Template 'IB BILLING CYCLE PRINT'..." S DIK="^DIPT(" D ^DIK
K DA,DIK
Q
;
OBSPRO ; Delete obsolete protocols.
W !!,">>> Deleting obsolete protocols..."
F IBI=1:1 S IBN=$P($T(OBSP+IBI),";;",2) Q:IBN="" D
.W !?5,"deleting protocol '",IBN,"'... "
.S DIC="^ORD(101,",DIC(0)="FN",X=IBN D ^DIC K DIC S DA=+Y
.I DA<0 W "not found." Q
.S DIK="^ORD(101," D ^DIK W "done."
K DA,DIK,IBI,IBN,X,Y
Q
;
EDOPT ; Change name of option IB UB-82 MENU to IB THIRD PARTY BILLING MENU
S DA=$O(^DIC(19,"B","IB UB-82 MENU",0))
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
K DIE,DA,DR
Q
;
DD ; Delete field descriptions and cross references
K ^DD(399,.01,21),^DD(399,2,21),^DD(399,205,21),^DD(399,213,23),^DD(399,303,21)
;
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
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
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
;
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
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
;
K ^DGCR(399.1,"OCC"),^DGCR(399.1,"DIS"),^DGCR(399.2,"D")
;
S DIK="^DD(399,101,1,",DA(2)=399,DA(1)=101,DA=3 D ^DIK
;
K IB,DA,DIK
Q
;
OBSP ; Obsolete protocols to be deleted
;;IBACM ENTRY SELECT
;;IBACM MENU
;;IBACM BLANK 1
;;IBACM BLANK 10
;;IBACM BLANK 11
;;IBACM BLANK 12
;;IBACM BLANK 2
;;IBACM BLANK 3
;;IBACM BLANK 4
;;IBACM BLANK 5
;;IBACM BLANK 6
;;IBACM BLANK 7
;;IBACM BLANK 8
;;IBACM BLANK 9
;
IB20IN ;ALB/CPM - IB V2.0 INITIALIZATION ROUTINE ; 01-SEP-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ; Perform one-time installation items
+4 IF +$GET(^DD(350,0,"VR"))<2
Begin DoDot:1
+5 ; delete IB SCREEN7H input template
DO SC7H
+6 ; delete 'AVC' x-ref
DO AVC
+7 ; delete 'AVP' x-ref
DO AVP
+8 ; delete obsolete list template
DO OBSLT
+9 ; delete obsolete print template
DO BCP
+10 ; delete obsolete protocols
DO OBSPRO
+11 ; change name of option IB UB-82 MENU
DO EDOPT
End DoDot:1
+12 ;
+13 ; Run at every installation
+14 ; delete file #350.8 and data
DO DEL
+15 ; delete IBACM1 MENU protocol
DO CHGPRO
+16 ; delete field decriptions and cross references
DO DD
+17 ;
+18 QUIT
+19 ;
+20 ;
SC7H WRITE !!,">>> Removing IB SCREEN7H input template..."
+1 SET IBX=0
FOR
SET IBX=$ORDER(^DIE("B","IB SCREEN7H",IBX))
IF IBX<1
QUIT
SET DA=IBX
SET DIE="^DIE("
SET DR=".01////@"
DO ^DIE
+2 KILL IBX
+3 QUIT
+4 ;
AVC WRITE !!,">>> Removing 'AVC' cross-reference on REVENUE CODE field... "
+1 SET DA=0
+2 FOR
SET DA=$ORDER(^DD(399.042,.01,1,DA))
IF DA<1
QUIT
IF $GET(^(DA,0))="399.042^AVC^MUMPS"
SET DIK="^DD(399.042,.01,1,"
SET DA(2)=399.042
SET DA(1)=.01
WRITE "."
DO ^DIK
WRITE "."
KILL DIK
+3 KILL DA
+4 QUIT
+5 ;
AVP WRITE !!,">>> Removing 'AVP' cross-reference on PROCEDURES field..."
+1 SET DA=0
+2 FOR
SET DA=$ORDER(^DD(399.0304,.01,1,DA))
IF DA<1
QUIT
IF $GET(^(DA,0))="399.0304^AVP^MUMPS"
SET DIK="^DD(399.0304,.01,1,"
SET DA(2)=399.0304
SET DA(1)=.01
WRITE "."
DO ^DIK
WRITE "."
KILL DIK
+3 KILL DA
+4 QUIT
+5 ;
DEL WRITE !!,">>> Deleting IB ERROR file (350.8) with data."
+1 WRITE !," It will be restored."
+2 SET DIU(0)="D"
SET DIU="^IBE(350.8,"
DO EN^DIU2
KILL DIU
QUIT
+3 QUIT
+4 ;
CHGPRO ; Delete the 'IBACM1 MENU' protocol (to be added later by IBONIT)
+1 SET DIC="^ORD(101,"
SET DIC(0)="FN"
SET X="IBACM1 MENU"
DO ^DIC
KILL DIC
SET DA=+Y
+2 IF DA>0
WRITE !!,">>> Deleting protocol 'IBACM1 MENU'...",!?4,"It will be restored."
SET DIK="^ORD(101,"
DO ^DIK
+3 KILL DA,DIK,X,Y
+4 QUIT
+5 ;
OBSLT ; Delete the obsolete List Template 'IB BILLABLE EVENT'
+1 SET DA=$ORDER(^SD(409.61,"B","IB BILLABLE EVENT",0))
+2 IF DA
WRITE !!,">>> Deleting Obsolete List Template 'IB BILLABLE EVENT'..."
SET DIK="^SD(409.61,"
DO ^DIK
+3 KILL DA,DIK
+4 QUIT
+5 ;
BCP ; Delete obsolete print template 'IB BILLING CYCLE PRINT'
+1 SET DA=$ORDER(^DIPT("B","IB BILLING CYCLE PRINT",0))
+2 IF DA
WRITE !!,">>> Deleting Obsolete Print Template 'IB BILLING CYCLE PRINT'..."
SET DIK="^DIPT("
DO ^DIK
+3 KILL DA,DIK
+4 QUIT
+5 ;
OBSPRO ; Delete obsolete protocols.
+1 WRITE !!,">>> Deleting obsolete protocols..."
+2 FOR IBI=1:1
SET IBN=$PIECE($TEXT(OBSP+IBI),";;",2)
IF IBN=""
QUIT
Begin DoDot:1
+3 WRITE !?5,"deleting protocol '",IBN,"'... "
+4 SET DIC="^ORD(101,"
SET DIC(0)="FN"
SET X=IBN
DO ^DIC
KILL DIC
SET DA=+Y
+5 IF DA<0
WRITE "not found."
QUIT
+6 SET DIK="^ORD(101,"
DO ^DIK
WRITE "done."
End DoDot:1
+7 KILL DA,DIK,IBI,IBN,X,Y
+8 QUIT
+9 ;
EDOPT ; Change name of option IB UB-82 MENU to IB THIRD PARTY BILLING MENU
+1 SET DA=$ORDER(^DIC(19,"B","IB UB-82 MENU",0))
+2 IF DA
WRITE !!,">>> Changing the option 'IB UB-82 MENU' to 'IB THIRD PARTY BILLING MENU'..."
SET DIE="^DIC(19,"
SET DR=".01///IB THIRD PARTY BILLING MENU"
DO ^DIE
+3 KILL DIE,DA,DR
+4 QUIT
+5 ;
DD ; Delete field descriptions and cross references
+1 KILL ^DD(399,.01,21),^DD(399,2,21),^DD(399,205,21),^DD(399,213,23),^DD(399,303,21)
+2 ;
+3 SET IB=0
FOR
SET IB=$ORDER(^DD(399.1,.11,1,IB))
IF IB<1
QUIT
SET DIK="^DD(399.1,.11,1,"
SET DA(2)=399.1
SET DA(1)=.11
SET DA=IB
DO ^DIK
KILL DIK
+4 SET IB=0
FOR
SET IB=$ORDER(^DD(399.1,.13,1,IB))
IF IB<1
QUIT
SET DIK="^DD(399.1,.13,1,"
SET DA(2)=399.1
SET DA(1)=.13
SET DA=IB
DO ^DIK
KILL DIK
+5 SET IB=0
FOR
SET IB=$ORDER(^DD(399.2,.01,1,IB))
IF IB<1
QUIT
SET DIK="^DD(399.2,.01,1,"
SET DA(2)=399.2
SET DA(1)=.01
SET DA=IB
DO ^DIK
KILL DIK
+6 ;
+7 SET IB=0
FOR
SET IB=$ORDER(^DD(399.042,.02,1,IB))
IF IB<1
QUIT
SET DIK="^DD(399.042,.02,1,"
SET DA(2)=399.042
SET DA(1)=.02
SET DA=IB
DO ^DIK
KILL DIK
+8 SET IB=0
FOR
SET IB=$ORDER(^DD(399.042,.03,1,IB))
IF IB<1
QUIT
SET DIK="^DD(399.042,.03,1,"
SET DA(2)=399.042
SET DA(1)=.03
SET DA=IB
DO ^DIK
KILL DIK
+9 ;
+10 KILL ^DGCR(399.1,"OCC"),^DGCR(399.1,"DIS"),^DGCR(399.2,"D")
+11 ;
+12 SET DIK="^DD(399,101,1,"
SET DA(2)=399
SET DA(1)=101
SET DA=3
DO ^DIK
+13 ;
+14 KILL IB,DA,DIK
+15 QUIT
+16 ;
OBSP ; Obsolete protocols to be deleted
+1 ;;IBACM ENTRY SELECT
+2 ;;IBACM MENU
+3 ;;IBACM BLANK 1
+4 ;;IBACM BLANK 10
+5 ;;IBACM BLANK 11
+6 ;;IBACM BLANK 12
+7 ;;IBACM BLANK 2
+8 ;;IBACM BLANK 3
+9 ;;IBACM BLANK 4
+10 ;;IBACM BLANK 5
+11 ;;IBACM BLANK 6
+12 ;;IBACM BLANK 7
+13 ;;IBACM BLANK 8
+14 ;;IBACM BLANK 9
+15 ;
