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

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.