- PRCACLN ;ALB/MAF; CLEAN UP OF EXTRANEOUS PRCA PACKAGE FILE ENTRIES; 12 MAY 1997
- ;;4.5;Accounts Receivable;**81**;Mar 20, 1995
- ;Check to see if there is a package labeled ACCOUNTS RECEIVABLE and
- ;to make sure there is not more than one package with the name of
- ;ACCOUNTS RECEIVABLE. If so the install will abort.
- ;This is the Environment Check routine portion of the code.
- N PRCAPKG,PRCANME,PRCAID,IBQUIT,PRCANODE
- 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
- .W !,"*** There is more than one ACCOUNTS RECEIVABLE entry in the package file"
- .W !," Please check your Package file and find the correct entry"
- .W !," and rename the other(s).",!
- .W !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
- .W !," and install the patch.",!
- .S (XPDQUIT,IBQUIT)=1
- .Q
- I $G(XPDQUIT) Q
- I '$D(PRCAPKG) D Q
- .W !,"*** There are no ACCOUNTS RECEIVABLE entries in the Package file"
- .W !," Please check your Package File to make sure you have an"
- .W !," entry named ACCOUNTS RECEIVABLE.",!
- .W !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
- .W !," and install the patch.",!
- .S XPDQUIT=1
- .Q
- I '$G(XPDQUIT) W !!,"Environment Check is OK!"
- Q
- EN ;Check the "C" cross ref for more than one ocurrence of the PRCA
- ;prefix. If only one nothing gets cleaned up.
- ;This is the cleanup routine portion of the code.
- N PRCAIFN,PRCAFL1,PRCAFL2,PRCAFL3,PRCABLK,PRCABLK1,PRCABLK2,PRCABLK3,PRCANODE,IBQUIT
- S $P(PRCABLK," ",15)="",$P(PRCABLK1," ",21)="",$P(PRCABLK2," ",5)=""
- N PRCANME,PRCAID
- F PRCAIFN=0:0 S PRCAIFN=$O(^DIC(9.4,"C","PRCA",PRCAIFN)) Q:PRCAIFN']"" D:'$D(PRCAFL1) MES Q:$D(PRCAFL2) D
- .I $P($G(^DIC(9.4,PRCAIFN,0)),"^",1)'="ACCOUNTS RECEIVABLE" D
- ..S DIE="^DIC(9.4,",DR="1////"_"PRCZ",DA=PRCAIFN D ^DIE K DIE,DR,DA
- .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
- .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))
- .Q
- Q
- 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCACLN 2601 printed Feb 18, 2025@23:05:36 Page 2
- PRCACLN ;ALB/MAF; CLEAN UP OF EXTRANEOUS PRCA PACKAGE FILE ENTRIES; 12 MAY 1997
- +1 ;;4.5;Accounts Receivable;**81**;Mar 20, 1995
- +2 ;Check to see if there is a package labeled ACCOUNTS RECEIVABLE and
- +3 ;to make sure there is not more than one package with the name of
- +4 ;ACCOUNTS RECEIVABLE. If so the install will abort.
- +5 ;This is the Environment Check routine portion of the code.
- +6 NEW PRCAPKG,PRCANME,PRCAID,IBQUIT,PRCANODE
- +7 FOR PRCAID=0:0
- SET PRCAID=$ORDER(^DIC(9.4,"B","ACCOUNTS RECEIVABLE",PRCAID))
- if PRCAID']""!($DATA(IBQUIT))
- QUIT
- SET PRCAPKG=PRCAID
- SET PRCANODE=$GET(^DIC(9.4,PRCAID,0))
- IF $ORDER(^DIC(9.4,"B","ACCOUNTS RECEIVABLE",PRCAID))
- Begin DoDot:1
- +8 WRITE !,"*** There is more than one ACCOUNTS RECEIVABLE entry in the package file"
- +9 WRITE !," Please check your Package file and find the correct entry"
- +10 WRITE !," and rename the other(s).",!
- +11 WRITE !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
- +12 WRITE !," and install the patch.",!
- +13 SET (XPDQUIT,IBQUIT)=1
- +14 QUIT
- End DoDot:1
- IF IBQUIT
- QUIT
- +15 IF $GET(XPDQUIT)
- QUIT
- +16 IF '$DATA(PRCAPKG)
- Begin DoDot:1
- +17 WRITE !,"*** There are no ACCOUNTS RECEIVABLE entries in the Package file"
- +18 WRITE !," Please check your Package File to make sure you have an"
- +19 WRITE !," entry named ACCOUNTS RECEIVABLE.",!
- +20 WRITE !,"*** Once this has been done, re-install pacman using INSTALL/CHECK MESSAGE"
- +21 WRITE !," and install the patch.",!
- +22 SET XPDQUIT=1
- +23 QUIT
- End DoDot:1
- QUIT
- +24 IF '$GET(XPDQUIT)
- WRITE !!,"Environment Check is OK!"
- +25 QUIT
- EN ;Check the "C" cross ref for more than one ocurrence of the PRCA
- +1 ;prefix. If only one nothing gets cleaned up.
- +2 ;This is the cleanup routine portion of the code.
- +3 NEW PRCAIFN,PRCAFL1,PRCAFL2,PRCAFL3,PRCABLK,PRCABLK1,PRCABLK2,PRCABLK3,PRCANODE,IBQUIT
- +4 SET $PIECE(PRCABLK," ",15)=""
- SET $PIECE(PRCABLK1," ",21)=""
- SET $PIECE(PRCABLK2," ",5)=""
- +5 NEW PRCANME,PRCAID
- +6 FOR PRCAIFN=0:0
- SET PRCAIFN=$ORDER(^DIC(9.4,"C","PRCA",PRCAIFN))
- if PRCAIFN']""
- QUIT
- if '$DATA(PRCAFL1)
- DO MES
- if $DATA(PRCAFL2)
- QUIT
- Begin DoDot:1
- +7 IF $PIECE($GET(^DIC(9.4,PRCAIFN,0)),"^",1)'="ACCOUNTS RECEIVABLE"
- Begin DoDot:2
- +8 SET DIE="^DIC(9.4,"
- SET DR="1////"_"PRCZ"
- SET DA=PRCAIFN
- DO ^DIE
- KILL DIE,DR,DA
- End DoDot:2
- +9 IF '$DATA(PRCAFL3)
- DO MES^XPDUTL("The prefix has been changed for the following entries in the Package File: ")
- DO MES^XPDUTL("File IEN"_PRCABLK2_"Old Prefix"_PRCABLK_"New Prefix"_PRCABLK_"Package Name")
- SET PRCAFL3=1
- +10 SET X=13-$LENGTH(PRCAIFN)
- SET $PIECE(PRCABLK3," ",X)=""
- DO MES^XPDUTL(PRCAIFN_PRCABLK3_"PRCA"_PRCABLK1_$PIECE($GET(^DIC(9.4,PRCAIFN,0)),"^",2)_PRCABLK1_$PIECE($GET(^DIC(9.4,PRCAIFN,0)),"^",1))
- +11 QUIT
- End DoDot:1
- +12 QUIT
- MES ;Only one PRCA prefix--no cleanup
- SET PRCAFL1=1
- IF $ORDER(^DIC(9.4,"C","PRCA",PRCAIFN))']""
- DO MES^XPDUTL("*** Only one PRCA entry in Package file... no 'C' x-reference cleanup occurred!!")
- SET PRCAFL2=1
- QUIT
- +1 QUIT
