XPDIGP ;SFISC/RSD - load Global Distribution ;08/25/2014
;;8.0;KERNEL;**41,422,672**;Jul 10, 1995;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
;XPDT is undefine if PKG^XPDIL1 aborted, need to close device
I '$D(XPDT) D ^%ZISC Q
N %,XPD,XPDIST,XPDBLD,XPDNM
S XPDA=+XPDT(1),XPDNM=$P(XPDT(1),U,2),XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0))
;update Install file, read in the other globals, close device
D XPCK,GPI:'$G(XPDQUIT),^%ZISC
I $G(XPDQUIT) D ABRTALL^XPDI(1) Q
;run post install routine
S XPD=$$INRTN^XPDIL1("INIT") I XPD]"" D
.;% = routine name only, remove tag
.S %=$P(XPD,U,$L(XPD,U)) Q:'$D(^XTMP("XPDI",XPDA,"RTN",%))
.W ! D SAVE^XPDIJ(%),BMES^XPDUTL(" Running Post Install routine "_XPD),@XPD
.;update Package file
;XPDIST is flag for site tracking, it is set in PKG^XPDIP
S XPDIST=0 D BMES^XPDUTL(" Updating KIDS files... "),PKG^XPDIP
;sends site tracking bulletin
;I XPDIST S %=$$EN^XPDIST(XPDA) D BMES^XPDUTL(" "_$P("NO ",U,'%)_"Install Message sent to FORUM ") ; p672removed
I XPDIST S %=$$EN^XPDIST(XPDA) D BMES^XPDUTL(" "_$P("NO ",U,'$P(%,"#",2))_"Install Message sent "_%) ; p672 Send tracking message to Forum.
W !! D BMES^XPDUTL(" "_XPDNM_" Installed."),STMP^XPDIJ1(17) W !!
K ^XTMP("XPDI",XPDA),XPD
;update the status field
S XPD(9.7,XPDA_",",.02)=3 D FILE^DIE("","XPD")
Q
DISP ;display the contents
N X,Y,Z
W !,"This is a Global Distribution. It contains Global(s) that will",!,"update your system at this time. The following Global(s) will be installed:",!!
F Y=1:1 S X=$P(XPDGP,"^",Y) Q:X="" D
.S Z=+$P(X,";"),X=$P(X,";",2),XPDT("GP",X)=Z_U_Y
.W "^"_X,?12,$P("Overwrite^Replace",U,Z+1),!
.;if unsubscripted global and replacing
.W:X'["("&Z "**WARNING - Global will be KILLED before install,",!,"Check global protection on ALL systems before continuing.",!
W !,"If you continue with the Load, the Global(s) will be",!,"Installed at this time.",!
Q
GPI ;global package input
N DIRUT,GP,GR,X,XPDSEQ,Y,Z
;start reading the HFS again, rwf, changed all read timeout from 0 to 1.
U IO R X:10,Y:10
;the next read must be the GLOBAL
I X'="**GLOBAL**" U IO(0) W !!,"ERROR in HFS file format!" S XPDQUIT=1 Q
U IO(0) D BMES^XPDUTL(" "_Y) U IO
;XPDSEQ is the disk sequence number
S GP=$P(Y,U,2),GR=$S(Y[")":$E(Y,1,$L(Y)-1)_",",1:Y_"("),XPDSEQ=1
K:XPDT("GP",GP) @Y
;X=global ref, Y=global value. DIRUT is when user is prompted for
;next disk in NEXTD and they abort
F R X:10,Y:10 Q:X="**END**" D I $D(DIRUT) S XPDQUIT=1 Q
.;new global
.I X="**GLOBAL**" D Q
..;completes last global check point
..D XPCOM(GP,Y)
..;reset global ref
..S GP=$P(Y,U,2),GR=$S(Y[")":$E(Y,1,$L(Y)-1)_",",1:Y_"(")
..;kill global if flag is set
..K:XPDT("GP",GP) @Y
.;I X="**CONTINUE**" D NEXTD^XPDIL Q ;X="**CONTINUE**" will only happen if the file was on multiple diskettes.
.S @(GR_X)=Y
D XPCOM(GP)
U IO(0)
Q
;
;create Global multiple of Install file
XPCK N DIR,DIRUT,X,XPD,XPDJ,X,Y,Z
S DIR(0)="Y",DIR("A")="Globals will now be installed, OK",DIR("B")="YES",DIR("?")="YES will continue with install, NO will abort install"
W ! D ^DIR I $D(DIRUT)!'Y S XPDQUIT=1 Q
W ! D BMES^XPDUTL(" Install Started for "_XPDNM_" : "),STMP^XPDIJ1(11),BMES^XPDUTL(" Installing Globals:")
S X=""
F S X=$O(XPDT("GP",X)) Q:X="" S Z=$P(XPDT("GP",X),U,2),XPD(9.718,"+"_Z_","_XPDA_",",.01)=X,XPDJ(Z)=Z
D:$D(XPD)>9 UPDATE^DIE("S","XPD","XPDJ")
Q
;
XPCOM(X,XPDN) ;complete checkpoint for global X,XPDN=next global
N GR,GP,XPD,Y,Z
U IO(0)
S Y=$$NOW^XLFDT,Z=+$P(XPDT("GP",X),U,2),XPD(9.718,Z_","_XPDA_",",1)=Y
D MES^XPDUTL(" "_$$FMTE^XLFDT(Y)),FILE^DIE("","XPD")
D:$L($G(XPDN)) BMES^XPDUTL(" "_XPDN)
U IO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIGP 3768 printed Sep 02, 2024@18:49 Page 2
XPDIGP ;SFISC/RSD - load Global Distribution ;08/25/2014
+1 ;;8.0;KERNEL;**41,422,672**;Jul 10, 1995;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;XPDT is undefine if PKG^XPDIL1 aborted, need to close device
+4 IF '$DATA(XPDT)
DO ^%ZISC
QUIT
+5 NEW %,XPD,XPDIST,XPDBLD,XPDNM
+6 SET XPDA=+XPDT(1)
SET XPDNM=$PIECE(XPDT(1),U,2)
SET XPDBLD=$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
+7 ;update Install file, read in the other globals, close device
+8 DO XPCK
if '$GET(XPDQUIT)
DO GPI
DO ^%ZISC
+9 IF $GET(XPDQUIT)
DO ABRTALL^XPDI(1)
QUIT
+10 ;run post install routine
+11 SET XPD=$$INRTN^XPDIL1("INIT")
IF XPD]""
Begin DoDot:1
+12 ;% = routine name only, remove tag
+13 SET %=$PIECE(XPD,U,$LENGTH(XPD,U))
if '$DATA(^XTMP("XPDI",XPDA,"RTN",%))
QUIT
+14 WRITE !
DO SAVE^XPDIJ(%)
DO BMES^XPDUTL(" Running Post Install routine "_XPD)
DO @XPD
+15 ;update Package file
End DoDot:1
+16 ;XPDIST is flag for site tracking, it is set in PKG^XPDIP
+17 SET XPDIST=0
DO BMES^XPDUTL(" Updating KIDS files... ")
DO PKG^XPDIP
+18 ;sends site tracking bulletin
+19 ;I XPDIST S %=$$EN^XPDIST(XPDA) D BMES^XPDUTL(" "_$P("NO ",U,'%)_"Install Message sent to FORUM ") ; p672removed
+20 ; p672 Send tracking message to Forum.
IF XPDIST
SET %=$$EN^XPDIST(XPDA)
DO BMES^XPDUTL(" "_$PIECE("NO ",U,'$PIECE(%,"#",2))_"Install Message sent "_%)
+21 WRITE !!
DO BMES^XPDUTL(" "_XPDNM_" Installed.")
DO STMP^XPDIJ1(17)
WRITE !!
+22 KILL ^XTMP("XPDI",XPDA),XPD
+23 ;update the status field
+24 SET XPD(9.7,XPDA_",",.02)=3
DO FILE^DIE("","XPD")
+25 QUIT
DISP ;display the contents
+1 NEW X,Y,Z
+2 WRITE !,"This is a Global Distribution. It contains Global(s) that will",!,"update your system at this time. The following Global(s) will be installed:",!!
+3 FOR Y=1:1
SET X=$PIECE(XPDGP,"^",Y)
if X=""
QUIT
Begin DoDot:1
+4 SET Z=+$PIECE(X,";")
SET X=$PIECE(X,";",2)
SET XPDT("GP",X)=Z_U_Y
+5 WRITE "^"_X,?12,$PIECE("Overwrite^Replace",U,Z+1),!
+6 ;if unsubscripted global and replacing
+7 if X'["("&Z
WRITE "**WARNING - Global will be KILLED before install,",!,"Check global protection on ALL systems before continuing.",!
End DoDot:1
+8 WRITE !,"If you continue with the Load, the Global(s) will be",!,"Installed at this time.",!
+9 QUIT
GPI ;global package input
+1 NEW DIRUT,GP,GR,X,XPDSEQ,Y,Z
+2 ;start reading the HFS again, rwf, changed all read timeout from 0 to 1.
+3 USE IO
READ X:10,Y:10
+4 ;the next read must be the GLOBAL
+5 IF X'="**GLOBAL**"
USE IO(0)
WRITE !!,"ERROR in HFS file format!"
SET XPDQUIT=1
QUIT
+6 USE IO(0)
DO BMES^XPDUTL(" "_Y)
USE IO
+7 ;XPDSEQ is the disk sequence number
+8 SET GP=$PIECE(Y,U,2)
SET GR=$SELECT(Y[")":$EXTRACT(Y,1,$LENGTH(Y)-1)_",",1:Y_"(")
SET XPDSEQ=1
+9 if XPDT("GP",GP)
KILL @Y
+10 ;X=global ref, Y=global value. DIRUT is when user is prompted for
+11 ;next disk in NEXTD and they abort
+12 FOR
READ X:10,Y:10
if X="**END**"
QUIT
Begin DoDot:1
+13 ;new global
+14 IF X="**GLOBAL**"
Begin DoDot:2
+15 ;completes last global check point
+16 DO XPCOM(GP,Y)
+17 ;reset global ref
+18 SET GP=$PIECE(Y,U,2)
SET GR=$SELECT(Y[")":$EXTRACT(Y,1,$LENGTH(Y)-1)_",",1:Y_"(")
+19 ;kill global if flag is set
+20 if XPDT("GP",GP)
KILL @Y
End DoDot:2
QUIT
+21 ;I X="**CONTINUE**" D NEXTD^XPDIL Q ;X="**CONTINUE**" will only happen if the file was on multiple diskettes.
+22 SET @(GR_X)=Y
End DoDot:1
IF $DATA(DIRUT)
SET XPDQUIT=1
QUIT
+23 DO XPCOM(GP)
+24 USE IO(0)
+25 QUIT
+26 ;
+27 ;create Global multiple of Install file
XPCK NEW DIR,DIRUT,X,XPD,XPDJ,X,Y,Z
+1 SET DIR(0)="Y"
SET DIR("A")="Globals will now be installed, OK"
SET DIR("B")="YES"
SET DIR("?")="YES will continue with install, NO will abort install"
+2 WRITE !
DO ^DIR
IF $DATA(DIRUT)!'Y
SET XPDQUIT=1
QUIT
+3 WRITE !
DO BMES^XPDUTL(" Install Started for "_XPDNM_" : ")
DO STMP^XPDIJ1(11)
DO BMES^XPDUTL(" Installing Globals:")
+4 SET X=""
+5 FOR
SET X=$ORDER(XPDT("GP",X))
if X=""
QUIT
SET Z=$PIECE(XPDT("GP",X),U,2)
SET XPD(9.718,"+"_Z_","_XPDA_",",.01)=X
SET XPDJ(Z)=Z
+6 if $DATA(XPD)>9
DO UPDATE^DIE("S","XPD","XPDJ")
+7 QUIT
+8 ;
XPCOM(X,XPDN) ;complete checkpoint for global X,XPDN=next global
+1 NEW GR,GP,XPD,Y,Z
+2 USE IO(0)
+3 SET Y=$$NOW^XLFDT
SET Z=+$PIECE(XPDT("GP",X),U,2)
SET XPD(9.718,Z_","_XPDA_",",1)=Y
+4 DO MES^XPDUTL(" "_$$FMTE^XLFDT(Y))
DO FILE^DIE("","XPD")
+5 if $LENGTH($GET(XPDN))
DO BMES^XPDUTL(" "_XPDN)
+6 USE IO
+7 QUIT
