source: IHS-VA_UTILITIES-XB/trunk/ZIBCKPKG.m@ 1251

ZIBCKPKG        ; IHS/ADC/GTH - CHECK UCI FOR PACKAGE CONTENT ; [ 10/29/2002   7:42 AM ]

        ;;4.0;XB;;Jul 20, 2009;Build 2

        ;

        ;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.