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.
Q
;
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)
Q
;
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
Q
;
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
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")
Q
;
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.",!
Q
;
RSLT(%) S ^(0)=$G(^TMP("XBTRK XMD",$J,0))+1,^(^(0))=%
Q
;
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)=""
Q
;
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 ;
