XPDIJ ;SFISC/RSD - Install Job ;08/14/2008
;;8.0;KERNEL;**2,21,28,41,44,68,81,95,108,124,229,275,506,672,796**;Jul 10, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
EN ;install all packages
;XPDA=ien of first package
;this is needed to restore XPDIJ1
D LNRF("XPDUTL") ;p275 SAVE calls RTNLOG^XPDUTL
D LNRF("XPDIJ1") ;See that XPDIJ1 is loaded befor it is called
N IEN,XPDI,XPD0,XPDSET,XPDABORT,XPDMENU,XPDQUIT,XPDVOL,X,Y,ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK
M X=DUZ N DUZ M DUZ=X S DUZ(0)="@" ;See that install has full FM priv.
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XPDIJ"
E S X="ERR^XPDIJ",@^%ZOSF("TRAP")
;check that Install entry exists, set status to "Start of Install"
Q:'$D(^XPD(9.7,+$G(XPDA),0)) S XPD0=^(0),$P(^(0),U,9)=2
D INIT^XPDID
;See if need to Inhibit Logons
I $$ANSWER^XPDIQ("XPI1") D INHIBIT^XPDIJ1("Y")
;disable options & protocols for setname, XPDSET=1/0^setname^out of order msg.
S Y=$P(XPD0,U,8),XPDSET=+Y_U_$E(Y,2,99)_U_$S($L(Y):$P($G(^XTMP("XQOO",$E(Y,2,99),0)),U),1:"")
;hang the number of seconds given in 0;10
I XPDSET D OFF^XQOO1($P(XPDSET,U,2)) I $P(XPD0,U,10) H ($P(XPD0,U,10)*60)
;check that Install still exists, wasn't unloaded p672
I '$D(^XPD(9.7,XPDA,0))!'$D(^XTMP("XPDI",XPDA)) D EXIT^XPDID(" Build NOT installed, Transport Global missing!!!!") Q
S Y=0
;XPDABORT can be set in pre or post install to abort install
F S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y S %=$O(^(Y,0)) D:% Q:$D(XPDABORT)
.N XPD,XPDA,XPDNM,XPDV,XPDV0,XPDVOL,XPDX,XPDY,Y
.;Now do the Install
.S XPDA=%,XPDNM=$P($G(^XPD(9.7,XPDA,0)),U) D IN^XPDIJ1 Q:$D(XPDABORT)
;
;Now do Master Build Post INIT.
I '$D(XPDABORT),$D(XPDT("MASTER")) D
.N XPDBLD,XPDGREF
.S XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
.D POST^XPDIJ1
;ZTREQ tells taskman to delete task
I $G(ZTSK) S ZTREQ="@" D
.;remove task # from Install File
.N XPD S XPD(9.7,XPDA_",",5)="@"
.D FILE^DIE("","XPD")
;quit if install was aborted
I $D(XPDABORT) D EXIT^XPDID("Install Aborted!!"),^%ZISC Q
;put option back in order
I $P(XPDSET,U,2)]"" D ON^XQOO1($P(XPDSET,U,2)) K ^XTMP("XQOO",$P(XPDSET,U,2))
;check if menu rebuild is wanted (only if option has been added to any installs)
;XPDMENU is used to check that it is only done once
S (Y,XPDMENU)=0
F S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y S %=$O(^(Y,0)) D:% Q:XPDMENU
.N XPDA,Y
.S XPDA=%
.I $$ANSWER^XPDIQ("XPO1") D BMES^XPDUTL(" Call MENU rebuild"),KIDS^XQ81 S XPDMENU=1
.;There should be no reason to check other CPUs anymore, patch 496
.Q
.;check if need to queue menu rebuild on other CPUs
.D:$O(^XPD(9.7,XPDA,"VOL",0))
..N XPDU,XPDY,XPDV,XPDV0,ZTUCI,ZTCPU
..X ^%ZOSF("UCI") S XPDU=$P(Y,","),XPDY=$P(Y,",",2),XPDV=0
..;loop thru VOLUMES SET and don't do current volume set
..F S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV S XPDV0=$P(^(XPDV,0),U) D:XPDV0'=XPDY
...S ZTUCI=XPDU,ZTDTH=$H,ZTIO="",ZTDESC="Install Menu Rebuild",ZTCPU=XPDV0,ZTRTN="KIDS^XQ81" D ^%ZTLOAD
;
;See if need to reset inhibit logons
I $$ANSWER^XPDIQ("XPI1") D INHIBIT^XPDIJ1("N")
;
;clean up globals
S Y=0
F S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y S XPDI=$O(^(Y,0)) D:XPDI
. N %,Y,XPD,X
. ;See if need to delete Env,Pre,Post routines.
. S %=$O(^XTMP("XPDI",XPDI,"BLD",0)),XPD=$G(^XTMP("XPDI",XPDI,"BLD",%,"INID"))
. I '$$GET^XUPARAM("XPD NO_EPP_DELETE") F %=1:1:3 I $P(XPD,U,%)="y" D
. . S X=^XTMP("XPDI",XPDI,$P("PRE^INIT^INI",U,%)) S:X[U X=$P(X,U,2) X:X]"" ^%ZOSF("DEL")
. ;kill transport global
. K ^XTMP("XPDI",XPDI)
. ;update the status field
. S XPD(9.7,XPDI_",",.02)=3
. D FILE^DIE("","XPD")
D EXIT^XPDID("Install Completed"),^%ZISC
Q
;
SAVE(X) ;restore routine X
N %,DIE,XCM,XCN,XCS
S DIE="^XTMP(""XPDI"",XPDA,""RTN"",X,",XCN=0
X ^%ZOSF("SAVE") D RTNLOG^XPDUTL(X)
Q
RTN(XPDA) ;restore all routines for package XPDA
;^XPD("XPDI",XPDA,"RTN",routine name)=0-install, 1-delete, 2-skip^checksum
Q:$G(XPDA)=""
N X,XPDI,XPDJ S XPDI=""
F S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDI)) Q:XPDI="" S XPDJ=^(XPDI) D
.;if we are doing VT graphic display, set counter
.I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
.I 'XPDJ D SAVE(XPDI) Q
.;set checksum to null, since routine wasn't loaded
.I $P(XPDJ,U,2) S $P(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"KRN",9.8,"NM",$P(XPDJ,U,2),0),U,4)=""
.I $P(XPDJ,U)=1 S X=XPDI X ^%ZOSF("DEL")
;if graphic display, update full count
I $D(XPDIDVT) D UPDATE^XPDID(XPDIDCNT)
Q
;
VOLERR(V,F) ;volume set not updated,V=volume set, F=flag
N XQA,XQAMSG,XPDMES
S XPDMES(1)=" ",XPDMES(2)=" ** Job on VOLUME SET "_V_$S(F:" never started **",1:" has been idle for an hour.")
S XPDMES(3)=" ** "_V_" has NOT been updated! **"
S XQA(DUZ)="",XQAMSG="VOLUME SET "_V_" NOT updated for Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)
D MES^XPDUTL(.XPDMES),SETUP^XQALERT
Q
;come here on error, record error in Install file and cleanup var.
ERR N XPDERROR,XQA,XQAMSG
S XPDERROR=$$EC^%ZOSV
;record error
D ^%ZTER
;reset primary device back to home device
I $G(IO(0))]"" U IO(0) ;p796
;write message, reset terminal
D BMES^XPDUTL(XPDERROR),EXIT^XPDID()
S XQA(DUZ)="",XQAMSG="Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)_" has encountered an Error."
D SETUP^XQALERT G UNWIND^%ZTER
;
LNRF(RN) ;Load needed routines first
I $D(^XTMP("XPDI",XPDA,"RTN",RN)) D
.N X
.D SAVE(RN)
.S XCN=$$RTNUP^XPDUTL(RN,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIJ 5549 printed Sep 23, 2025@19:39:43 Page 2
XPDIJ ;SFISC/RSD - Install Job ;08/14/2008
+1 ;;8.0;KERNEL;**2,21,28,41,44,68,81,95,108,124,229,275,506,672,796**;Jul 10, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
EN ;install all packages
+1 ;XPDA=ien of first package
+2 ;this is needed to restore XPDIJ1
+3 ;p275 SAVE calls RTNLOG^XPDUTL
DO LNRF("XPDUTL")
+4 ;See that XPDIJ1 is loaded befor it is called
DO LNRF("XPDIJ1")
+5 NEW IEN,XPDI,XPD0,XPDSET,XPDABORT,XPDMENU,XPDQUIT,XPDVOL,X,Y,ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK
+6 ;See that install has full FM priv.
MERGE X=DUZ
NEW DUZ
MERGE DUZ=X
SET DUZ(0)="@"
+7 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^XPDIJ"
+8 IF '$TEST
SET X="ERR^XPDIJ"
SET @^%ZOSF("TRAP")
+9 ;check that Install entry exists, set status to "Start of Install"
+10 if '$DATA(^XPD(9.7,+$GET(XPDA),0))
QUIT
SET XPD0=^(0)
SET $PIECE(^(0),U,9)=2
+11 DO INIT^XPDID
+12 ;See if need to Inhibit Logons
+13 IF $$ANSWER^XPDIQ("XPI1")
DO INHIBIT^XPDIJ1("Y")
+14 ;disable options & protocols for setname, XPDSET=1/0^setname^out of order msg.
+15 SET Y=$PIECE(XPD0,U,8)
SET XPDSET=+Y_U_$EXTRACT(Y,2,99)_U_$SELECT($LENGTH(Y):$PIECE($GET(^XTMP("XQOO",$EXTRACT(Y,2,99),0)),U),1:"")
+16 ;hang the number of seconds given in 0;10
+17 IF XPDSET
DO OFF^XQOO1($PIECE(XPDSET,U,2))
IF $PIECE(XPD0,U,10)
HANG ($PIECE(XPD0,U,10)*60)
+18 ;check that Install still exists, wasn't unloaded p672
+19 IF '$DATA(^XPD(9.7,XPDA,0))!'$DATA(^XTMP("XPDI",XPDA))
DO EXIT^XPDID(" Build NOT installed, Transport Global missing!!!!")
QUIT
+20 SET Y=0
+21 ;XPDABORT can be set in pre or post install to abort install
+22 FOR
SET Y=$ORDER(^XPD(9.7,"ASP",XPDA,Y))
if 'Y
QUIT
SET %=$ORDER(^(Y,0))
if %
Begin DoDot:1
+23 NEW XPD,XPDA,XPDNM,XPDV,XPDV0,XPDVOL,XPDX,XPDY,Y
+24 ;Now do the Install
+25 SET XPDA=%
SET XPDNM=$PIECE($GET(^XPD(9.7,XPDA,0)),U)
DO IN^XPDIJ1
if $DATA(XPDABORT)
QUIT
End DoDot:1
if $DATA(XPDABORT)
QUIT
+26 ;
+27 ;Now do Master Build Post INIT.
+28 IF '$DATA(XPDABORT)
IF $DATA(XPDT("MASTER"))
Begin DoDot:1
+29 NEW XPDBLD,XPDGREF
+30 SET XPDBLD=$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
SET XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
+31 DO POST^XPDIJ1
End DoDot:1
+32 ;ZTREQ tells taskman to delete task
+33 IF $GET(ZTSK)
SET ZTREQ="@"
Begin DoDot:1
+34 ;remove task # from Install File
+35 NEW XPD
SET XPD(9.7,XPDA_",",5)="@"
+36 DO FILE^DIE("","XPD")
End DoDot:1
+37 ;quit if install was aborted
+38 IF $DATA(XPDABORT)
DO EXIT^XPDID("Install Aborted!!")
DO ^%ZISC
QUIT
+39 ;put option back in order
+40 IF $PIECE(XPDSET,U,2)]""
DO ON^XQOO1($PIECE(XPDSET,U,2))
KILL ^XTMP("XQOO",$PIECE(XPDSET,U,2))
+41 ;check if menu rebuild is wanted (only if option has been added to any installs)
+42 ;XPDMENU is used to check that it is only done once
+43 SET (Y,XPDMENU)=0
+44 FOR
SET Y=$ORDER(^XPD(9.7,"ASP",XPDA,Y))
if 'Y
QUIT
SET %=$ORDER(^(Y,0))
if %
Begin DoDot:1
+45 NEW XPDA,Y
+46 SET XPDA=%
+47 IF $$ANSWER^XPDIQ("XPO1")
DO BMES^XPDUTL(" Call MENU rebuild")
DO KIDS^XQ81
SET XPDMENU=1
+48 ;There should be no reason to check other CPUs anymore, patch 496
+49 QUIT
+50 ;check if need to queue menu rebuild on other CPUs
+51 if $ORDER(^XPD(9.7,XPDA,"VOL",0))
Begin DoDot:2
+52 NEW XPDU,XPDY,XPDV,XPDV0,ZTUCI,ZTCPU
+53 XECUTE ^%ZOSF("UCI")
SET XPDU=$PIECE(Y,",")
SET XPDY=$PIECE(Y,",",2)
SET XPDV=0
+54 ;loop thru VOLUMES SET and don't do current volume set
+55 FOR
SET XPDV=$ORDER(^XPD(9.7,XPDA,"VOL",XPDV))
if 'XPDV
QUIT
SET XPDV0=$PIECE(^(XPDV,0),U)
if XPDV0'=XPDY
Begin DoDot:3
+56 SET ZTUCI=XPDU
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTDESC="Install Menu Rebuild"
SET ZTCPU=XPDV0
SET ZTRTN="KIDS^XQ81"
DO ^%ZTLOAD
End DoDot:3
End DoDot:2
End DoDot:1
if XPDMENU
QUIT
+57 ;
+58 ;See if need to reset inhibit logons
+59 IF $$ANSWER^XPDIQ("XPI1")
DO INHIBIT^XPDIJ1("N")
+60 ;
+61 ;clean up globals
+62 SET Y=0
+63 FOR
SET Y=$ORDER(^XPD(9.7,"ASP",XPDA,Y))
if 'Y
QUIT
SET XPDI=$ORDER(^(Y,0))
if XPDI
Begin DoDot:1
+64 NEW %,Y,XPD,X
+65 ;See if need to delete Env,Pre,Post routines.
+66 SET %=$ORDER(^XTMP("XPDI",XPDI,"BLD",0))
SET XPD=$GET(^XTMP("XPDI",XPDI,"BLD",%,"INID"))
+67 IF '$$GET^XUPARAM("XPD NO_EPP_DELETE")
FOR %=1:1:3
IF $PIECE(XPD,U,%)="y"
Begin DoDot:2
+68 SET X=^XTMP("XPDI",XPDI,$PIECE("PRE^INIT^INI",U,%))
if X[U
SET X=$PIECE(X,U,2)
if X]""
XECUTE ^%ZOSF("DEL")
End DoDot:2
+69 ;kill transport global
+70 KILL ^XTMP("XPDI",XPDI)
+71 ;update the status field
+72 SET XPD(9.7,XPDI_",",.02)=3
+73 DO FILE^DIE("","XPD")
End DoDot:1
+74 DO EXIT^XPDID("Install Completed")
DO ^%ZISC
+75 QUIT
+76 ;
SAVE(X) ;restore routine X
+1 NEW %,DIE,XCM,XCN,XCS
+2 SET DIE="^XTMP(""XPDI"",XPDA,""RTN"",X,"
SET XCN=0
+3 XECUTE ^%ZOSF("SAVE")
DO RTNLOG^XPDUTL(X)
+4 QUIT
RTN(XPDA) ;restore all routines for package XPDA
+1 ;^XPD("XPDI",XPDA,"RTN",routine name)=0-install, 1-delete, 2-skip^checksum
+2 if $GET(XPDA)=""
QUIT
+3 NEW X,XPDI,XPDJ
SET XPDI=""
+4 FOR
SET XPDI=$ORDER(^XTMP("XPDI",XPDA,"RTN",XPDI))
if XPDI=""
QUIT
SET XPDJ=^(XPDI)
Begin DoDot:1
+5 ;if we are doing VT graphic display, set counter
+6 IF $DATA(XPDIDVT)
SET XPDIDCNT=XPDIDCNT+1
if '(XPDIDCNT#XPDIDMOD)
DO UPDATE^XPDID(XPDIDCNT)
+7 IF 'XPDJ
DO SAVE(XPDI)
QUIT
+8 ;set checksum to null, since routine wasn't loaded
+9 IF $PIECE(XPDJ,U,2)
SET $PIECE(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"KRN",9.8,"NM",$PIECE(XPDJ,U,2),0),U,4)=""
+10 IF $PIECE(XPDJ,U)=1
SET X=XPDI
XECUTE ^%ZOSF("DEL")
End DoDot:1
+11 ;if graphic display, update full count
+12 IF $DATA(XPDIDVT)
DO UPDATE^XPDID(XPDIDCNT)
+13 QUIT
+14 ;
VOLERR(V,F) ;volume set not updated,V=volume set, F=flag
+1 NEW XQA,XQAMSG,XPDMES
+2 SET XPDMES(1)=" "
SET XPDMES(2)=" ** Job on VOLUME SET "_V_$SELECT(F:" never started **",1:" has been idle for an hour.")
+3 SET XPDMES(3)=" ** "_V_" has NOT been updated! **"
+4 SET XQA(DUZ)=""
SET XQAMSG="VOLUME SET "_V_" NOT updated for Install "_$EXTRACT($PIECE($GET(^XPD(9.7,+$GET(XPDA),0)),"^"),1,30)
+5 DO MES^XPDUTL(.XPDMES)
DO SETUP^XQALERT
+6 QUIT
+7 ;come here on error, record error in Install file and cleanup var.
ERR NEW XPDERROR,XQA,XQAMSG
+1 SET XPDERROR=$$EC^%ZOSV
+2 ;record error
+3 DO ^%ZTER
+4 ;reset primary device back to home device
+5 ;p796
IF $GET(IO(0))]""
USE IO(0)
+6 ;write message, reset terminal
+7 DO BMES^XPDUTL(XPDERROR)
DO EXIT^XPDID()
+8 SET XQA(DUZ)=""
SET XQAMSG="Install "_$EXTRACT($PIECE($GET(^XPD(9.7,+$GET(XPDA),0)),"^"),1,30)_" has encountered an Error."
+9 DO SETUP^XQALERT
GOTO UNWIND^%ZTER
+10 ;
LNRF(RN) ;Load needed routines first
+1 IF $DATA(^XTMP("XPDI",XPDA,"RTN",RN))
Begin DoDot:1
+2 NEW X
+3 DO SAVE(RN)
+4 SET XCN=$$RTNUP^XPDUTL(RN,2)
End DoDot:1
+5 QUIT
