XBBPI ; IHS/ADC/GTH - BUILD PACKAGE PRE-INIT ROUTINE ; [ 02/07/97 3:02 PM ]
;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
;
; This routine builds a pre-init routine for a specified
; package. The pre-init routine will delete FileMan
; dictionaries being created by the package. Data
; globals and templates will be saved.
;
START ;
D ^XBKVAR
W !!,"This routine will build a pre-init routine for the specified package."
W !,"The pre-init routine will call XBKD to delete the FileMan dictionaries"
W !,"being created by the package. Data globals and templates will be saved.",!!
F XBBPLOOP=0:0 D PACKAGE Q:Y<0 D BUILD
KILL %,XBBPLOOP
Q
;
PACKAGE ;
S DIC="^DIC(9.4,",DIC(0)="AEMQ"
D ^DIC
KILL DIC
Q
;
BUILD ;
S XBBPDFN=+Y,XBBPPRFX=$P(^DIC(9.4,XBBPDFN,0),U,2),Y=DT
D DD^%DT
S XBBPVER=$G(^DIC(9.4,XBBPDFN,"VERSION"))_";"_$P(^DIC(9.4,XBBPDFN,0),U,1)_";;"_Y,XBBPPGM=XBBPPRFX_"PREI"
D CHECKRTN
I XBBPFLG D EOJ3 W !!,"Bye",! Q
KILL ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J)
W "."
S (XBBPX,XBBPFLE)=0
F XBBPL=0:0 S XBBPFLE=$O(^DIC(9.4,XBBPDFN,4,"B",XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S ^UTILITY("XBBPI",$J,XBBPFLE)=""
W "."
S XBBPFLG=0,XBBPFLE=""
F XBBPL=0:0 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE I '$D(^DIC(XBBPFLE)) S XBBPFLG=1 W !,XBBPFLE," does not exist in ^DIC!"
I XBBPFLG W !!,"All files in package must exist. Fix and rerun.",!! D EOJ Q
W "."
S XBBPFLE=""
F XBBPL=0:0 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S ^(XBBPFLE)="^UTILITY(""XBDSET"",$J,"_XBBPFLE_")=S^S"
W "."
S %DT="",X="T"
D ^%DT
X ^DD("DD")
S ^UTILITY("XBBPPGM",$J,1,0)=XBBPPGM_" ; CREATED BY XBBPI ON "_Y
S ^UTILITY("XBBPPGM",$J,2,0)=" ;;"_XBBPVER
F XBBPI=1:1:3 S ^UTILITY("XBBPPGM",$J,XBBPI+2,0)=$P($T(DTA+XBBPI),";;",2,99)
S XBBPFLE=0
F XBBPI=6:1 S XBBPFLE=$O(^UTILITY("XBBPI",$J,XBBPFLE)) Q:XBBPFLE'=+XBBPFLE S XBBPY=^(XBBPFLE),^UTILITY("XBBPPGM",$J,XBBPI,0)=" ;;"_XBBPY
S DIE="^UTILITY(""XBBPPGM"",$J,",X=XBBPPGM,XCN=0
X ^%ZOSF("SAVE")
D EOJ
Q
;
CHECKRTN ;
S XBBPFLG=0
Q:'$D(^DD("OS"))#2
Q:'$D(^DD("OS",^DD("OS"),18))#2 S X=XBBPPGM X ^(18)
E Q
CR2 ;
W !!,XBBPPGM," already exists. Want to recreate it (Y/N) Y//"
D YN^DICN
S:$E(%Y)="N" XBBPFLG=1
Q
;
EOJ ;
W !!,"Routine ",XBBPPGM," has been filed.",!!
I '$D(^DIC(9.4,XBBPDFN,"INI")) D EOJ2
I $D(^DIC(9.4,XBBPDFN,"INI")),$P(^("INI"),U)="" D EOJ2 I 1
E I $D(^DIC(9.4,XBBPDFN,"INI")),$P(^("INI"),U)'=XBBPPGM W !!,"Package ",XBBPPRFX," has a pre-initialization routine entry but it is ",$P(^("INI"),U),"!"
D EOJ3
Q
;
EOJ2 ;
W !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",!
Q
;
EOJ3 ;
KILL ^UTILITY("XBBPI",$J),^UTILITY("XBBPPGM",$J),^UTILITY("XBBPI EXEC",$J)
KILL %,%DT,DIE,XCN
KILL XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY,XBBPVER
Q
;
DTA ;
;; K ^UTILITY("XBDSET",$J) F XBBPI=1:1 S XBBPIX=$P($T(Q+XBBPI),";;",2) Q:XBBPIX="" S XBBPIY=$P(XBBPIX,"=",2,99),XBBPIX=$P(XBBPIX,"=",1) S @XBBPIX=XBBPIY
;; K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
;;Q Q
XBBPI ; IHS/ADC/GTH - BUILD PACKAGE PRE-INIT ROUTINE ; [ 02/07/97 3:02 PM ]
+1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
+2 ;
+3 ; This routine builds a pre-init routine for a specified
+4 ; package. The pre-init routine will delete FileMan
+5 ; dictionaries being created by the package. Data
+6 ; globals and templates will be saved.
+7 ;
START ;
+1 DO ^XBKVAR
+2 WRITE !!,"This routine will build a pre-init routine for the specified package."
+3 WRITE !,"The pre-init routine will call XBKD to delete the FileMan dictionaries"
+4 WRITE !,"being created by the package. Data globals and templates will be saved.",!!
+5 FOR XBBPLOOP=0:0
DO PACKAGE
IF Y<0
QUIT
DO BUILD
+6 KILL %,XBBPLOOP
+7 QUIT
+8 ;
PACKAGE ;
+1 SET DIC="^DIC(9.4,"
SET DIC(0)="AEMQ"
+2 DO ^DIC
+3 KILL DIC
+4 QUIT
+5 ;
BUILD ;
+1 SET XBBPDFN=+Y
SET XBBPPRFX=$PIECE(^DIC(9.4,XBBPDFN,0),U,2)
SET Y=DT
+2 DO DD^%DT
+3 SET XBBPVER=$GET(^DIC(9.4,XBBPDFN,"VERSION"))_";"_$PIECE(^DIC(9.4,XBBPDFN,0),U,1)_";;"_Y
SET XBBPPGM=XBBPPRFX_"PREI"
+4 DO CHECKRTN
+5 IF XBBPFLG
DO EOJ3
WRITE !!,"Bye",!
QUIT
+6 KILL ^UTILITY("XBBPI",$JOB),^UTILITY("XBBPPGM",$JOB),^UTILITY("XBBPI EXEC",$JOB)
+7 WRITE "."
+8 SET (XBBPX,XBBPFLE)=0
+9 FOR XBBPL=0:0
SET XBBPFLE=$ORDER(^DIC(9.4,XBBPDFN,4,"B",XBBPFLE))
IF XBBPFLE'=+XBBPFLE
QUIT
SET ^UTILITY("XBBPI",$JOB,XBBPFLE)=""
+10 WRITE "."
+11 SET XBBPFLG=0
SET XBBPFLE=""
+12 FOR XBBPL=0:0
SET XBBPFLE=$ORDER(^UTILITY("XBBPI",$JOB,XBBPFLE))
IF XBBPFLE'=+XBBPFLE
QUIT
IF '$DATA(^DIC(XBBPFLE))
SET XBBPFLG=1
WRITE !,XBBPFLE," does not exist in ^DIC!"
+13 IF XBBPFLG
WRITE !!,"All files in package must exist. Fix and rerun.",!!
DO EOJ
QUIT
+14 WRITE "."
+15 SET XBBPFLE=""
+16 FOR XBBPL=0:0
SET XBBPFLE=$ORDER(^UTILITY("XBBPI",$JOB,XBBPFLE))
IF XBBPFLE'=+XBBPFLE
QUIT
SET ^(XBBPFLE)="^UTILITY(""XBDSET"",$J,"_XBBPFLE_")=S^S"
+17 WRITE "."
+18 SET %DT=""
SET X="T"
+19 DO ^%DT
+20 XECUTE ^DD("DD")
+21 SET ^UTILITY("XBBPPGM",$JOB,1,0)=XBBPPGM_" ; CREATED BY XBBPI ON "_Y
+22 SET ^UTILITY("XBBPPGM",$JOB,2,0)=" ;;"_XBBPVER
+23 FOR XBBPI=1:1:3
SET ^UTILITY("XBBPPGM",$JOB,XBBPI+2,0)=$PIECE($TEXT(DTA+XBBPI),";;",2,99)
+24 SET XBBPFLE=0
+25 FOR XBBPI=6:1
SET XBBPFLE=$ORDER(^UTILITY("XBBPI",$JOB,XBBPFLE))
IF XBBPFLE'=+XBBPFLE
QUIT
SET XBBPY=^(XBBPFLE)
SET ^UTILITY("XBBPPGM",$JOB,XBBPI,0)=" ;;"_XBBPY
+26 SET DIE="^UTILITY(""XBBPPGM"",$J,"
SET X=XBBPPGM
SET XCN=0
+27 XECUTE ^%ZOSF("SAVE")
+28 DO EOJ
+29 QUIT
+30 ;
CHECKRTN ;
+1 SET XBBPFLG=0
+2 IF '$DATA(^DD("OS"))#2
QUIT
+3 IF '$DATA(^DD("OS",^DD("OS"),18))#2
QUIT
SET X=XBBPPGM
XECUTE ^(18)
+4 IF '$TEST
QUIT
CR2 ;
+1 WRITE !!,XBBPPGM," already exists. Want to recreate it (Y/N) Y//"
+2 DO YN^DICN
+3 IF $EXTRACT(%Y)="N"
SET XBBPFLG=1
+4 QUIT
+5 ;
EOJ ;
+1 WRITE !!,"Routine ",XBBPPGM," has been filed.",!!
+2 IF '$DATA(^DIC(9.4,XBBPDFN,"INI"))
DO EOJ2
+3 IF $DATA(^DIC(9.4,XBBPDFN,"INI"))
IF $PIECE(^("INI"),U)=""
DO EOJ2
IF 1
+4 IF '$TEST
IF $DATA(^DIC(9.4,XBBPDFN,"INI"))
IF $PIECE(^("INI"),U)'=XBBPPGM
WRITE !!,"Package ",XBBPPRFX," has a pre-initialization routine entry but it is ",$PIECE(^("INI"),U),"!"
+5 DO EOJ3
+6 QUIT
+7 ;
EOJ2 ;
+1 WRITE !,"Package ",XBBPPRFX," has no pre-initialization routine entry!",!
+2 QUIT
+3 ;
EOJ3 ;
+1 KILL ^UTILITY("XBBPI",$JOB),^UTILITY("XBBPPGM",$JOB),^UTILITY("XBBPI EXEC",$JOB)
+2 KILL %,%DT,DIE,XCN
+3 KILL XBBPDFN,XBBPFLE,XBBPFLG,XBBPI,XBBPL,XBBPP,XBBPPGM,XBBPPRFX,XBBPX,XBBPY,XBBPVER
+4 QUIT
+5 ;
DTA ;
+1 ;; K ^UTILITY("XBDSET",$J) F XBBPI=1:1 S XBBPIX=$P($T(Q+XBBPI),";;",2) Q:XBBPIX="" S XBBPIY=$P(XBBPIX,"=",2,99),XBBPIX=$P(XBBPIX,"=",1) S @XBBPIX=XBBPIY
+2 ;; K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
+3 ;;Q Q
