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