| [613] | 1 | PRCACLN ;ALB/MAF; CLEAN UP OF EXTRANEOUS PRCA PACKAGE FILE ENTRIES; 12 MAY 1997
|
|---|
| 2 | ;;4.5;Accounts Receivable;**81**;Mar 20, 1995
|
|---|
| 3 | ;Check to see if there is a package labeled ACCOUNTS RECEIVABLE and
|
|---|
| 4 | ;to make sure there is not more than one package with the name of
|
|---|
| 5 | ;ACCOUNTS RECEIVABLE. If so the install will abort.
|
|---|
| 6 | ;This is the Environment Check routine portion of the code.
|
|---|
| 7 | N PRCAPKG,PRCANME,PRCAID,IBQUIT,PRCANODE
|
|---|
| 8 | F PRCAID=0:0 S PRCAID=$O(^DIC(9.4,"B","ACCOUNTS RECEIVABLE",PRCAID)) Q:PRCAID']""!($D(IBQUIT)) S PRCAPKG=PRCAID,PRCANODE=$G(^DIC(9.4,PRCAID,0)) I $O(^DIC(9.4,"B","ACCOUNTS RECEIVABLE",PRCAID)) D I IBQUIT Q
|
|---|
| 9 | .W !,"*** There is more than one ACCOUNTS RECEIVABLE entry in the package file"
|
|---|
| 10 | .W !," Please check your Package file and find the correct entry"
|
|---|
| 11 | .W !," and rename the other(s).",!
|
|---|
| 12 | .W !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
|
|---|
| 13 | .W !," and install the patch.",!
|
|---|
| 14 | .S (XPDQUIT,IBQUIT)=1
|
|---|
| 15 | .Q
|
|---|
| 16 | I $G(XPDQUIT) Q
|
|---|
| 17 | I '$D(PRCAPKG) D Q
|
|---|
| 18 | .W !,"*** There are no ACCOUNTS RECEIVABLE entries in the Package file"
|
|---|
| 19 | .W !," Please check your Package File to make sure you have an"
|
|---|
| 20 | .W !," entry named ACCOUNTS RECEIVABLE.",!
|
|---|
| 21 | .W !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
|
|---|
| 22 | .W !," and install the patch.",!
|
|---|
| 23 | .S XPDQUIT=1
|
|---|
| 24 | .Q
|
|---|
| 25 | I '$G(XPDQUIT) W !!,"Environment Check is OK!"
|
|---|
| 26 | Q
|
|---|
| 27 | EN ;Check the "C" cross ref for more than one ocurrence of the PRCA
|
|---|
| 28 | ;prefix. If only one nothing gets cleaned up.
|
|---|
| 29 | ;This is the cleanup routine portion of the code.
|
|---|
| 30 | N PRCAIFN,PRCAFL1,PRCAFL2,PRCAFL3,PRCABLK,PRCABLK1,PRCABLK2,PRCABLK3,PRCANODE,IBQUIT
|
|---|
| 31 | S $P(PRCABLK," ",15)="",$P(PRCABLK1," ",21)="",$P(PRCABLK2," ",5)=""
|
|---|
| 32 | N PRCANME,PRCAID
|
|---|
| 33 | F PRCAIFN=0:0 S PRCAIFN=$O(^DIC(9.4,"C","PRCA",PRCAIFN)) Q:PRCAIFN']"" D:'$D(PRCAFL1) MES Q:$D(PRCAFL2) D
|
|---|
| 34 | .I $P($G(^DIC(9.4,PRCAIFN,0)),"^",1)'="ACCOUNTS RECEIVABLE" D
|
|---|
| 35 | ..S DIE="^DIC(9.4,",DR="1////"_"PRCZ",DA=PRCAIFN D ^DIE K DIE,DR,DA
|
|---|
| 36 | .I '$D(PRCAFL3) D MES^XPDUTL("The prefix has been changed for the following entries in the Package File: ") D MES^XPDUTL("File IEN"_PRCABLK2_"Old Prefix"_PRCABLK_"New Prefix"_PRCABLK_"Package Name") S PRCAFL3=1
|
|---|
| 37 | .S X=13-$L(PRCAIFN),$P(PRCABLK3," ",X)="" D MES^XPDUTL(PRCAIFN_PRCABLK3_"PRCA"_PRCABLK1_$P($G(^DIC(9.4,PRCAIFN,0)),"^",2)_PRCABLK1_$P($G(^DIC(9.4,PRCAIFN,0)),"^",1))
|
|---|
| 38 | .Q
|
|---|
| 39 | Q
|
|---|
| 40 | MES S PRCAFL1=1 I $O(^DIC(9.4,"C","PRCA",PRCAIFN))']"" D MES^XPDUTL("*** Only one PRCA entry in Package file... no 'C' x-reference cleanup occurred!!") S PRCAFL2=1 Q ;Only one PRCA prefix--no cleanup
|
|---|
| 41 | Q
|
|---|
