ZIBCKPKG ; IHS/ADC/GTH - CHECK UCI FOR PACKAGE CONTENT ; [ 10/29/2002 7:42 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;
;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Change MSM systax to use $ROUTINE.
D INIT
S XBQUEST=1 D ASKIT G:XBQ=U EXIT S XBINPR=XBQ
S XBQUEST=2 D ASKIT G:XBQ=U EXIT S XBLC=XBQ
S XBQUEST=3 D ASKIT G:XBQ=U EXIT S XBLNPR=XBQ
;
ZIS ; SELECT DEVICE
KILL ZTSK,IOP,%ZIS
S %ZIS="PQM"
D ^%ZIS
G:POP EXIT
G:$D(IO("Q")) QUE
NOQUE ;
U IO
D EN
D ^%ZISC
G EXIT
;
QUE ;
KILL ZTSAVE
F %="XBINPR","XBLNPR","XBLC" S ZTSAVE(%)=""
S ZTRTN="EN^ZIBCKPKG",ZTDESC="SCAN UCI FOR PACKAGES",ZTIO=IO,ZTDTH=0
D ^%ZTLOAD
KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
EXIT ;
D KILLS
Q
;
EN1 ; ENTRY FOR SILENT OPERATION
D INIT
S (XBINPR,XBLC)=1
G EN
;
INIT ; INITIALIZATION
S U="^"
S:'$D(DTIME) DTIME=300
Q
;
EN ; COMMON INTERNAL ENTRY
S XBQUIT=0
KILL ^UTILITY($J,"ZIBCKPKG")
D SCAN
Q:XBQUIT
D:XBLNPR SHOWNPR
D:XBLC SHOWLC
I $D(IOST),$D(IOF),$E(IOST,1,2)="P-" W @IOF
SET:$D(ZTQUEUED) ZTREQ="@"
KILLS ;
KILL XBINPR,XBRNPR,XBLNPR,XBLC,XBQUIT,XBR,XBR2,XBPF,XBI,XBJ,XBP,XBQ,XBCNT,XBQUEST
KILL ^UTILITY($J,"ZIBCKPKG"),ZTSK
Q
;
SCAN ;
X ^%ZOSF("UCI")
W "- - - PACKAGE SCAN OF UCI ",Y,$S($D(^DD("SITE")):" ON "_^("SITE"),1:"")," - - -",!!
; S XBR=$O(^ ("%zzzzzzz")) ;IHS/SET/GTH XB*3*9 10/29/2002
S XBR=$O(^$R("%zzzzzzz")) ;IHS/SET/GTH XB*3*9 10/29/2002
F Q:XBR="" Q:XBR?1L.E D CHKPKG Q:XBQUIT
Q:XBQUIT
F Q:XBR="" D GETNXT
Q
;
CHKPKG ; CHECK FOR PACKAGE
S XBPF=$E(XBR,1,4)
F XBI=$L(XBPF):-1:0 S XBPF=$E(XBPF,1,XBI) Q:XBPF="" S XBP=$O(^DIC(9.4,"C",XBPF,0)) Q:XBP
I XBPF="" D NOTPKG Q
W XBPF,?4," - ",$P(^DIC(9.4,XBP,0),U,1)
S XBRNPR=0
D SKIP
W " (",XBCNT,")",!
Q
;
NOTPKG ;
I XBINPR S ^UTILITY($J,"ZIBCKPKG",2,XBR)="" S XBPF="" D GETNXT Q
F W XBR R " -- Package prefix? ",XBPF:DTIME S:'$T XBPF=U Q:XBPF[U D GETPKG Q:XBPF'="-"
I XBPF[U S XBQUIT=1 Q
W !
I XBPF="" D GETNXT Q
S XBI=$L(XBPF),XBRNPR=1
D SKIP
W " ",XBCNT," ROUTINES SKIPPED.",!
Q
;
GETPKG ;
I XBPF?1."?" S XBQUEST=4 D DSPHLP W ! S XBPF="-" Q
I XBPF?1."?"1.E D DSPLY S XBPF="-" Q
Q:XBPF'?.E1CL.E&($L(XBPF)<5)
W " -- Package id must be upper case, length 1-4",!
S XBPF="-"
Q
;
SKIP ;
F XBCNT=1:1 S:XBRNPR ^UTILITY($J,"ZIBCKPKG",2,XBR)="" D GETNXT Q:$E(XBR,1,XBI)'=XBPF
Q
;
GETNXT ;
S:XBR?.E1L.E ^UTILITY($J,"ZIBCKPKG",1,XBR)=""
; S XBR=$O(^ (XBR)) ;IHS/SET/GTH XB*3*9 10/29/2002
S XBR=$O(^$R(XBR)) ;IHS/SET/GTH XB*3*9 10/29/2002
Q
;
DSPLY ;
S (XBPF,XBR2)=$E(XBPF,2,$L(XBPF))
W !
S XBJ=0
S X=XBR2
X ^%ZOSF("TEST")
I S XBJ=1 W !,XBR2
; F XBJ=XBJ:1 S XBR2=$O(^ (XBR2)) Q:$E(XBR2,1,$L(XBPF))'=XBPF W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 ;IHS/SET/GTH XB*3*9 10/29/2002
F XBJ=XBJ:1 S XBR2=$O(^$R(XBR2)) Q:$E(XBR2,1,$L(XBPF))'=XBPF W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 ;IHS/SET/GTH XB*3*9 10/29/2002
W:$X !
W !
Q
;
SHOWNPR ;
Q:'$D(^UTILITY($J,"ZIBCKPKG",2))
W !!,"Non-package routines:",!
S XBR2=""
F XBJ=0:1 S XBR2=$O(^UTILITY($J,"ZIBCKPKG",2,XBR2)) Q:XBR2="" W:XBJ#8=0 ! W ?XBJ#8*10,XBR2
W !
Q
;
SHOWLC ;
Q:'$D(^UTILITY($J,"ZIBCKPKG",1))
W !!,"Routine names containing lower case letters:",!
S XBR2=""
F XBJ=0:1 S XBR2=$O(^UTILITY($J,"ZIBCKPKG",1,XBR2)) Q:XBR2="" W:XBJ#8=0 ! W ?XBJ#8*10,XBR2
W !
Q
;
ASKIT ; ASK A YES/NO QUESTION
KILL XBQ
S %=$T(@XBQUEST),XBQ("Q")=$P(%,";;",2),XBQ("D")=$P(%,";;",3)
ASKIT2 ;
W !,XBQ("Q")," ",XBQ("D"),"// "
R XBQ:DTIME
S:'$T XBQ=U
I XBQ="" S XBQ=XBQ("D") W XBQ
S XBQ("R")=XBQ,XBQ=""
I XBQ("R")[U S XBQ=U
I $P("YES",XBQ("R"))="" S XBQ=1
I $P("yes",XBQ("R"))="" S XBQ=1
I $P("NO",XBQ("R"))="" S XBQ=0
I $P("no",XBQ("R"))="" S XBQ=0
I XBQ]"" W ! Q
W !,"-- Please answer YES or NO"
D DSPHLP
G ASKIT
;
DSPHLP ;
F XBI=1:1 S %=$T(@XBQUEST+XBI) Q:%="" Q:$P(%," ")]"" W !,"-- ",$P(%,";;",2)
W !
KILL %
Q
;
QUEST ;
;
1 ;;Ignore non-package routines?;;YES
;;Responding NO will cause you to be asked if a routine for which
;;a namespace cannot be identified in the package file can be
;;considered part of a "psuedo-package" with which a namespace can
;;be associated.
2 ;;Display routine names containing lower case letters?;;YES
;;Responding YES will cause a tabular listing to be produced
;;displaying all routine names which contain a lower case letter.
3 ;;Display names of non-package routines?;;YES
;;Responding YES will cause a tabular listing to be produced
;;displaying the names of all routines which were not found
;;to be part of a package.
4 ;;
;;If you enter a namespace, routines will be processed as though a
;;formal package association was made.
ZIBCKPKG ; IHS/ADC/GTH - CHECK UCI FOR PACKAGE CONTENT ; [ 10/29/2002 7:42 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;
+3 ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Change MSM systax to use $ROUTINE.
+4 DO INIT
+5 SET XBQUEST=1
DO ASKIT
IF XBQ=U
GOTO EXIT
SET XBINPR=XBQ
+6 SET XBQUEST=2
DO ASKIT
IF XBQ=U
GOTO EXIT
SET XBLC=XBQ
+7 SET XBQUEST=3
DO ASKIT
IF XBQ=U
GOTO EXIT
SET XBLNPR=XBQ
+8 ;
ZIS ; SELECT DEVICE
+1 KILL ZTSK,IOP,%ZIS
+2 SET %ZIS="PQM"
+3 DO ^%ZIS
+4 IF POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
GOTO QUE
NOQUE ;
+1 USE IO
+2 DO EN
+3 DO ^%ZISC
+4 GOTO EXIT
+5 ;
QUE ;
+1 KILL ZTSAVE
+2 FOR %="XBINPR","XBLNPR","XBLC"
SET ZTSAVE(%)=""
+3 SET ZTRTN="EN^ZIBCKPKG"
SET ZTDESC="SCAN UCI FOR PACKAGES"
SET ZTIO=IO
SET ZTDTH=0
+4 DO ^%ZTLOAD
+5 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
EXIT ;
+1 DO KILLS
+2 QUIT
+3 ;
EN1 ; ENTRY FOR SILENT OPERATION
+1 DO INIT
+2 SET (XBINPR,XBLC)=1
+3 GOTO EN
+4 ;
INIT ; INITIALIZATION
+1 SET U="^"
+2 IF '$DATA(DTIME)
SET DTIME=300
+3 QUIT
+4 ;
EN ; COMMON INTERNAL ENTRY
+1 SET XBQUIT=0
+2 KILL ^UTILITY($JOB,"ZIBCKPKG")
+3 DO SCAN
+4 IF XBQUIT
QUIT
+5 IF XBLNPR
DO SHOWNPR
+6 IF XBLC
DO SHOWLC
+7 IF $DATA(IOST)
IF $DATA(IOF)
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILLS ;
+1 KILL XBINPR,XBRNPR,XBLNPR,XBLC,XBQUIT,XBR,XBR2,XBPF,XBI,XBJ,XBP,XBQ,XBCNT,XBQUEST
+2 KILL ^UTILITY($JOB,"ZIBCKPKG"),ZTSK
+3 QUIT
+4 ;
SCAN ;
+1 XECUTE ^%ZOSF("UCI")
+2 WRITE "- - - PACKAGE SCAN OF UCI ",Y,$SELECT($DATA(^DD("SITE")):" ON "_^("SITE"),1:"")," - - -",!!
+3 ; S XBR=$O(^ ("%zzzzzzz")) ;IHS/SET/GTH XB*3*9 10/29/2002
+4 ;IHS/SET/GTH XB*3*9 10/29/2002
SET XBR=$ORDER(^$RANDOM("%zzzzzzz"))
+5 FOR
IF XBR=""
QUIT
IF XBR?1L.E
QUIT
DO CHKPKG
IF XBQUIT
QUIT
+6 IF XBQUIT
QUIT
+7 FOR
IF XBR=""
QUIT
DO GETNXT
+8 QUIT
+9 ;
CHKPKG ; CHECK FOR PACKAGE
+1 SET XBPF=$EXTRACT(XBR,1,4)
+2 FOR XBI=$LENGTH(XBPF):-1:0
SET XBPF=$EXTRACT(XBPF,1,XBI)
IF XBPF=""
QUIT
SET XBP=$ORDER(^DIC(9.4,"C",XBPF,0))
IF XBP
QUIT
+3 IF XBPF=""
DO NOTPKG
QUIT
+4 WRITE XBPF,?4," - ",$PIECE(^DIC(9.4,XBP,0),U,1)
+5 SET XBRNPR=0
+6 DO SKIP
+7 WRITE " (",XBCNT,")",!
+8 QUIT
+9 ;
NOTPKG ;
+1 IF XBINPR
SET ^UTILITY($JOB,"ZIBCKPKG",2,XBR)=""
SET XBPF=""
DO GETNXT
QUIT
+2 FOR
WRITE XBR
READ " -- Package prefix? ",XBPF:DTIME
IF '$TEST
SET XBPF=U
IF XBPF[U
QUIT
DO GETPKG
IF XBPF'="-"
QUIT
+3 IF XBPF[U
SET XBQUIT=1
QUIT
+4 WRITE !
+5 IF XBPF=""
DO GETNXT
QUIT
+6 SET XBI=$LENGTH(XBPF)
SET XBRNPR=1
+7 DO SKIP
+8 WRITE " ",XBCNT," ROUTINES SKIPPED.",!
+9 QUIT
+10 ;
GETPKG ;
+1 IF XBPF?1."?"
SET XBQUEST=4
DO DSPHLP
WRITE !
SET XBPF="-"
QUIT
+2 IF XBPF?1."?"1.E
DO DSPLY
SET XBPF="-"
QUIT
+3 IF XBPF'?.E1CL.E&($LENGTH(XBPF)<5)
QUIT
+4 WRITE " -- Package id must be upper case, length 1-4",!
+5 SET XBPF="-"
+6 QUIT
+7 ;
SKIP ;
+1 FOR XBCNT=1:1
IF XBRNPR
SET ^UTILITY($JOB,"ZIBCKPKG",2,XBR)=""
DO GETNXT
IF $EXTRACT(XBR,1,XBI)'=XBPF
QUIT
+2 QUIT
+3 ;
GETNXT ;
+1 IF XBR?.E1L.E
SET ^UTILITY($JOB,"ZIBCKPKG",1,XBR)=""
+2 ; S XBR=$O(^ (XBR)) ;IHS/SET/GTH XB*3*9 10/29/2002
+3 ;IHS/SET/GTH XB*3*9 10/29/2002
SET XBR=$ORDER(^$RANDOM(XBR))
+4 QUIT
+5 ;
DSPLY ;
+1 SET (XBPF,XBR2)=$EXTRACT(XBPF,2,$LENGTH(XBPF))
+2 WRITE !
+3 SET XBJ=0
+4 SET X=XBR2
+5 XECUTE ^%ZOSF("TEST")
+6 IF $TEST
SET XBJ=1
WRITE !,XBR2
+7 ; F XBJ=XBJ:1 S XBR2=$O(^ (XBR2)) Q:$E(XBR2,1,$L(XBPF))'=XBPF W:XBJ#8=0 ! W ?XBJ#8*10,XBR2 ;IHS/SET/GTH XB*3*9 10/29/2002
+8 ;IHS/SET/GTH XB*3*9 10/29/2002
FOR XBJ=XBJ:1
SET XBR2=$ORDER(^$RANDOM(XBR2))
IF $EXTRACT(XBR2,1,$LENGTH(XBPF))'=XBPF
QUIT
IF XBJ#8=0
WRITE !
WRITE ?XBJ#8*10,XBR2
+9 IF $X
WRITE !
+10 WRITE !
+11 QUIT
+12 ;
SHOWNPR ;
+1 IF '$DATA(^UTILITY($JOB,"ZIBCKPKG",2))
QUIT
+2 WRITE !!,"Non-package routines:",!
+3 SET XBR2=""
+4 FOR XBJ=0:1
SET XBR2=$ORDER(^UTILITY($JOB,"ZIBCKPKG",2,XBR2))
IF XBR2=""
QUIT
IF XBJ#8=0
WRITE !
WRITE ?XBJ#8*10,XBR2
+5 WRITE !
+6 QUIT
+7 ;
SHOWLC ;
+1 IF '$DATA(^UTILITY($JOB,"ZIBCKPKG",1))
QUIT
+2 WRITE !!,"Routine names containing lower case letters:",!
+3 SET XBR2=""
+4 FOR XBJ=0:1
SET XBR2=$ORDER(^UTILITY($JOB,"ZIBCKPKG",1,XBR2))
IF XBR2=""
QUIT
IF XBJ#8=0
WRITE !
WRITE ?XBJ#8*10,XBR2
+5 WRITE !
+6 QUIT
+7 ;
ASKIT ; ASK A YES/NO QUESTION
+1 KILL XBQ
+2 SET %=$TEXT(@XBQUEST)
SET XBQ("Q")=$PIECE(%,";;",2)
SET XBQ("D")=$PIECE(%,";;",3)
ASKIT2 ;
+1 WRITE !,XBQ("Q")," ",XBQ("D"),"// "
+2 READ XBQ:DTIME
+3 IF '$TEST
SET XBQ=U
+4 IF XBQ=""
SET XBQ=XBQ("D")
WRITE XBQ
+5 SET XBQ("R")=XBQ
SET XBQ=""
+6 IF XBQ("R")[U
SET XBQ=U
+7 IF $PIECE("YES",XBQ("R"))=""
SET XBQ=1
+8 IF $PIECE("yes",XBQ("R"))=""
SET XBQ=1
+9 IF $PIECE("NO",XBQ("R"))=""
SET XBQ=0
+10 IF $PIECE("no",XBQ("R"))=""
SET XBQ=0
+11 IF XBQ]""
WRITE !
QUIT
+12 WRITE !,"-- Please answer YES or NO"
+13 DO DSPHLP
+14 GOTO ASKIT
+15 ;
DSPHLP ;
+1 FOR XBI=1:1
SET %=$TEXT(@XBQUEST+XBI)
IF %=""
QUIT
IF $PIECE(%," ")]""
QUIT
WRITE !,"-- ",$PIECE(%,";;",2)
+2 WRITE !
+3 KILL %
+4 QUIT
+5 ;
QUEST ;
+1 ;
1 ;;Ignore non-package routines?;;YES
+1 ;;Responding NO will cause you to be asked if a routine for which
+2 ;;a namespace cannot be identified in the package file can be
+3 ;;considered part of a "psuedo-package" with which a namespace can
+4 ;;be associated.
2 ;;Display routine names containing lower case letters?;;YES
+1 ;;Responding YES will cause a tabular listing to be produced
+2 ;;displaying all routine names which contain a lower case letter.
3 ;;Display names of non-package routines?;;YES
+1 ;;Responding YES will cause a tabular listing to be produced
+2 ;;displaying the names of all routines which were not found
+3 ;;to be part of a package.
4 ;;
+1 ;;If you enter a namespace, routines will be processed as though a
+2 ;;formal package association was made.
