AUBPI.m

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