source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACLN.m

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

initial load of FOIAVistA 6/30/08 version

File size: 2.5 KB
Line 
1PRCACLN ;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
27EN ;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
40MES 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
Note: See TracBrowser for help on using the repository browser.