XPDT ;SFISC/RSD - Transport a package ;02/12/2009
;;8.0;KERNEL;**2,10,28,41,44,51,58,66,68,85,100,108,393,511,539,547,672,713,738,750**;Jul 10, 1995;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
EN ;build XTMP("XPDT",ien, XPDA=ien,XPDNM=name
;XPDT(seq #)=ien^name^1=use current transport global^required in multi-package^don't send PAH^Version#
;XPDT("DA",ien)=seq #^build type
;XPDVER=version number^package name
;XPDGP=flag;global^flag;global^... flag=1 replace global at site
N DIR,DIRUT,I,POP,XPD,XPDA,XPDA0,XPDERR,XPDGP,XPDGREF,XPDH,XPDH1,XPDHD,XPDI,XPDNM,XPDSEQ,XPDSIZ,XPDSIZA,XPDT,XPDTP,XPDVER
N DUOUT,DTOUT,XPDFMSG,X,Y,Z,Z1
K ^TMP($J,"XPD")
S XPD="First Package Name: ",DIR(0)="Y",DIR("A")=" Use this Transport Global",DIR("?")="Yes, will use the current Transport Global on your system. No, will create a new one.",XPDT=0
W !!,"Enter the Package Names to be transported. The order in which",!,"they are entered will be the order in which they are installed.",!!
F S XPDA=$$DIC^XPDE("AEMQZ",XPD) Q:'XPDA D Q:$D(DIRUT)!$D(XPDERR)
.S XPDA0=Y(0)
.S:'XPDT XPD="Another Package Name: "
.;XPDI=name^1=use current transport global
.S XPDI=$P(XPDA0,U)_"^"
.I $D(XPDT("DA",XPDA)) W " ",$P(XPDI,U)," already listed",! Q
.;if type is Global Package, set DIRUT if there is other packages
.I $P(XPDA0,U,3)=2 W " GLOBAL PACKAGE" D Q
..;if there is already a package in distribution, abort
..I XPDT S DIRUT=1 W !,"A GLOBAL PACKAGE cannot be sent with any other packages" Q
..I $D(^XTMP("XPDT",XPDA)) W " **Cannot have a pre-existing Transport Global**" S DIRUT=1 Q
..W !?10,"will transport the following globals:",! S X=0,XPDGP=""
..F S X=$O(^XPD(9.6,XPDA,"GLO",X)) Q:'X S Z=$G(^(X,0)) I $P(Z,U)]"" S XPDGP=XPDGP_($P(Z,U,2)="y")_";"_$P(Z,U)_"^" W ?12,$P(Z,U),!
..;XPDERR is set to quit loop, so no other packages can be added
..S XPDERR=1,XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDI,XPDT("DA",XPDA)=XPDT_U_2
.Q:$D(XPDERR)
.D PCK(XPDA,XPDI,,XPDA0)
.;multi-package
.Q:$P(XPDA0,U,3)'=1
.W " (Multi-Package)" S X=0
.I XPDT>1 S DIRUT=1 W !,"A Master Build must be the first/only package in a transport" Q
.F S X=$O(^XPD(9.6,XPDA,10,X)) Q:'X S Z=$P($G(^(X,0)),U),Z1=$P($G(^(0)),U,2) D:Z]""
..N XPDA,XPDA0,X
..W !?3,Z S XPDA=$O(^XPD(9.6,"B",Z,0)),XPDA0=$G(^XPD(9.6,XPDA,0))
..I 'XPDA!(XPDA0="") W " **Can't find definition in Build file**" Q
..I $D(XPDT("DA",XPDA)) W " already listed" Q
..D PCK(XPDA,Z,Z1,XPDA0)
.S XPDERR=1 ;XPDERR is set to quit loop, so no other packages can be added
.Q
G:'XPDT!$D(DUOUT) QUIT K XPDERR
;XPDH=Header comment, XPDTP=transport method: 1=PM, 0=HF
S (XPDH,XPDTP)=""
;XPDH=header comment, will be return from DISP ;p713
F D DISP Q:$D(DIRUT)
G:$D(DUOUT) QUIT
;XPDT>1 (more than one package) or $P(XPDA0,U,3) multi-package) can only use HF
I XPDT=1,'$P(XPDA0,U,3) D G:$D(DTOUT)!$D(DUOUT) QUIT
.S DIR(0)="SAO^HF:Host File;PM:PackMan",DIR("A")="Transport through (HF)Host File or (PM)PackMan: "
.S DIR("?")="Enter the method of transport for the package(s)."
.D ^DIR S:Y="PM" XPDTP=1 S:Y="" XPDH=""
.K DIR
.Q
;single package, no transport method, no header comment
I XPDT=1,'XPDTP,XPDH="" W !,"No Transport Method selected, will only write Transport Global to ^XTMP."
;XPDTP = 1-transports using Packman, can't be GP or multiple builds
I 'XPDTP,XPDH]"" D DEV G:POP QUIT
W !!
F XPDT=1:1:XPDT S XPDA=XPDT(XPDT),XPDNM=$P(XPDA,U,2) D G:$D(XPDERR) ABORT
.W !?5,XPDNM,"..." S XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")"
.;if using current transport global, run pre-transp routine and quit
.I $P(XPDA,U,3) S XPDA=+XPDA D PRET Q
.;if package file link then set XPDVER=version number^package name
.S XPDA=+XPDA,XPDVER=$S($P(^XPD(9.6,XPDA,0),U,2):$$VER^XPDUTL(XPDNM)_U_$$PKG^XPDUTL(XPDNM),1:"")
.;Increment and set the Build number and set Build version #
.S $P(^XPD(9.6,XPDA,6.3),U)=$G(^XPD(9.6,XPDA,6.3))+1,$P(^XPD(9.6,XPDA,6),U)=$P(XPDT(XPDT),U,6)
.K ^XTMP("XPDT",XPDA)
.;GLOBAL PACKAGE
.I $D(XPDGP) D S XPDT=1 Q
..;can't send global package in packman message
..I $G(XPDTP) S XPDERR=1 Q
..;verify global package
..I '$$GLOPKG^XPDV(XPDA) S XPDERR=1 Q
..;get Environment check and Post Install routines
..F Y="PRE","INIT" I $G(^XPD(9.6,XPDA,Y))]"" S X=^(Y) D
...S ^XTMP("XPDT",XPDA,Y)=X,X=$P(X,U,$L(X,U)),%=$$LOAD^XPDTA(X,"0^")
..D BLD^XPDTC,PRET
.F X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC" D @X Q:$D(XPDERR)
.D:'$D(XPDERR) PRET
;XPDTP - call ^XPDTP to build Packman message
I $G(XPDTP) S XPDA=+XPDT(XPDT) D ^XPDTP G QUIT
I $L(XPDH) D GO G QUIT
;if no device then just create transport global
W !! F XPDT=1:1:XPDT W "Transport Global ^XTMP(""XPDT"","_+XPDT(XPDT)_") created for ",$P(XPDT(XPDT),U,2),!
Q
DEV N FIL,DIR,IOP,X,Y,%ZIS W !
D HOME^%ZIS
S DIR(0)="F^3:245",DIR("A")="Enter a Host File",DIR("?")="Enter a filename and/or path to output package(s).",POP=0
D ^DIR I $D(DTOUT)!$D(DUOUT) S POP=1 Q
;if no file, then quit
Q:Y="" S FIL=Y
S DIR(0)="F^3:200",DIR("A")="Header Comment",DIR("?")="Enter a comment between 3 and 200 characters.",DIR("B")=XPDH
D ^DIR I $D(DTOUT)!$D(DUOUT) S POP=1 Q
S XPDH=Y
S %ZIS="",%ZIS("HFSNAME")=FIL,%ZIS("HFSMODE")="W",IOP="HFS",(XPDSIZ,XPDSIZA)=0,XPDSEQ=1
D ^%ZIS I POP W !!,"**Incorrect Host File name**",!,$C(7) Q
;write date and comment header
S XPDHD="KIDS Distribution saved on "_$$HTE^XLFDT($H)
U IO W $$SUM(XPDHD),!,$$SUM(XPDH),!
S XPDFMSG=1 ;Send mail to forum of routines in HFS.
;U IO(0) is to insure I am writing to the terminal
U IO(0) Q
;
GO S I=1,Y="",XPDH1="**KIDS**:" U IO
;Global Package, header is different and there is only 1 package
I $D(XPDGP) W $$SUM("**KIDS**GLOBALS:"_$P(XPDT(1),U,2)_U_XPDGP),! G GO1
;write header that maintains package list, keep less than 255 char
F D W $$SUM(XPDH1_Y),! Q:I=XPDT S Y="",I=I+1,XPDH1="**KIDS**"
.F I=I:1 S Y=Y_$P(XPDT(I),U,2)_"^" Q:$L(Y)>200!(I=XPDT)
;after the package list write an extra line feed
GO1 W ! S XPDSIZA=XPDSIZA+2
N XMSUB,XMY,XMTEXT
;loop thru & write global, don't kill if set to permanent, set in XPDIU
F XPDT=1:1:XPDT S XPDA=+XPDT(XPDT),XPDNM=$P(XPDT(XPDT),U,2) D GW,XM K:'$G(^XTMP("XPDT",XPDA)) ^(XPDA)
W "**END**",!
;GLOBAL PACKAGE there could only be one package, write globals
I $D(XPDGP) D GPW W "**END**",!
;we're done with device, close it
W "**END**",! D ^%ZISC
W !!,"Package Transported Successfully",!
Q
GW ;global write
N GR,GCK,GL
S GCK="^XTMP(""XPDT"","_XPDA,GR=GCK_")",GCK=GCK_",",GL=$L(GCK)
;INSTALL NAME line will mark the beginning of global for all lines until
;the next INSTALL NAME
W $$SUM("**INSTALL NAME**",1),!,$$SUM(XPDNM),!
F Q:$D(DIRUT) S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK) W $$SUM($P(GR,GCK,2),1),!,$$SUM(@GR),!
Q
XM ;Send HFS checksum message
Q:'$G(XPDFMSG)
N XMTEXT,C,RN,RN2,X,X2
K ^TMP($J)
S XMSUB="**KIDS** Checksum for "_XPDNM,XMTEXT="^TMP($J)"
I $G(^XMB("NETNAME"))["DOMAIN.EXT" S XMY("S.A1AE HFS CHKSUM SVR@DOMAIN.EXT")=""
E S X=$$GET^XPAR("PKG","XPD PATCH HFS SERVER",1,"Q") S:$L(X) XMY(X)=""
I '$D(XMY) Q ;No one to send it to.
S C=1,@XMTEXT@(1,0)="~~1:"_XPDNM
I XPDT=1,$O(XPDT(1)) D
. S RN=1 F S RN=$O(XPDT(RN)) Q:'RN S C=C+1,@XMTEXT@(C,0)="~~2:"_$P(XPDT(RN),"^",2)
S (RN,RN2)="" ;Send full RTN node
F S RN=$O(^XTMP("XPDT",XPDA,"RTN",RN)) Q:'$L(RN) S X=^(RN),X2=$G(^(RN,2,0)) D
. S C=C+1,@XMTEXT@(C,0)="~~3:"_RN_"^"_X_"^"_$P(X2,";",5)
. I RN2="",$E(X2,1,3)=" ;;" S RN2=$P(X2,"**",1)_"**[Patch List]**"_$P(X2,"**",3)
S C=C+1,@XMTEXT@(C,0)="~~4:"_RN2
S C=C+1,@XMTEXT@(C,0)="~~8:"_$G(^XMB("NETNAME"))
S C=C+1,@XMTEXT@(C,0)="~~9:Save"
S XMTEXT="^TMP($J,"
D ^XMD
Q
GPW ;global package write
N I,G,GR,GCK,GL
W !
F I=1:1 S G=$P(XPDGP,U,I) Q:G="" D
.S GR="^"_$P(G,";",2),GCK=$S(GR[")":$E(GR,1,$L(GR)-1)_",",1:GR_"("),GL=$L(GCK)
.;GLOBAL line will mark the beginning of global for all lines until
.;the next GLOBAL
.W $$SUM("**GLOBAL**",1),!,$$SUM(GR),!
.F Q:$D(DIRUT) S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK) W $$SUM($P(GR,GCK,2),1),!,$$SUM(@GR),!
Q
QUIT F XPDT=1:1:XPDT L -^XPD(9.6,+XPDT(XPDT))
Q
ABORT W !!,"**TRANSPORT ABORTED**",*7
D QUIT
F XPDT=1:1:XPDT K ^XTMP("XPDT",+XPDT(XPDT))
;if HF, save file name IO into XPDH
S:$L(XPDH) XPDH=IO
D ^%ZISC
;if HF, then delete file
I $L(XPDH),$$DEL1^%ZISH(XPDH) W !,"File: ",XPDH," (Deleted)"
Q
;
PCK(XPDA,XPDNM,XPDREQ,XPDA0) ;XPDA=Build ien, XPDNM=Build name, XPDREQ=Required, XPDA0=Y(0) ^XPD(9.6,XPDA,0)
N Y,Z
S XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDNM,XPDT("DA",XPDA)=XPDT_"^"_$P(XPDA0,U,3)
;get TEST# and increment ;p713
S Z=+$G(^XPD(9.6,XPDA,6)),Z=Z+1,$P(XPDT(XPDT),U,6)=Z
S:'$G(XPDREQ) XPDREQ=0
S $P(XPDT(XPDT),U,4)=XPDREQ
Q:'$D(^XTMP("XPDT",XPDA)) S Y=$G(^(XPDA))
W " **Transport Global exists**"
;Y=1 if TG is permanent
I Y S $P(XPDT(XPDT),U,3)=1 Q
;ask if they want to use TG
D ^DIR S $P(XPDT(XPDT),U,3)=Y
Q
;
SUM(X,Z) ;X=string to write, Z 0=don't check size
S XPDSIZA=XPDSIZA+$L(X)+2
Q X
;
PAH(XPDA) ;check for PATCH APPLICATION HISTORY in Package file
N Y,Z
S Y=^XPD(9.6,XPDA,0),Z=$$VER^XPDUTL($P(Y,U))
;Single Package, Version multiple, PAH multiple
I $P(Y,U,3)=0,$D(^DIC(9.4,+$P(Y,U,2),22)),Z S Z=$O(^(22,"B",Z,0)) I Z,$O(^DIC(9.4,+$P(Y,U,2),22,Z,"PAH",0)) Q 1
Q 0
;
PRET ;Pre-Transport Routine
N Y,Z
S Y=$G(^XPD(9.6,XPDA,"PRET")) Q:Y=""
I '$$RTN^XPDV(Y,.Z) W !!,"Pre-Transportation Routine ",Y,Z,*7 Q
S Y=$S(Y["^":Y,1:"^"_Y) W !,"Running Pre-Transportation Routine ",Y
D @Y
Q
;
DISP ;display packages, RETURN: DIRUT ;p713 ;p750
N DIR,X,Y
W !!,"ORDER PACKAGE",?45,"VERSION #",!
F XPDT=1:1:XPDT W ?2,XPDT,?9,$P(XPDT(XPDT),U,2),?47," ",$P(XPDT(XPDT),U,6) D W !
.W:$P(XPDT(XPDT),U,3) ?25," **will use current Transport Global**"
.;check if New and single package, has Package File Link, Package App. History
.I $P(XPDT(XPDT),U,2)["*"!'$$PAH(+XPDT(XPDT))!($P(XPDT(XPDT),U,5)) Q
.S DIR(0)="Y",DIR("A")="Send the PATCH APPLICATION HISTORY from the PACKAGE file",DIR("B")="YES"
.W !! D ^DIR I 'Y S $P(XPDT(XPDT),U,5)=1
.Q
S DIR(0)="SA^C:Continue;E:Edit Version #;Q:Quit",DIR("A")="Do you want to (C)ontinue, (E)dit Version #, (Q)uit: ",DIR("B")="C"
W ! D ^DIR
I Y="C" D S DIRUT=1 Q
.N DIC,I,J,Y
.S I=XPDT,J=""
.F I=1:1:XPDT S J=J_$P(XPDT(I),U,2)_" v"_$P(XPDT(I),U,6)_$S(I<XPDT:", ",1:"")
.S XPDH=J
.Q
I $D(DIRUT)!(Y="Q") S DIRUT=1,DUOUT=1 Q
;edit of Version # ;p713
F D I $D(DIRUT) K DIRUT Q
.K DIR
.S DIR(0)="NOA^1:"_XPDT,DIR("A")="Enter the ORDER number or <CR> when done: "
.W ! D ^DIR I $D(DIRUT)!(Y="") Q
.S Z=Y,DIR("B")=$P(XPDT(Z),U,6),DIR(0)="NA^1:9999",DIR("A")="Version #: "
.D ^DIR I Y S $P(XPDT(Z),U,6)=Y
.Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDT 10880 printed Apr 09, 2024@21:09:09 Page 2
XPDT ;SFISC/RSD - Transport a package ;02/12/2009
+1 ;;8.0;KERNEL;**2,10,28,41,44,51,58,66,68,85,100,108,393,511,539,547,672,713,738,750**;Jul 10, 1995;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
EN ;build XTMP("XPDT",ien, XPDA=ien,XPDNM=name
+1 ;XPDT(seq #)=ien^name^1=use current transport global^required in multi-package^don't send PAH^Version#
+2 ;XPDT("DA",ien)=seq #^build type
+3 ;XPDVER=version number^package name
+4 ;XPDGP=flag;global^flag;global^... flag=1 replace global at site
+5 NEW DIR,DIRUT,I,POP,XPD,XPDA,XPDA0,XPDERR,XPDGP,XPDGREF,XPDH,XPDH1,XPDHD,XPDI,XPDNM,XPDSEQ,XPDSIZ,XPDSIZA,XPDT,XPDTP,XPDVER
+6 NEW DUOUT,DTOUT,XPDFMSG,X,Y,Z,Z1
+7 KILL ^TMP($JOB,"XPD")
+8 SET XPD="First Package Name: "
SET DIR(0)="Y"
SET DIR("A")=" Use this Transport Global"
SET DIR("?")="Yes, will use the current Transport Global on your system. No, will create a new one."
SET XPDT=0
+9 WRITE !!,"Enter the Package Names to be transported. The order in which",!,"they are entered will be the order in which they are installed.",!!
+10 FOR
SET XPDA=$$DIC^XPDE("AEMQZ",XPD)
if 'XPDA
QUIT
Begin DoDot:1
+11 SET XPDA0=Y(0)
+12 if 'XPDT
SET XPD="Another Package Name: "
+13 ;XPDI=name^1=use current transport global
+14 SET XPDI=$PIECE(XPDA0,U)_"^"
+15 IF $DATA(XPDT("DA",XPDA))
WRITE " ",$PIECE(XPDI,U)," already listed",!
QUIT
+16 ;if type is Global Package, set DIRUT if there is other packages
+17 IF $PIECE(XPDA0,U,3)=2
WRITE " GLOBAL PACKAGE"
Begin DoDot:2
+18 ;if there is already a package in distribution, abort
+19 IF XPDT
SET DIRUT=1
WRITE !,"A GLOBAL PACKAGE cannot be sent with any other packages"
QUIT
+20 IF $DATA(^XTMP("XPDT",XPDA))
WRITE " **Cannot have a pre-existing Transport Global**"
SET DIRUT=1
QUIT
+21 WRITE !?10,"will transport the following globals:",!
SET X=0
SET XPDGP=""
+22 FOR
SET X=$ORDER(^XPD(9.6,XPDA,"GLO",X))
if 'X
QUIT
SET Z=$GET(^(X,0))
IF $PIECE(Z,U)]""
SET XPDGP=XPDGP_($PIECE(Z,U,2)="y")_";"_$PIECE(Z,U)_"^"
WRITE ?12,$PIECE(Z,U),!
+23 ;XPDERR is set to quit loop, so no other packages can be added
+24 SET XPDERR=1
SET XPDT=XPDT+1
SET XPDT(XPDT)=XPDA_U_XPDI
SET XPDT("DA",XPDA)=XPDT_U_2
End DoDot:2
QUIT
+25 if $DATA(XPDERR)
QUIT
+26 DO PCK(XPDA,XPDI,,XPDA0)
+27 ;multi-package
+28 if $PIECE(XPDA0,U,3)'=1
QUIT
+29 WRITE " (Multi-Package)"
SET X=0
+30 IF XPDT>1
SET DIRUT=1
WRITE !,"A Master Build must be the first/only package in a transport"
QUIT
+31 FOR
SET X=$ORDER(^XPD(9.6,XPDA,10,X))
if 'X
QUIT
SET Z=$PIECE($GET(^(X,0)),U)
SET Z1=$PIECE($GET(^(0)),U,2)
if Z]""
Begin DoDot:2
+32 NEW XPDA,XPDA0,X
+33 WRITE !?3,Z
SET XPDA=$ORDER(^XPD(9.6,"B",Z,0))
SET XPDA0=$GET(^XPD(9.6,XPDA,0))
+34 IF 'XPDA!(XPDA0="")
WRITE " **Can't find definition in Build file**"
QUIT
+35 IF $DATA(XPDT("DA",XPDA))
WRITE " already listed"
QUIT
+36 DO PCK(XPDA,Z,Z1,XPDA0)
End DoDot:2
+37 ;XPDERR is set to quit loop, so no other packages can be added
SET XPDERR=1
+38 QUIT
End DoDot:1
if $DATA(DIRUT)!$DATA(XPDERR)
QUIT
+39 if 'XPDT!$DATA(DUOUT)
GOTO QUIT
KILL XPDERR
+40 ;XPDH=Header comment, XPDTP=transport method: 1=PM, 0=HF
+41 SET (XPDH,XPDTP)=""
+42 ;XPDH=header comment, will be return from DISP ;p713
+43 FOR
DO DISP
if $DATA(DIRUT)
QUIT
+44 if $DATA(DUOUT)
GOTO QUIT
+45 ;XPDT>1 (more than one package) or $P(XPDA0,U,3) multi-package) can only use HF
+46 IF XPDT=1
IF '$PIECE(XPDA0,U,3)
Begin DoDot:1
+47 SET DIR(0)="SAO^HF:Host File;PM:PackMan"
SET DIR("A")="Transport through (HF)Host File or (PM)PackMan: "
+48 SET DIR("?")="Enter the method of transport for the package(s)."
+49 DO ^DIR
if Y="PM"
SET XPDTP=1
if Y=""
SET XPDH=""
+50 KILL DIR
+51 QUIT
End DoDot:1
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO QUIT
+52 ;single package, no transport method, no header comment
+53 IF XPDT=1
IF 'XPDTP
IF XPDH=""
WRITE !,"No Transport Method selected, will only write Transport Global to ^XTMP."
+54 ;XPDTP = 1-transports using Packman, can't be GP or multiple builds
+55 IF 'XPDTP
IF XPDH]""
DO DEV
if POP
GOTO QUIT
+56 WRITE !!
+57 FOR XPDT=1:1:XPDT
SET XPDA=XPDT(XPDT)
SET XPDNM=$PIECE(XPDA,U,2)
Begin DoDot:1
+58 WRITE !?5,XPDNM,"..."
SET XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")"
+59 ;if using current transport global, run pre-transp routine and quit
+60 IF $PIECE(XPDA,U,3)
SET XPDA=+XPDA
DO PRET
QUIT
+61 ;if package file link then set XPDVER=version number^package name
+62 SET XPDA=+XPDA
SET XPDVER=$SELECT($PIECE(^XPD(9.6,XPDA,0),U,2):$$VER^XPDUTL(XPDNM)_U_$$PKG^XPDUTL(XPDNM),1:"")
+63 ;Increment and set the Build number and set Build version #
+64 SET $PIECE(^XPD(9.6,XPDA,6.3),U)=$GET(^XPD(9.6,XPDA,6.3))+1
SET $PIECE(^XPD(9.6,XPDA,6),U)=$PIECE(XPDT(XPDT),U,6)
+65 KILL ^XTMP("XPDT",XPDA)
+66 ;GLOBAL PACKAGE
+67 IF $DATA(XPDGP)
Begin DoDot:2
+68 ;can't send global package in packman message
+69 IF $GET(XPDTP)
SET XPDERR=1
QUIT
+70 ;verify global package
+71 IF '$$GLOPKG^XPDV(XPDA)
SET XPDERR=1
QUIT
+72 ;get Environment check and Post Install routines
+73 FOR Y="PRE","INIT"
IF $GET(^XPD(9.6,XPDA,Y))]""
SET X=^(Y)
Begin DoDot:3
+74 SET ^XTMP("XPDT",XPDA,Y)=X
SET X=$PIECE(X,U,$LENGTH(X,U))
SET %=$$LOAD^XPDTA(X,"0^")
End DoDot:3
+75 DO BLD^XPDTC
DO PRET
End DoDot:2
SET XPDT=1
QUIT
+76 FOR X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC"
DO @X
if $DATA(XPDERR)
QUIT
+77 if '$DATA(XPDERR)
DO PRET
End DoDot:1
if $DATA(XPDERR)
GOTO ABORT
+78 ;XPDTP - call ^XPDTP to build Packman message
+79 IF $GET(XPDTP)
SET XPDA=+XPDT(XPDT)
DO ^XPDTP
GOTO QUIT
+80 IF $LENGTH(XPDH)
DO GO
GOTO QUIT
+81 ;if no device then just create transport global
+82 WRITE !!
FOR XPDT=1:1:XPDT
WRITE "Transport Global ^XTMP(""XPDT"","_+XPDT(XPDT)_") created for ",$PIECE(XPDT(XPDT),U,2),!
+83 QUIT
DEV NEW FIL,DIR,IOP,X,Y,%ZIS
WRITE !
+1 DO HOME^%ZIS
+2 SET DIR(0)="F^3:245"
SET DIR("A")="Enter a Host File"
SET DIR("?")="Enter a filename and/or path to output package(s)."
SET POP=0
+3 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET POP=1
QUIT
+4 ;if no file, then quit
+5 if Y=""
QUIT
SET FIL=Y
+6 SET DIR(0)="F^3:200"
SET DIR("A")="Header Comment"
SET DIR("?")="Enter a comment between 3 and 200 characters."
SET DIR("B")=XPDH
+7 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET POP=1
QUIT
+8 SET XPDH=Y
+9 SET %ZIS=""
SET %ZIS("HFSNAME")=FIL
SET %ZIS("HFSMODE")="W"
SET IOP="HFS"
SET (XPDSIZ,XPDSIZA)=0
SET XPDSEQ=1
+10 DO ^%ZIS
IF POP
WRITE !!,"**Incorrect Host File name**",!,$CHAR(7)
QUIT
+11 ;write date and comment header
+12 SET XPDHD="KIDS Distribution saved on "_$$HTE^XLFDT($HOROLOG)
+13 USE IO
WRITE $$SUM(XPDHD),!,$$SUM(XPDH),!
+14 ;Send mail to forum of routines in HFS.
SET XPDFMSG=1
+15 ;U IO(0) is to insure I am writing to the terminal
+16 USE IO(0)
QUIT
+17 ;
GO SET I=1
SET Y=""
SET XPDH1="**KIDS**:"
USE IO
+1 ;Global Package, header is different and there is only 1 package
+2 IF $DATA(XPDGP)
WRITE $$SUM("**KIDS**GLOBALS:"_$PIECE(XPDT(1),U,2)_U_XPDGP),!
GOTO GO1
+3 ;write header that maintains package list, keep less than 255 char
+4 FOR
Begin DoDot:1
+5 FOR I=I:1
SET Y=Y_$PIECE(XPDT(I),U,2)_"^"
if $LENGTH(Y)>200!(I=XPDT)
QUIT
End DoDot:1
WRITE $$SUM(XPDH1_Y),!
if I=XPDT
QUIT
SET Y=""
SET I=I+1
SET XPDH1="**KIDS**"
+6 ;after the package list write an extra line feed
GO1 WRITE !
SET XPDSIZA=XPDSIZA+2
+1 NEW XMSUB,XMY,XMTEXT
+2 ;loop thru & write global, don't kill if set to permanent, set in XPDIU
+3 FOR XPDT=1:1:XPDT
SET XPDA=+XPDT(XPDT)
SET XPDNM=$PIECE(XPDT(XPDT),U,2)
DO GW
DO XM
if '$GET(^XTMP("XPDT",XPDA))
KILL ^(XPDA)
+4 WRITE "**END**",!
+5 ;GLOBAL PACKAGE there could only be one package, write globals
+6 IF $DATA(XPDGP)
DO GPW
WRITE "**END**",!
+7 ;we're done with device, close it
+8 WRITE "**END**",!
DO ^%ZISC
+9 WRITE !!,"Package Transported Successfully",!
+10 QUIT
GW ;global write
+1 NEW GR,GCK,GL
+2 SET GCK="^XTMP(""XPDT"","_XPDA
SET GR=GCK_")"
SET GCK=GCK_","
SET GL=$LENGTH(GCK)
+3 ;INSTALL NAME line will mark the beginning of global for all lines until
+4 ;the next INSTALL NAME
+5 WRITE $$SUM("**INSTALL NAME**",1),!,$$SUM(XPDNM),!
+6 FOR
if $DATA(DIRUT)
QUIT
SET GR=$QUERY(@GR)
if GR=""!($EXTRACT(GR,1,GL)'=GCK)
QUIT
WRITE $$SUM($PIECE(GR,GCK,2),1),!,$$SUM(@GR),!
+7 QUIT
XM ;Send HFS checksum message
+1 if '$GET(XPDFMSG)
QUIT
+2 NEW XMTEXT,C,RN,RN2,X,X2
+3 KILL ^TMP($JOB)
+4 SET XMSUB="**KIDS** Checksum for "_XPDNM
SET XMTEXT="^TMP($J)"
+5 IF $GET(^XMB("NETNAME"))["DOMAIN.EXT"
SET XMY("S.A1AE HFS CHKSUM SVR@DOMAIN.EXT")=""
+6 IF '$TEST
SET X=$$GET^XPAR("PKG","XPD PATCH HFS SERVER",1,"Q")
if $LENGTH(X)
SET XMY(X)=""
+7 ;No one to send it to.
IF '$DATA(XMY)
QUIT
+8 SET C=1
SET @XMTEXT@(1,0)="~~1:"_XPDNM
+9 IF XPDT=1
IF $ORDER(XPDT(1))
Begin DoDot:1
+10 SET RN=1
FOR
SET RN=$ORDER(XPDT(RN))
if 'RN
QUIT
SET C=C+1
SET @XMTEXT@(C,0)="~~2:"_$PIECE(XPDT(RN),"^",2)
End DoDot:1
+11 ;Send full RTN node
SET (RN,RN2)=""
+12 FOR
SET RN=$ORDER(^XTMP("XPDT",XPDA,"RTN",RN))
if '$LENGTH(RN)
QUIT
SET X=^(RN)
SET X2=$GET(^(RN,2,0))
Begin DoDot:1
+13 SET C=C+1
SET @XMTEXT@(C,0)="~~3:"_RN_"^"_X_"^"_$PIECE(X2,";",5)
+14 IF RN2=""
IF $EXTRACT(X2,1,3)=" ;;"
SET RN2=$PIECE(X2,"**",1)_"**[Patch List]**"_$PIECE(X2,"**",3)
End DoDot:1
+15 SET C=C+1
SET @XMTEXT@(C,0)="~~4:"_RN2
+16 SET C=C+1
SET @XMTEXT@(C,0)="~~8:"_$GET(^XMB("NETNAME"))
+17 SET C=C+1
SET @XMTEXT@(C,0)="~~9:Save"
+18 SET XMTEXT="^TMP($J,"
+19 DO ^XMD
+20 QUIT
GPW ;global package write
+1 NEW I,G,GR,GCK,GL
+2 WRITE !
+3 FOR I=1:1
SET G=$PIECE(XPDGP,U,I)
if G=""
QUIT
Begin DoDot:1
+4 SET GR="^"_$PIECE(G,";",2)
SET GCK=$SELECT(GR[")":$EXTRACT(GR,1,$LENGTH(GR)-1)_",",1:GR_"(")
SET GL=$LENGTH(GCK)
+5 ;GLOBAL line will mark the beginning of global for all lines until
+6 ;the next GLOBAL
+7 WRITE $$SUM("**GLOBAL**",1),!,$$SUM(GR),!
+8 FOR
if $DATA(DIRUT)
QUIT
SET GR=$QUERY(@GR)
if GR=""!($EXTRACT(GR,1,GL)'=GCK)
QUIT
WRITE $$SUM($PIECE(GR,GCK,2),1),!,$$SUM(@GR),!
End DoDot:1
+9 QUIT
QUIT FOR XPDT=1:1:XPDT
LOCK -^XPD(9.6,+XPDT(XPDT))
+1 QUIT
ABORT WRITE !!,"**TRANSPORT ABORTED**",*7
+1 DO QUIT
+2 FOR XPDT=1:1:XPDT
KILL ^XTMP("XPDT",+XPDT(XPDT))
+3 ;if HF, save file name IO into XPDH
+4 if $LENGTH(XPDH)
SET XPDH=IO
+5 DO ^%ZISC
+6 ;if HF, then delete file
+7 IF $LENGTH(XPDH)
IF $$DEL1^%ZISH(XPDH)
WRITE !,"File: ",XPDH," (Deleted)"
+8 QUIT
+9 ;
PCK(XPDA,XPDNM,XPDREQ,XPDA0) ;XPDA=Build ien, XPDNM=Build name, XPDREQ=Required, XPDA0=Y(0) ^XPD(9.6,XPDA,0)
+1 NEW Y,Z
+2 SET XPDT=XPDT+1
SET XPDT(XPDT)=XPDA_U_XPDNM
SET XPDT("DA",XPDA)=XPDT_"^"_$PIECE(XPDA0,U,3)
+3 ;get TEST# and increment ;p713
+4 SET Z=+$GET(^XPD(9.6,XPDA,6))
SET Z=Z+1
SET $PIECE(XPDT(XPDT),U,6)=Z
+5 if '$GET(XPDREQ)
SET XPDREQ=0
+6 SET $PIECE(XPDT(XPDT),U,4)=XPDREQ
+7 if '$DATA(^XTMP("XPDT",XPDA))
QUIT
SET Y=$GET(^(XPDA))
+8 WRITE " **Transport Global exists**"
+9 ;Y=1 if TG is permanent
+10 IF Y
SET $PIECE(XPDT(XPDT),U,3)=1
QUIT
+11 ;ask if they want to use TG
+12 DO ^DIR
SET $PIECE(XPDT(XPDT),U,3)=Y
+13 QUIT
+14 ;
SUM(X,Z) ;X=string to write, Z 0=don't check size
+1 SET XPDSIZA=XPDSIZA+$LENGTH(X)+2
+2 QUIT X
+3 ;
PAH(XPDA) ;check for PATCH APPLICATION HISTORY in Package file
+1 NEW Y,Z
+2 SET Y=^XPD(9.6,XPDA,0)
SET Z=$$VER^XPDUTL($PIECE(Y,U))
+3 ;Single Package, Version multiple, PAH multiple
+4 IF $PIECE(Y,U,3)=0
IF $DATA(^DIC(9.4,+$PIECE(Y,U,2),22))
IF Z
SET Z=$ORDER(^(22,"B",Z,0))
IF Z
IF $ORDER(^DIC(9.4,+$PIECE(Y,U,2),22,Z,"PAH",0))
QUIT 1
+5 QUIT 0
+6 ;
PRET ;Pre-Transport Routine
+1 NEW Y,Z
+2 SET Y=$GET(^XPD(9.6,XPDA,"PRET"))
if Y=""
QUIT
+3 IF '$$RTN^XPDV(Y,.Z)
WRITE !!,"Pre-Transportation Routine ",Y,Z,*7
QUIT
+4 SET Y=$SELECT(Y["^":Y,1:"^"_Y)
WRITE !,"Running Pre-Transportation Routine ",Y
+5 DO @Y
+6 QUIT
+7 ;
DISP ;display packages, RETURN: DIRUT ;p713 ;p750
+1 NEW DIR,X,Y
+2 WRITE !!,"ORDER PACKAGE",?45,"VERSION #",!
+3 FOR XPDT=1:1:XPDT
WRITE ?2,XPDT,?9,$PIECE(XPDT(XPDT),U,2),?47," ",$PIECE(XPDT(XPDT),U,6)
Begin DoDot:1
+4 if $PIECE(XPDT(XPDT),U,3)
WRITE ?25," **will use current Transport Global**"
+5 ;check if New and single package, has Package File Link, Package App. History
+6 IF $PIECE(XPDT(XPDT),U,2)["*"!'$$PAH(+XPDT(XPDT))!($PIECE(XPDT(XPDT),U,5))
QUIT
+7 SET DIR(0)="Y"
SET DIR("A")="Send the PATCH APPLICATION HISTORY from the PACKAGE file"
SET DIR("B")="YES"
+8 WRITE !!
DO ^DIR
IF 'Y
SET $PIECE(XPDT(XPDT),U,5)=1
+9 QUIT
End DoDot:1
WRITE !
+10 SET DIR(0)="SA^C:Continue;E:Edit Version #;Q:Quit"
SET DIR("A")="Do you want to (C)ontinue, (E)dit Version #, (Q)uit: "
SET DIR("B")="C"
+11 WRITE !
DO ^DIR
+12 IF Y="C"
Begin DoDot:1
+13 NEW DIC,I,J,Y
+14 SET I=XPDT
SET J=""
+15 FOR I=1:1:XPDT
SET J=J_$PIECE(XPDT(I),U,2)_" v"_$PIECE(XPDT(I),U,6)_$SELECT(I<XPDT:", ",1:"")
+16 SET XPDH=J
+17 QUIT
End DoDot:1
SET DIRUT=1
QUIT
+18 IF $DATA(DIRUT)!(Y="Q")
SET DIRUT=1
SET DUOUT=1
QUIT
+19 ;edit of Version # ;p713
+20 FOR
Begin DoDot:1
+21 KILL DIR
+22 SET DIR(0)="NOA^1:"_XPDT
SET DIR("A")="Enter the ORDER number or <CR> when done: "
+23 WRITE !
DO ^DIR
IF $DATA(DIRUT)!(Y="")
QUIT
+24 SET Z=Y
SET DIR("B")=$PIECE(XPDT(Z),U,6)
SET DIR(0)="NA^1:9999"
SET DIR("A")="Version #: "
+25 DO ^DIR
IF Y
SET $PIECE(XPDT(Z),U,6)=Y
+26 QUIT
End DoDot:1
IF $DATA(DIRUT)
KILL DIRUT
QUIT
+27 QUIT
+28 ;
