Routine: XBTRK

XBTRK ;IHS/ASDST/GTH - GET SITE PACKAGE INFO ; [ 10/29/2002   7:42 AM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ; IHS/SET/GTH XB*3*9 10/29/2002

 ; Thanks to Don Jackson and Carlos Cordova for the original routine.

 ;                June 6, 2001.

 ; This routine counts the number of patched routines in each namespace

 ; in each entry in the PACKAGE file, and, if run in foreground, only

 ; delivers a mail message with the results to all local programmers.

 ; If Q'd thru option "XB PACKAGE TRACKING", in addition to the mail

 ; message getting generated, a file is sent to the system id(s)

 ; specified on the 2nd page of the TaskMan option scheduling function,

 ; with the id(s) set into variable XBSYSID(n), where "n" is a numeric

 ; subscript.

 ; The option, "XB PACKAGE TRACKING", is recommended to run every 30

 ; days, and is atch'd to the Site Manager's menu, "XUSITEMGR", as a

 ; protection against deletion by the Kernel's dangling-option cleanup

 ; process.

 ; The format of the data global transmitted to the System(s) is:

 ;         CV^namespace^name^version^#routines^patch

 ; where "CV" means "Current Version" on that machine.  If the

 ; first piece is "PV", the info on that node means the the version

 ; of the routines was a "Previous Version".  This assumes there are

 ; no 'future' versions.

START ;EP - From TaskMan.

 I '$D(ZTQUEUED) D  Q:'$$DIR^XBDIR("Y","Proceed","N",$S($G(DTIME):DTIME,1:300),"If you answer 'Y', we'll go ahead and run this")  W !

 . D ^XBKVAR

 . S ^UTILITY($J,"XBTRK")=""

 . D EN^XBRPTL

.Q

 KILL ^XBPKDATA ; KILL of unsubscripted work global.

 KILL ^TMP("XBTRK",$J),^TMP("XBTRK XMD",$J)

 ; Process every entry in the PACKAGE file that has a PREFIX value.

 NEW XBI,XBN

 S XBI=0

 F  S XBI=$O(^DIC(9.4,XBI)) Q:'XBI  D

 . S XBN=$P($G(^DIC(9.4,XBI,0)),U,2)

 . Q:XBN=""

 . W:'$D(ZTQUEUED) XBN,$J("",8-$L(XBN))

 . D:$$RSEL^ZIBRSEL(XBN_"*") ONEP(XBN)

.Q

 ; SET info ^TMP("XBTRK",$J,namespace,version,patch) into ^XBPKDATA.

 ; "CV"=Current Version;  "PV"=Previous Version.

 S (C,N)=""

 F  S N=$O(^TMP("XBTRK",$J,N)) Q:(N="")  S V="" D

 . F  S V=$O(^TMP("XBTRK",$J,N,V)) Q:(V="")  S P="" D

 .. F  S P=$O(^TMP("XBTRK",$J,N,V,P)) Q:(P="")  D

 ... S I=$O(^DIC(9.4,"C",N,0))

 ... S S=$G(^DIC(9.4,I,"VERSION"))

 ... S C=C+1

 ... S ^XBPKDATA(C)=$S(S=V:"CV",1:"PV")_U_N_U_$P(^DIC(9.4,I,0),U)_U_V_U_^TMP("XBTRK",$J,N,V,P)_U_P

 ...Q

..Q

.Q

 ; Set the 0th node.

 S %=$G(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0))

 S ^XBPKDATA(0)=$P(%,U,10)_U_$P(^DIC(4,+%,0),U,1)_U_DT_U_DT_U_DT_U_U_C

 KILL C,N,V,P,S,X

 D EN^XBVK("ZIB"),SAVE:$D(XBSYSID),MAIL,EN^XBVK("XB"),^XBKTMP

 KILL ^XBPKDATA ; KILL of unsubscripted work global.

ONEP(N) ;one package - N = namespace

 ; Process all the routines in namespace R.

 NEW R

 S R=""

 F  S R=$O(^TMP("ZIBRSEL",$J,R)) Q:R=""  D ONER(R)

ONER(R) ;one routine

 ; Do not process init's, pre's, or post's.

 I R["IN0"!(R["I00")!(R["INI")!(R["PRE")!(R["POS") Q

 I $E(R,5,6)["I0"!(R["IN1") Q

 ; Get the version line, then the 3rd and 5th ";" pieces.

 S R=$T(+2^@R)

 Q:'$L($P(R,";",3))

 S R(3)=$P(R,";",3),R(5)=$TR($P(R,";",5),"*")

 ; Increment patch count in ^TMP("XBTRK",$J,namespace,version,patch)

 F %=1:1:$L(R(5),",") S ^TMP("XBTRK",$J,N,R(3),+$P(R(5),",",%))=$G(^TMP("XBTRK",$J,N,R(3),+$P(R(5),",",%)))+1

SAVE ; Send the global to XBSYSID(n), as defined in the option schedule.

 NEW XB

 S XBQTO=$O(XBSYSID(""))

 Q:'$L(XBQTO)

 D XBUF

 S XBGL="XBPKDATA",XBMED="F",XBTLE="Package tracking info via XBTRK from",XBQ="Y",XBFN="XBTK"_$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0)),U,10)_"."_$$RJ^XLFSTR($$JDT^XBFUNC(DT),3,"0"),XBFLT=1

 D ^XBGSAVE

 I $G(XBFLG)=-1,'$D(ZTQUEUED) W !,"XBGSAVE has returned this error :  ",$G(XBFLG(1)),".",! I $$DIR^XBDIR("E","Press RETURN") Q

 S XBQTO=$O(XBSYSID(""))

 F  S XBQTO=$O(XBSYSID(XBQTO)) Q:'$L(XBQTO)  D  Q:$G(XBFLG)=-1

 . D XBUF

 . S XBFN="XBTK"_$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0)),U,10)_"."_$$RJ^XLFSTR($$JDT^XBFUNC(DT),3,"0")

 . I ^%ZOSF("OS")["UNIX" D UUCPQ^ZIBGSVEM I 1

 . E  D UUCPQ^ZIBGSVEP

 . I $G(XBFLG)=-1,'$D(ZTQUEUED) W !,"XBGSAVE has returned this error :  ",$G(XBFLG(1)),".",! I $$DIR^XBDIR("E","Press RETURN") Q

.Q

XBUF ;

 I ^%ZOSF("OS")["UNIX" S XBUF="/usr/spool/uucppublic"

 E  S XBUF=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:"C:\EXPORT")

MAIL ; Send a local mail note to current user and programmers.

 ;;Routine count by package, version, patch.

;;

 ;;This note contains a count of routines in this uci, by patch level.

 ;;Patch level '0' indicates the routines are not patched.

;;

 ;;The routines are limited to the namespaces of the packages in the PACKAGE file.

;;

 ;;'CV' indicates the routines belong to the currently installed version

 ;;of the application in the PACKAGE file.  'PV' means that the version

 ;;line of the routine (2nd line) does not match the currently installed

 ;;version of the application.

;;

 ;;A summary patch report can be obtained from IHS MailMan by selecting:

 ;;  Patch User Menu ...

 ;;and then:

 ;;  Latest/Highest Patch for all Packages

;;

 ;;For a description of how to control this report, and any file

 ;;produced/sent by this function, read the DESCRIPTION field of

 ;;option "XB PACKAGE TRACKING".

 ;;E.g., ITSC is requesting a copy of the file be sent to

 ;;   "cmbsyb.hqw.DOMAIN.NAME"

 ;;and the option description will describe how you can control that

 ;;sending, or configure the option to send the information to other

 ;;systems.

;;

 ;;CV/PV Prefix Name                Version #Rtns Patch

 ;;----- ------ ------------------  -----   ----- -----

;;

 ;;###

 NEW XMSUB,XMDUZ,XMTEXT,XMY

 S XMSUB=$P($T(MAIL+1),";",3),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""XBTRK XMD"",$J,",XMY(DUZ)="",XMY(1)=""

 D SINGLE("XUPROGMODE")

 F %=1:1 D RSLT($P($T(MAIL+%),";",3)) Q:$P($T(MAIL+%+1),";",3)="###"

 F %=0:0  S %=$O(^XBPKDATA(%)) Q:'%  S X=^(%) D

 . F Y=1:1:6 S X(Y)=$P(X,U,Y)

 . S X(3)=$E(X(3),1,18)

 . D RSLT(X(1)_"    "_X(2)_$J("",7-$L(X(2)))_X(3)_$J("",20-$L(X(3)))_X(4)_$J("",8-$L(X(4)))_$J(X(5),5)_$J(X(6),5))

.Q

 ; ^XBPKDATA(n)=CV^namespace^name^version^#routines^patch

 KILL X,Y

 D ^XMD

 KILL ^TMP("XBTRK XMD",$J)

 I '$D(ZTQUEUED) W !!,"The results are in your MailMan 'IN' basket.",!

RSLT(%) S ^(0)=$G(^TMP("XBTRK XMD",$J,0))+1,^(^(0))=%

SINGLE(K) ; Get holders of a single key K.

 NEW Y

 S Y=0

 Q:'$D(^XUSEC(K))

 F  S Y=$O(^XUSEC(K,Y)) Q:'Y  S XMY(Y)=""

XBTRK     ;IHS/ASDST/GTH - GET SITE PACKAGE INFO ; [ 10/29/2002   7:42 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ;

 +3       ; IHS/SET/GTH XB*3*9 10/29/2002

 +4       ;

 +5       ; Thanks to Don Jackson and Carlos Cordova for the original routine.

 +6       ;                June 6, 2001.

 +7       ;

 +8       ; This routine counts the number of patched routines in each namespace

 +9       ; in each entry in the PACKAGE file, and, if run in foreground, only

 +10      ; delivers a mail message with the results to all local programmers.

 +11      ;

 +12      ; If Q'd thru option "XB PACKAGE TRACKING", in addition to the mail

 +13      ; message getting generated, a file is sent to the system id(s)

 +14      ; specified on the 2nd page of the TaskMan option scheduling function,

 +15      ; with the id(s) set into variable XBSYSID(n), where "n" is a numeric

 +16      ; subscript.

 +17      ;

 +18      ; The option, "XB PACKAGE TRACKING", is recommended to run every 30

 +19      ; days, and is atch'd to the Site Manager's menu, "XUSITEMGR", as a

 +20      ; protection against deletion by the Kernel's dangling-option cleanup

 +21      ; process.

 +22      ;

 +23      ; The format of the data global transmitted to the System(s) is:

 +24      ;         CV^namespace^name^version^#routines^patch

 +25      ; where "CV" means "Current Version" on that machine.  If the

 +26      ; first piece is "PV", the info on that node means the the version

 +27      ; of the routines was a "Previous Version".  This assumes there are

 +28      ; no 'future' versions.

 +29      ;

START     ;EP - From TaskMan.

 +1       ;

 +2        IF '$DATA(ZTQUEUED)

               Begin DoDot:1

 +3                DO ^XBKVAR

 +4                SET ^UTILITY($JOB,"XBTRK")=""

 +5                DO EN^XBRPTL

 +6                QUIT

               End DoDot:1

               IF '$$DIR^XBDIR("Y","Proceed","N",$SELECT($GET(DTIME)

                   QUIT

               WRITE !

 +7       ;

 +8       ; KILL of unsubscripted work global.

           KILL ^XBPKDATA

 +9        KILL ^TMP("XBTRK",$JOB),^TMP("XBTRK XMD",$JOB)

 +10      ;

 +11      ; Process every entry in the PACKAGE file that has a PREFIX value.

 +12      ;

 +13       NEW XBI,XBN

 +14       SET XBI=0

 +15       FOR

               SET XBI=$ORDER(^DIC(9.4,XBI))

               IF 'XBI

                   QUIT

               Begin DoDot:1

 +16               SET XBN=$PIECE($GET(^DIC(9.4,XBI,0)),U,2)

 +17               IF XBN=""

                       QUIT

 +18               IF '$DATA(ZTQUEUED)

                       WRITE XBN,$JUSTIFY("",8-$LENGTH(XBN))

 +19               IF $$RSEL^ZIBRSEL(XBN_"*")

                       DO ONEP(XBN)

 +20               QUIT

               End DoDot:1

 +21      ;

 +22      ; SET info ^TMP("XBTRK",$J,namespace,version,patch) into ^XBPKDATA.

 +23      ; "CV"=Current Version;  "PV"=Previous Version.

 +24      ;

 +25       SET (C,N)=""

 +26      ;

 +27       FOR

               SET N=$ORDER(^TMP("XBTRK",$JOB,N))

               IF (N="")

                   QUIT

               SET V=""

               Begin DoDot:1

 +28               FOR

                       SET V=$ORDER(^TMP("XBTRK",$JOB,N,V))

                       IF (V="")

                           QUIT

                       SET P=""

                       Begin DoDot:2

 +29                       FOR

                               SET P=$ORDER(^TMP("XBTRK",$JOB,N,V,P))

                               IF (P="")

                                   QUIT

                               Begin DoDot:3

 +30                               SET I=$ORDER(^DIC(9.4,"C",N,0))

 +31                               SET S=$GET(^DIC(9.4,I,"VERSION"))

 +32                               SET C=C+1

 +33                               SET ^XBPKDATA(C)=$SELECT(S=V:"CV",1:"PV")_U_N_U_$PIECE(^DIC(9.4,I,0),U)_U_V_U_^TMP("XBTRK",$JOB,N,V,P)_U_P

 +34                               QUIT

                               End DoDot:3

 +35                       QUIT

                       End DoDot:2

 +36               QUIT

               End DoDot:1

 +37      ;

 +38      ; Set the 0th node.

 +39      ;

 +40       SET %=$GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0))

 +41       SET ^XBPKDATA(0)=$PIECE(%,U,10)_U_$PIECE(^DIC(4,+%,0),U,1)_U_DT_U_DT_U_DT_U_U_C

 +42      ;

 +43       KILL C,N,V,P,S,X

 +44       DO EN^XBVK("ZIB")

           IF $DATA(XBSYSID)

               DO SAVE

           DO MAIL

           DO EN^XBVK("XB")

           DO ^XBKTMP

 +45      ;

 +46      ; KILL of unsubscripted work global.

           KILL ^XBPKDATA

 +47       QUIT

 +48      ;

ONEP(N)   ;one package - N = namespace

 +1       ; Process all the routines in namespace R.

 +2        NEW R

 +3        SET R=""

 +4        FOR

               SET R=$ORDER(^TMP("ZIBRSEL",$JOB,R))

               IF R=""

                   QUIT

               DO ONER(R)

 +5        QUIT

 +6       ;

ONER(R)   ;one routine

 +1       ; Do not process init's, pre's, or post's.

 +2        IF R["IN0"!(R["I00")!(R["INI")!(R["PRE")!(R["POS")

               QUIT

 +3        IF $EXTRACT(R,5,6)["I0"!(R["IN1")

               QUIT

 +4       ; Get the version line, then the 3rd and 5th ";" pieces.

 +5        SET R=$TEXT(+2^@R)

 +6        IF '$LENGTH($PIECE(R,";",3))

               QUIT

 +7        SET R(3)=$PIECE(R,";",3)

           SET R(5)=$TRANSLATE($PIECE(R,";",5),"*")

 +8       ; Increment patch count in ^TMP("XBTRK",$J,namespace,version,patch)

 +9        FOR %=1:1:$LENGTH(R(5),",")

               SET ^TMP("XBTRK",$JOB,N,R(3),+$PIECE(R(5),",",%))=$GET(^TMP("XBTRK",$JOB,N,R(3),+$PIECE(R(5),",",%)))+1

 +10       QUIT

 +11      ;

SAVE      ; Send the global to XBSYSID(n), as defined in the option schedule.

 +1       ;

 +2        NEW XB

 +3       ;

 +4        SET XBQTO=$ORDER(XBSYSID(""))

 +5        IF '$LENGTH(XBQTO)

               QUIT

 +6       ;

 +7        DO XBUF

 +8        SET XBGL="XBPKDATA"

           SET XBMED="F"

           SET XBTLE="Package tracking info via XBTRK from"

           SET XBQ="Y"

           SET XBFN="XBTK"_$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0)),U,10)_"."_$$RJ^XLFSTR($$JDT^XBFUNC(DT),3,"0")

           SET XBFLT=1

 +9        DO ^XBGSAVE

 +10       IF $GET(XBFLG)=-1

               IF '$DATA(ZTQUEUED)

                   WRITE !,"XBGSAVE has returned this error :  ",$GET(XBFLG(1)),".",!

                   IF $$DIR^XBDIR("E","Press RETURN")

                       QUIT

 +11      ;

 +12       SET XBQTO=$ORDER(XBSYSID(""))

 +13       FOR

               SET XBQTO=$ORDER(XBSYSID(XBQTO))

               IF '$LENGTH(XBQTO)

                   QUIT

               Begin DoDot:1

 +14               DO XBUF

 +15               SET XBFN="XBTK"_$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0)),U,10)_"."_$$RJ^XLFSTR($$JDT^XBFUNC(DT),3,"0")

 +16               IF ^%ZOSF("OS")["UNIX"

                       DO UUCPQ^ZIBGSVEM

                       IF 1

 +17              IF '$TEST

                       DO UUCPQ^ZIBGSVEP

 +18               IF $GET(XBFLG)=-1

                       IF '$DATA(ZTQUEUED)

                           WRITE !,"XBGSAVE has returned this error :  ",$GET(XBFLG(1)),".",!

                           IF $$DIR^XBDIR("E","Press RETURN")

                               QUIT

 +19               QUIT

               End DoDot:1

               IF $GET(XBFLG)=-1

                   QUIT

 +20       QUIT

 +21      ;

XBUF      ;

 +1        IF ^%ZOSF("OS")["UNIX"

               SET XBUF="/usr/spool/uucppublic"

 +2       IF '$TEST

               SET XBUF=$SELECT($PIECE($GET(^AUTTSITE(1,1)),U,2)]"":$PIECE(^AUTTSITE(1,1),U,2),1:"C:\EXPORT")

 +3        QUIT

 +4       ;

MAIL      ; Send a local mail note to current user and programmers.

 +1       ;;Routine count by package, version, patch.

 +2       ;;

 +3       ;;This note contains a count of routines in this uci, by patch level.

 +4       ;;Patch level '0' indicates the routines are not patched.

 +5       ;;

 +6       ;;The routines are limited to the namespaces of the packages in the PACKAGE file.

 +7       ;;

 +8       ;;'CV' indicates the routines belong to the currently installed version

 +9       ;;of the application in the PACKAGE file.  'PV' means that the version

 +10      ;;line of the routine (2nd line) does not match the currently installed

 +11      ;;version of the application.

 +12      ;;

 +13      ;;A summary patch report can be obtained from IHS MailMan by selecting:

 +14      ;;  Patch User Menu ...

 +15      ;;and then:

 +16      ;;  Latest/Highest Patch for all Packages

 +17      ;;

 +18      ;;For a description of how to control this report, and any file

 +19      ;;produced/sent by this function, read the DESCRIPTION field of

 +20      ;;option "XB PACKAGE TRACKING".

 +21      ;;E.g., ITSC is requesting a copy of the file be sent to

 +22      ;;   "cmbsyb.hqw.DOMAIN.NAME"

 +23      ;;and the option description will describe how you can control that

 +24      ;;sending, or configure the option to send the information to other

 +25      ;;systems.

 +26      ;;

 +27      ;;CV/PV Prefix Name                Version #Rtns Patch

 +28      ;;----- ------ ------------------  -----   ----- -----

 +29      ;;

 +30      ;;###

 +31       NEW XMSUB,XMDUZ,XMTEXT,XMY

 +32       SET XMSUB=$PIECE($TEXT(MAIL+1),";",3)

           SET XMDUZ=$GET(DUZ,.5)

           SET XMTEXT="^TMP(""XBTRK XMD"",$J,"

           SET XMY(DUZ)=""

           SET XMY(1)=""

 +33       DO SINGLE("XUPROGMODE")

 +34       FOR %=1:1

               DO RSLT($PIECE($TEXT(MAIL+%),";",3))

               IF $PIECE($TEXT(MAIL+%+1),";",3)="###"

                   QUIT

 +35       FOR %=0:0

               SET %=$ORDER(^XBPKDATA(%))

               IF '%

                   QUIT

               SET X=^(%)

               Begin DoDot:1

 +36               FOR Y=1:1:6

                       SET X(Y)=$PIECE(X,U,Y)

 +37               SET X(3)=$EXTRACT(X(3),1,18)

 +38               DO RSLT(X(1)_"    "_X(2)_$JUSTIFY("",7-$LENGTH(X(2)))_X(3)_$JUSTIFY("",20-$LENGTH(X(3)))_X(4)_$JUSTIFY("",8-$LENGTH(X(4)))_$JUSTIFY(X(5),5)_$JUSTIFY(X(6),5))

 +39               QUIT

               End DoDot:1

 +40      ; ^XBPKDATA(n)=CV^namespace^name^version^#routines^patch

 +41       KILL X,Y

 +42       DO ^XMD

 +43       KILL ^TMP("XBTRK XMD",$JOB)

 +44       IF '$DATA(ZTQUEUED)

               WRITE !!,"The results are in your MailMan 'IN' basket.",!

 +45       QUIT

 +46      ;

RSLT(%)    SET ^(0)=$GET(^TMP("XBTRK XMD",$JOB,0))+1

           SET ^(^(0))=%

 +1        QUIT

 +2       ;

SINGLE(K) ; Get holders of a single key K.

 +1        NEW Y

 +2        SET Y=0

 +3        IF '$DATA(^XUSEC(K))

               QUIT

 +4        FOR

               SET Y=$ORDER(^XUSEC(K,Y))

               IF 'Y

                   QUIT

               SET XMY(Y)=""

 +5        QUIT

 +6       ;

XBTRK.m