XB3P9 ;IHS/SET/GTH - XB 3 PATCH 9 ; [ 04/21/2003 9:21 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;
; IHS/SET/GTH XB*3*9 10/29/2002
;
I '$G(IOM) D HOME^%ZIS
;
NEW IORVON,IORVOFF
S X="IORVON;IORVOFF"
D ENDR^%ZISS
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
S X=$P(^VA(200,DUZ,0),U)
D BMES^XPDUTL($$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM))
D BMES^XPDUTL($$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM))
;
NEW XBQUIT
S XBQUIT=0
I '$$VCHK("XB","3.0",2,"'=") S XBQUIT=2
;
NEW DA,DIC
S X="XB",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","XB")) D S XBQUIT=2
. D BMES^XPDUTL($$CJ^XLFSTR("You Have More Than One Entry In The",IOM)),MES^XPDUTL($$CJ^XLFSTR("PACKAGE File with an ""XB"" prefix.",IOM))
. D MES^XPDUTL($$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM))
. D MES^XPDUTL($$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM))
.Q
;
I $G(XPDENV)=1 D
. S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
. Q:DUZ(0)["@"
. D BMES^XPDUTL("I need ""@"" in your DUZ(0) for the install to work.")
. D MES^XPDUTL("In programmer mode, D P^DI,^XUP, and select ""XPD MAIN"" when you're prompted")
. D MES^XPDUTL("for OPTION NAME.")
. S XBQUIT=2
.Q
;
I XBQUIT D SORRY(XBQUIT) Q
;
D BMES^XPDUTL($$CJ^XLFSTR("ENVIRONMENT OK.",IOM))
;
I '$$DIR^XBDIR("E","","","","","",2) D SORRY(2)
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W:'$D(ZTQUEUED) *7,!,$$CJ^XLFSTR(IORVON_"Sorry...."_IORVOFF,IOM),$$DIR^XBDIR("E","Press RETURN")
Q
;
VCHK(XBPRE,XBVER,XBQUIT,XBCOMP) ; Check versions needed.
;
NEW XBV
S XBV=$$VERSION^XPDUTL(XBPRE)
W !,$$CJ^XLFSTR("Need "_$S(XBCOMP="<":"at least ",1:"")_XBPRE_" v "_XBVER_"....."_XBPRE_" v "_XBV_" Present",IOM)
I @(""""_XBV_""""_XBCOMP_""""_XBVER_"""") Q 0
Q 1
;
;
PRE ;EP - From KIDS.
Q
D BMES^XPDUTL("Begin 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
D BMES^XPDUTL("End 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
Q
;
POST ;EP - From KIDS.
D BMES^XPDUTL("Begin 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
;
D BMES^XPDUTL("Attaching ""XB PACKAGE TRACKING"" option to the Site Manager menu.")
D ATTACH
;
D BMES^XPDUTL("Setting up Q'ing of option 'XBTRK' for every 30 days.")
D QUE
;
I $$VERSION^%ZOSV(1)["Cache" D LOAD
;
D BMES^XPDUTL("Delivering XB*3*9 install message to select users...")
D MAIL
;
D BMES^XPDUTL("Creating Task to delete old/unused XB/ZIB routines.")
D DELR
;
D BMES^XPDUTL("End 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
Q
;
ATTACH ; Attach option for protection and interactive access.
I $$ADD^XPDMENU("XUSITEMGR","XB PACKAGE TRACKING","PTRK",10) D BMES^XPDUTL("....successfully atch'd....allocating Security Keys...") D I 1
. NEW XB,DA,DIC,DINUM
. S XB=0,XB("PG")=$O(^DIC(19.1,"B","XUPROGMODE",0)),XB("TRK")=$O(^DIC(19.1,"B","XBZ PACKAGE TRACKING",0))
. Q:'XB("PG")!'XB("TRK")
. S DIC(0)="NMQ",DIC("P")=$P(^DD(200,51,0),U,2)
. F S XB=$O(^XUSEC("XUPROGMODE",XB)) Q:'XB D
.. Q:$D(^VA(200,XB,51,XB("TRK")))
.. S DIC="^VA(200,XB,51,",DA(1)=XB,(DINUM,X)=XB("TRK")
.. D FILE^DICN
..Q
.Q
E D BMES^XPDUTL("....Attachment *FAILED*.")
Q
;
QUE ; Add the option to the OPTION SCHEDULING file.
NEW DA,DIC
S DIC=19.2,DIC(0)="L",X="XB PACKAGE TRACKING",DIC("DR")="2////"_$$SCH^XLFDT("1D",DT)_".05;6///30D"
D ^DIC
I +Y<0 D BMES^XPDUTL("Entry of ""XB PACKAGE TRACKING"" into OPTION SCHEDULING file failed.") Q
S DA(1)=+Y,DIC="^DIC(19.2,"_DA(1)_",2,",DIC(0)="",DIC("P")=$P(^DD(19.2,10,0),U,2),XBSYSID(1)="cmbsyb.hqw.DOMAIN.NAME",XBSYSID(2)=$P(^AUTTSITE(1,0),U,14)
KILL DO,DD
F X="XBSYSID(1)","XBSYSID(2)" S DIC("DR")="1///"""_(@X)_"""" D FILE^DICN
D BMES^XPDUTL("""XB PACKAGE TRACKING"" has been entered into OPTION SCHEDULING file.")
Q
;
MAIL ; Send install mail message.
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("XB3P9MS",$J)
S ^TMP("XB3P9MS",$J,1)=" --- XB v 3, Patch 9, has been installed ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("XB3P9MS",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""XB3P9MS"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("XB3P9MS",$J)
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
;
DELR ; Create task to delete unnecessary routines.
S ZTRTN="DEL^XBDELR(""XBP8"")",ZTDESC="Delete routines in the 'XBP8' namespace.",ZTDTH=$$HADD^XLFDT($H,0,0,30,0),ZTIO="",ZTPRI=1
D ^%ZTLOAD
Q
;
LOAD ; If Cache', save %-routines into Namespace
D BMES^XPDUTL("Saving 5 routines as % routines in current Namespace.")
NEW DIE,DIF,X,XB,XBF,XBL,XBT,XCM,XCN,XCNP
KILL ^TMP("XB3P9",$J)
F XB=1:1 S XBL=$P($T(RTN+XB),";",3) Q:'$L(XBL) D
. S XBF=$P(XBL,U,1),XBT=$P(XBL,U,2)
. D MES^XPDUTL(" Saving '"_$$LJ^XLFSTR(XBF,8)_"' as '"_$$LJ^XLFSTR(XBT,8)_"'.")
. S DIF="^TMP(""XB3P9"",$J,",XCNP=0,X=XBF
. X ^%ZOSF("LOAD")
. S DIE="^TMP(""XB3P9"",$J,",X=XBT,XCN=0
. X ^%ZOSF("SAVE")
. KILL ^TMP("XB3P9",$J)
.Q
Q
;
RTN ; Routine ^ Rename As
;;XBCLS^%XBCLS
;;ZIBGD^%ZIBGD
;;ZIBRD^%ZIBRD
;;ZIBCLU0^%ZIBCLU0
;;ZIBZUCI^%ZUCI
;
XB3P9 ;IHS/SET/GTH - XB 3 PATCH 9 ; [ 04/21/2003 9:21 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;
+3 ; IHS/SET/GTH XB*3*9 10/29/2002
+4 ;
+5 IF '$GET(IOM)
DO HOME^%ZIS
+6 ;
+7 NEW IORVON,IORVOFF
+8 SET X="IORVON;IORVOFF"
+9 DO ENDR^%ZISS
+10 ;
+11 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+12 ;
+13 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+14 ;
+15 SET X=$PIECE(^VA(200,DUZ,0),U)
+16 DO BMES^XPDUTL($$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM))
+17 DO BMES^XPDUTL($$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM))
+18 ;
+19 NEW XBQUIT
+20 SET XBQUIT=0
+21 IF '$$VCHK("XB","3.0",2,"'=")
SET XBQUIT=2
+22 ;
+23 NEW DA,DIC
+24 SET X="XB"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+25 DO IX^DIC
+26 IF Y<0
IF $DATA(^DIC(9.4,"C","XB"))
Begin DoDot:1
+27 DO BMES^XPDUTL($$CJ^XLFSTR("You Have More Than One Entry In The",IOM))
DO MES^XPDUTL($$CJ^XLFSTR("PACKAGE File with an ""XB"" prefix.",IOM))
+28 DO MES^XPDUTL($$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM))
+29 DO MES^XPDUTL($$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM))
+30 QUIT
End DoDot:1
SET XBQUIT=2
+31 ;
+32 IF $GET(XPDENV)=1
Begin DoDot:1
+33 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+34 IF DUZ(0)["@"
QUIT
+35 DO BMES^XPDUTL("I need ""@"" in your DUZ(0) for the install to work.")
+36 DO MES^XPDUTL("In programmer mode, D P^DI,^XUP, and select ""XPD MAIN"" when you're prompted")
+37 DO MES^XPDUTL("for OPTION NAME.")
+38 SET XBQUIT=2
+39 QUIT
End DoDot:1
+40 ;
+41 IF XBQUIT
DO SORRY(XBQUIT)
QUIT
+42 ;
+43 DO BMES^XPDUTL($$CJ^XLFSTR("ENVIRONMENT OK.",IOM))
+44 ;
+45 IF '$$DIR^XBDIR("E","","","","","",2)
DO SORRY(2)
+46 QUIT
+47 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 IF '$DATA(ZTQUEUED)
WRITE *7,!,$$CJ^XLFSTR(IORVON_"Sorry...."_IORVOFF,IOM),$$DIR^XBDIR("E","Press RETURN")
+4 QUIT
+5 ;
VCHK(XBPRE,XBVER,XBQUIT,XBCOMP) ; Check versions needed.
+1 ;
+2 NEW XBV
+3 SET XBV=$$VERSION^XPDUTL(XBPRE)
+4 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(XBCOMP="<":"at least ",1:"")_XBPRE_" v "_XBVER_"....."_XBPRE_" v "_XBV_" Present",IOM)
+5 IF @(""""_XBV_""""_XBCOMP_""""_XBVER_"""")
QUIT 0
+6 QUIT 1
+7 ;
+8 ;
PRE ;EP - From KIDS.
+1 QUIT
+2 DO BMES^XPDUTL("Begin 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
+3 DO BMES^XPDUTL("End 'PRE^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
+4 QUIT
+5 ;
POST ;EP - From KIDS.
+1 DO BMES^XPDUTL("Begin 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
+2 ;
+3 DO BMES^XPDUTL("Attaching ""XB PACKAGE TRACKING"" option to the Site Manager menu.")
+4 DO ATTACH
+5 ;
+6 DO BMES^XPDUTL("Setting up Q'ing of option 'XBTRK' for every 30 days.")
+7 DO QUE
+8 ;
+9 IF $$VERSION^%ZOSV(1)["Cache"
DO LOAD
+10 ;
+11 DO BMES^XPDUTL("Delivering XB*3*9 install message to select users...")
+12 DO MAIL
+13 ;
+14 DO BMES^XPDUTL("Creating Task to delete old/unused XB/ZIB routines.")
+15 DO DELR
+16 ;
+17 DO BMES^XPDUTL("End 'POST^XB3P9' at "_$$FMTE^XLFDT($$NOW^XLFDT)_".")
+18 QUIT
+19 ;
ATTACH ; Attach option for protection and interactive access.
+1 IF $$ADD^XPDMENU("XUSITEMGR","XB PACKAGE TRACKING","PTRK",10)
DO BMES^XPDUTL("....successfully atch'd....allocating Security Keys...")
Begin DoDot:1
+2 NEW XB,DA,DIC,DINUM
+3 SET XB=0
SET XB("PG")=$ORDER(^DIC(19.1,"B","XUPROGMODE",0))
SET XB("TRK")=$ORDER(^DIC(19.1,"B","XBZ PACKAGE TRACKING",0))
+4 IF 'XB("PG")!'XB("TRK")
QUIT
+5 SET DIC(0)="NMQ"
SET DIC("P")=$PIECE(^DD(200,51,0),U,2)
+6 FOR
SET XB=$ORDER(^XUSEC("XUPROGMODE",XB))
IF 'XB
QUIT
Begin DoDot:2
+7 IF $DATA(^VA(200,XB,51,XB("TRK")))
QUIT
+8 SET DIC="^VA(200,XB,51,"
SET DA(1)=XB
SET (DINUM,X)=XB("TRK")
+9 DO FILE^DICN
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
IF 1
+12 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+13 QUIT
+14 ;
QUE ; Add the option to the OPTION SCHEDULING file.
+1 NEW DA,DIC
+2 SET DIC=19.2
SET DIC(0)="L"
SET X="XB PACKAGE TRACKING"
SET DIC("DR")="2////"_$$SCH^XLFDT("1D",DT)_".05;6///30D"
+3 DO ^DIC
+4 IF +Y<0
DO BMES^XPDUTL("Entry of ""XB PACKAGE TRACKING"" into OPTION SCHEDULING file failed.")
QUIT
+5 SET DA(1)=+Y
SET DIC="^DIC(19.2,"_DA(1)_",2,"
SET DIC(0)=""
SET DIC("P")=$PIECE(^DD(19.2,10,0),U,2)
SET XBSYSID(1)="cmbsyb.hqw.DOMAIN.NAME"
SET XBSYSID(2)=$PIECE(^AUTTSITE(1,0),U,14)
+6 KILL DO,DD
+7 FOR X="XBSYSID(1)","XBSYSID(2)"
SET DIC("DR")="1///"""_(@X)_""""
DO FILE^DICN
+8 DO BMES^XPDUTL("""XB PACKAGE TRACKING"" has been entered into OPTION SCHEDULING file.")
+9 QUIT
+10 ;
MAIL ; Send install mail message.
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 KILL ^TMP("XB3P9MS",$JOB)
+3 SET ^TMP("XB3P9MS",$JOB,1)=" --- XB v 3, Patch 9, has been installed ---"
+4 SET %=0
+5 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("XB3P9MS",$JOB,(%+1))=" "_^(%,0)
+6 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""XB3P9MS"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+7 FOR %="XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+8 DO ^XMD
+9 KILL ^TMP("XB3P9MS",$JOB)
+10 QUIT
+11 ;
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 ;
DELR ; Create task to delete unnecessary routines.
+1 SET ZTRTN="DEL^XBDELR(""XBP8"")"
SET ZTDESC="Delete routines in the 'XBP8' namespace."
SET ZTDTH=$$HADD^XLFDT($HOROLOG,0,0,30,0)
SET ZTIO=""
SET ZTPRI=1
+2 DO ^%ZTLOAD
+3 QUIT
+4 ;
LOAD ; If Cache', save %-routines into Namespace
+1 DO BMES^XPDUTL("Saving 5 routines as % routines in current Namespace.")
+2 NEW DIE,DIF,X,XB,XBF,XBL,XBT,XCM,XCN,XCNP
+3 KILL ^TMP("XB3P9",$JOB)
+4 FOR XB=1:1
SET XBL=$PIECE($TEXT(RTN+XB),";",3)
IF '$LENGTH(XBL)
QUIT
Begin DoDot:1
+5 SET XBF=$PIECE(XBL,U,1)
SET XBT=$PIECE(XBL,U,2)
+6 DO MES^XPDUTL(" Saving '"_$$LJ^XLFSTR(XBF,8)_"' as '"_$$LJ^XLFSTR(XBT,8)_"'.")
+7 SET DIF="^TMP(""XB3P9"",$J,"
SET XCNP=0
SET X=XBF
+8 XECUTE ^%ZOSF("LOAD")
+9 SET DIE="^TMP(""XB3P9"",$J,"
SET X=XBT
SET XCN=0
+10 XECUTE ^%ZOSF("SAVE")
+11 KILL ^TMP("XB3P9",$JOB)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
RTN ; Routine ^ Rename As
+1 ;;XBCLS^%XBCLS
+2 ;;ZIBGD^%ZIBGD
+3 ;;ZIBRD^%ZIBRD
+4 ;;ZIBCLU0^%ZIBCLU0
+5 ;;ZIBZUCI^%ZUCI
+6 ;
