AUBPI ;EDE/OHPD/TUCSON BUILD PACKAGE PRE-INIT ROUTINE [ 03/15/89 3:15 PM ]
;
W !!,"This routine will build a pre-init routine for the specified package."
W !,"The pre-init routine will call %AUKD to delete the FileMan dictionaries"
W !,"being created by the package. Data globals and templates will be saved.",!!
F AUBPLOOP=0:0 D PACKAGE Q:Y<0 D BUILD
K %,AUBPLOOP
Q
;
PACKAGE ;
S DIC="^DIC(9.4,",DIC(0)="AEMQ" D ^DIC K DIC
Q
;
BUILD ;
S AUBPDFN=+Y
S AUBPPRFX=$P(^DIC(9.4,AUBPDFN,0),U,2)
S AUBPVER=^DIC(9.4,AUBPDFN,"VERSION") ;IHS/MFD ADDED VERSION SET
S AUBPPGM=AUBPPRFX_"PREI"
D CHECKRTN
I AUBPFLG D EOJ3 W !!,"Bye",! Q
K ^UTILITY("AUBPI",$J),^UTILITY("AUBPPGM",$J),^UTILITY("AUBPI EXEC",$J)
W "."
S (AUBPX,AUBPFLE)=0 F AUBPL=0:0 S AUBPFLE=$O(^DIC(9.4,AUBPDFN,4,"B",AUBPFLE)) Q:AUBPFLE'=+AUBPFLE S ^UTILITY("AUBPI",$J,AUBPFLE)=""
W "."
S AUBPFLG=0,AUBPFLE="" F AUBPL=0:0 S AUBPFLE=$O(^UTILITY("AUBPI",$J,AUBPFLE)) Q:AUBPFLE'=+AUBPFLE I '$D(^DIC(AUBPFLE)) S AUBPFLG=1 W !,AUBPFLE," does not exist in ^DIC!"
I AUBPFLG W !!,"All files in package must exist. Fix and rerun.",!! D EOJ Q
W "."
S AUBPFLE="" F AUBPL=0:0 S AUBPFLE=$O(^UTILITY("AUBPI",$J,AUBPFLE)) Q:AUBPFLE'=+AUBPFLE S ^(AUBPFLE)="^UTILITY(""AUDSET"",$J,"_AUBPFLE_")=S^S"
W "."
S %DT="",X="T" D ^%DT X ^DD("DD")
S ^UTILITY("AUBPPGM",$J,1)=AUBPPGM_" ;CREATED BY AUBPI ON "_Y
S ^UTILITY("AUBPPGM",$J,2)=" ;"_AUBPVER ;IHS/MFD ADDED LINE
F AUBPI=1:1:3 S ^UTILITY("AUBPPGM",$J,AUBPI+2)=$P($T(DTA+AUBPI),";;",2,99)
S AUBPFLE=0 F AUBPI=6:1 S AUBPFLE=$O(^UTILITY("AUBPI",$J,AUBPFLE)) Q:AUBPFLE'=+AUBPFLE S AUBPY=^(AUBPFLE),^UTILITY("AUBPPGM",$J,AUBPI)=" ;;"_AUBPY
S ^UTILITY("AUBPI EXEC",$J)="S AUBPP="""_AUBPPGM_""",AUBPY=0 ZR X ""F AUBPL=0:0 S AUBPY=$O(^UTILITY(""""AUBPPGM"""",$J,AUBPY)) Q:AUBPY'=+AUBPY ZI ^(AUBPY)"" ZS @AUBPP"
X ^UTILITY("AUBPI EXEC",$J)
D EOJ
Q
;
CHECKRTN ;
S AUBPFLG=0
Q:'$D(^DD("OS"))#2
Q:'$D(^DD("OS",^DD("OS"),18))#2
S X=AUBPPGM X ^(18)
E Q
CR2 W !!,AUBPPGM," already exists. Want to recreate it (Y/N) Y//" D YN^DICN
S:$E(%Y)="N" AUBPFLG=1
Q
;
EOJ ;
W !!,"Routine ",AUBPPGM," has been filed.",!!
I '$D(^DIC(9.4,AUBPDFN,"PRE")) D EOJ2
I $D(^DIC(9.4,AUBPDFN,"PRE")),^("PRE")="" D EOJ2
E I $D(^DIC(9.4,AUBPDFN,"PRE")),^("PRE")'=AUBPPGM W !!,"Package ",AUBPPRFX," has a pre-initialization routine entry but it is ",^("PRE"),"!"
D EOJ3
Q
EOJ2 ;
W !,"Package ",AUBPPRFX," has no pre-initialization routine entry!",!
Q
EOJ3 ;
K ^UTILITY("AUBPI",$J),^UTILITY("AUBPPGM",$J),^UTILITY("AUBPI EXEC",$J)
K %,%DT
K AUBPDFN,AUBPFLE,AUBPFLG,AUBPI,AUBPL,AUBPP,AUBPPGM,AUBPPRFX,AUBPX,AUBPY
Q
;
DTA ;
;; K ^UTILITY("AUDSET",$J) F AUBPI=1:1 S AUBPIX=$P($T(Q+AUBPI),";;",2) Q:AUBPIX="" S AUBPIY=$P(AUBPIX,"=",2,99),AUBPIX=$P(AUBPIX,"=",1) S @AUBPIX=AUBPIY
;; K AUBPI,AUBPIX,AUBPIY D EN2^%AUKD
;;Q Q
AUBPI ;EDE/OHPD/TUCSON BUILD PACKAGE PRE-INIT ROUTINE [ 03/15/89 3:15 PM ]
+1 ;
+2 WRITE !!,"This routine will build a pre-init routine for the specified package."
+3 WRITE !,"The pre-init routine will call %AUKD to delete the FileMan dictionaries"
+4 WRITE !,"being created by the package. Data globals and templates will be saved.",!!
+5 FOR AUBPLOOP=0:0
DO PACKAGE
IF Y<0
QUIT
DO BUILD
+6 KILL %,AUBPLOOP
+7 QUIT
+8 ;
PACKAGE ;
+1 SET DIC="^DIC(9.4,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 QUIT
+3 ;
BUILD ;
+1 SET AUBPDFN=+Y
+2 SET AUBPPRFX=$PIECE(^DIC(9.4,AUBPDFN,0),U,2)
+3 ;IHS/MFD ADDED VERSION SET
SET AUBPVER=^DIC(9.4,AUBPDFN,"VERSION")
+4 SET AUBPPGM=AUBPPRFX_"PREI"
+5 DO CHECKRTN
+6 IF AUBPFLG
DO EOJ3
WRITE !!,"Bye",!
QUIT
+7 KILL ^UTILITY("AUBPI",$JOB),^UTILITY("AUBPPGM",$JOB),^UTILITY("AUBPI EXEC",$JOB)
+8 WRITE "."
+9 SET (AUBPX,AUBPFLE)=0
FOR AUBPL=0:0
SET AUBPFLE=$ORDER(^DIC(9.4,AUBPDFN,4,"B",AUBPFLE))
IF AUBPFLE'=+AUBPFLE
QUIT
SET ^UTILITY("AUBPI",$JOB,AUBPFLE)=""
+10 WRITE "."
+11 SET AUBPFLG=0
SET AUBPFLE=""
FOR AUBPL=0:0
SET AUBPFLE=$ORDER(^UTILITY("AUBPI",$JOB,AUBPFLE))
IF AUBPFLE'=+AUBPFLE
QUIT
IF '$DATA(^DIC(AUBPFLE))
SET AUBPFLG=1
WRITE !,AUBPFLE," does not exist in ^DIC!"
+12 IF AUBPFLG
WRITE !!,"All files in package must exist. Fix and rerun.",!!
DO EOJ
QUIT
+13 WRITE "."
+14 SET AUBPFLE=""
FOR AUBPL=0:0
SET AUBPFLE=$ORDER(^UTILITY("AUBPI",$JOB,AUBPFLE))
IF AUBPFLE'=+AUBPFLE
QUIT
SET ^(AUBPFLE)="^UTILITY(""AUDSET"",$J,"_AUBPFLE_")=S^S"
+15 WRITE "."
+16 SET %DT=""
SET X="T"
DO ^%DT
XECUTE ^DD("DD")
+17 SET ^UTILITY("AUBPPGM",$JOB,1)=AUBPPGM_" ;CREATED BY AUBPI ON "_Y
+18 ;IHS/MFD ADDED LINE
SET ^UTILITY("AUBPPGM",$JOB,2)=" ;"_AUBPVER
+19 FOR AUBPI=1:1:3
SET ^UTILITY("AUBPPGM",$JOB,AUBPI+2)=$PIECE($TEXT(DTA+AUBPI),";;",2,99)
+20 SET AUBPFLE=0
FOR AUBPI=6:1
SET AUBPFLE=$ORDER(^UTILITY("AUBPI",$JOB,AUBPFLE))
IF AUBPFLE'=+AUBPFLE
QUIT
SET AUBPY=^(AUBPFLE)
SET ^UTILITY("AUBPPGM",$JOB,AUBPI)=" ;;"_AUBPY
+21 SET ^UTILITY("AUBPI EXEC",$JOB)="S AUBPP="""_AUBPPGM_""",AUBPY=0 ZR X ""F AUBPL=0:0 S AUBPY=$O(^UTILITY(""""AUBPPGM"""",$J,AUBPY)) Q:AUBPY'=+AUBPY ZI ^(AUBPY)"" ZS @AUBPP"
+22 XECUTE ^UTILITY("AUBPI EXEC",$JOB)
+23 DO EOJ
+24 QUIT
+25 ;
CHECKRTN ;
+1 SET AUBPFLG=0
+2 IF '$DATA(^DD("OS"))#2
QUIT
+3 IF '$DATA(^DD("OS",^DD("OS"),18))#2
QUIT
+4 SET X=AUBPPGM
XECUTE ^(18)
+5 IF '$TEST
QUIT
CR2 WRITE !!,AUBPPGM," already exists. Want to recreate it (Y/N) Y//"
DO YN^DICN
+1 IF $EXTRACT(%Y)="N"
SET AUBPFLG=1
+2 QUIT
+3 ;
EOJ ;
+1 WRITE !!,"Routine ",AUBPPGM," has been filed.",!!
+2 IF '$DATA(^DIC(9.4,AUBPDFN,"PRE"))
DO EOJ2
+3 IF $DATA(^DIC(9.4,AUBPDFN,"PRE"))
IF ^("PRE")=""
DO EOJ2
+4 IF '$TEST
IF $DATA(^DIC(9.4,AUBPDFN,"PRE"))
IF ^("PRE")'=AUBPPGM
WRITE !!,"Package ",AUBPPRFX," has a pre-initialization routine entry but it is ",^("PRE"),"!"
+5 DO EOJ3
+6 QUIT
EOJ2 ;
+1 WRITE !,"Package ",AUBPPRFX," has no pre-initialization routine entry!",!
+2 QUIT
EOJ3 ;
+1 KILL ^UTILITY("AUBPI",$JOB),^UTILITY("AUBPPGM",$JOB),^UTILITY("AUBPI EXEC",$JOB)
+2 KILL %,%DT
+3 KILL AUBPDFN,AUBPFLE,AUBPFLG,AUBPI,AUBPL,AUBPP,AUBPPGM,AUBPPRFX,AUBPX,AUBPY
+4 QUIT
+5 ;
DTA ;
+1 ;; K ^UTILITY("AUDSET",$J) F AUBPI=1:1 S AUBPIX=$P($T(Q+AUBPI),";;",2) Q:AUBPIX="" S AUBPIY=$P(AUBPIX,"=",2,99),AUBPIX=$P(AUBPIX,"=",1) S @AUBPIX=AUBPIY
+2 ;; K AUBPI,AUBPIX,AUBPIY D EN2^%AUKD
+3 ;;Q Q
