IB20IN.m

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

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20IN   4044     printed  Mar 13, 2025@21:06:20                                                                                                                                                                                                      Page 2

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      ;