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,1018**;Jul 10, 1995;Build 8
;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 on system
;XPDT("DA",ien)=seq #
;XPDVER=version number^package name
;XPDGP=flag;global^flag;global^... flag=1 replace global at site
N DIR,DIRUT,I,POP,XPD,XPDA,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:'XPDT XPD="Another Package Name: "
.;XPDI=name^1=use current transport global
.S XPDI=$P(Y(0),U)_"^"
.I $D(XPDT("DA",XPDA)) W " ",$P(Y(0),U)," already listed",! Q
.;if type is Global Package, set DIRUT if there is other packages
.I $P(Y(0),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
.Q:$D(XPDERR)
.D PCK(XPDA,XPDI)
.;multi-package
.Q:$P(Y(0),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,X
..S Z=$P(^XPD(9.6,Z,0),U,1) ;XU*8.0*1018 - IHS/OIT/FBD - 5/16/2011 - ADDED LINE TO CORRECT MULTIPACKAGE MALFUNCTIONS
..W !?3,Z S XPDA=$O(^XPD(9.6,"B",Z,0))
..I 'XPDA W " **Can't find definition in Build file**" Q
..I $D(XPDT("DA",XPDA)) W " already listed" Q
..D PCK(XPDA,Z,Z1)
.S XPDERR=1 ;XPDERR is set to quit loop, so no other packages can be added
.Q
G:'XPDT!$D(DIRUT) QUIT K XPDERR
W !!,"ORDER PACKAGE",!
F XPDT=1:1:XPDT S Y=$P(XPDT(XPDT),U,2) W ?2,XPDT,?7,Y D W !
.W:$P(XPDT(XPDT),U,3) " **will use current Transport Global**"
.;check if New Version and single package, has Package File Link, Package App. History
.Q:Y["*"!'$$PAH(+XPDT(XPDT))
.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
S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES",XPDH=""
W !! D ^DIR G:$D(DIRUT)!'Y QUIT K DIR
I $G(XPDTP),XPDT>1 W !!,"You cannot send multiple Builds through PackMan."
S DIR(0)="SAO^HF:Host File"_$S(XPDT=1:";PM:PackMan",1:"")
S DIR("A")="Transport through (HF)Host File"_$S(XPDT=1:" or (PM)PackMan: ",1:": ")
S DIR("?")="Enter the method of transport for the package(s)."
D ^DIR G:$D(DTOUT)!$D(DUOUT) QUIT K DIR
I Y="" W !,"No Transport Method selected, will only write Transport Global to ^XTMP." S XPDH=""
;XPDTP = transports using Packman
S:Y="PM" XPDTP=1
I $D(XPDGP),Y'="HF" W !,"**Global Package can only be sent with a Host File, Transport ABORTED**" Q
I Y="HF" 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:"")
.;Inc the Build number
.S $P(^XPD(9.6,XPDA,6.3),U)=$G(^XPD(9.6,XPDA,6.3))+1
.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:80",DIR("A")="Header Comment",DIR("?")="Enter a comment between 3 and 80 characters."
D ^DIR I $D(DIRUT) S POP=1 Q
S XPDH=Y,%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"))["VA.GOV" S XMY("S.A1AE HFS CHKSUM SVR@FORUM.VA.GOV")=""
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) ;XPDA=Build ien, XPDNM=Build name, XPDREQ=Required
N Y
S XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDNM,XPDT("DA",XPDA)=XPDT
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
;
;
;FROM DEV
;if MSM and HFS file is on device A or B, then get size for floppy disk
;XPDSIZ=disk size, XPDSIZA=accummulated size,XPDSEQ=disk sequence number
I ^%ZOSF("OS")["MSM",FIL?1(1"A",1"B")1":"1.E D Q:POP
.S DIR(0)="N^0:5000",DIR("A")="Size of Diskette (1K blocks)",DIR("B")=1400,DIR("?")="Enter the number of 1K blocks which each diskette will hold, 0 means unlimited space"
.D ^DIR I $D(DIRUT) S POP=1 Q
.S XPDSIZ=$S(Y:Y*1024,1:0)
;FROM SUM
;ask for next disk
;this code is for MSM system only
I $G(Z),XPDSIZ,XPDSIZ-XPDSIZA<1024 D
.;write continue flag at end of this file
.W "**CONTINUE**",!,"**END**",!
.;should call %ZIS HFS utilities to close and open file
.X "C IO" U IO(0)
.N DIR,G,GR,GCK,GL,I,X,Y
.W !!,"Diskette #",XPDSEQ," is full."
.S DIR(0)="E",DIR("A")="Insert the next diskette and Press the return key",DIR("?")="The current diskette is full, insert a new diskette to continue."
.;$D(DIRUT)=the user aborted the distribution
.D ^DIR I $D(DIRUT) D ABORT Q
.W ! S XPDSEQ=XPDSEQ+1,XPDSIZA=0
.;MSM specific code to open HFS
.X "O IO:IOPAR" U IO
.W $$SUM("Continuation #"_XPDSEQ_" of "_XPDHD),!,$$SUM(XPDH),!,$$SUM("**SEQ**:"_XPDSEQ),!!
.S XPDSIZA=XPDSIZA+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,1018**;Jul 10, 1995;Build 8
+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 on system
+2 ;XPDT("DA",ien)=seq #
+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,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 IF 'XPDT
SET XPD="Another Package Name: "
+12 ;XPDI=name^1=use current transport global
+13 SET XPDI=$PIECE(Y(0),U)_"^"
+14 IF $DATA(XPDT("DA",XPDA))
WRITE " ",$PIECE(Y(0),U)," already listed",!
QUIT
+15 ;if type is Global Package, set DIRUT if there is other packages
+16 IF $PIECE(Y(0),U,3)=2
WRITE " GLOBAL PACKAGE"
Begin DoDot:2
+17 ;if there is already a package in distribution, abort
+18 IF XPDT
SET DIRUT=1
WRITE !,"A GLOBAL PACKAGE cannot be sent with any other packages"
QUIT
+19 IF $DATA(^XTMP("XPDT",XPDA))
WRITE " **Cannot have a pre-existing Transport Global**"
SET DIRUT=1
QUIT
+20 WRITE !?10,"will transport the following globals:",!
SET X=0
SET XPDGP=""
+21 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),!
+22 ;XPDERR is set to quit loop, so no other packages can be added
+23 SET XPDERR=1
SET XPDT=XPDT+1
SET XPDT(XPDT)=XPDA_U_XPDI
SET XPDT("DA",XPDA)=XPDT
End DoDot:2
QUIT
+24 IF $DATA(XPDERR)
QUIT
+25 DO PCK(XPDA,XPDI)
+26 ;multi-package
+27 IF $PIECE(Y(0),U,3)'=1
QUIT
+28 WRITE " (Multi-Package)"
SET X=0
+29 IF XPDT>1
SET DIRUT=1
WRITE !,"A Master Build must be the first/only package in a transport"
QUIT
+30 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
+31 NEW XPDA,X
+32 ;XU*8.0*1018 - IHS/OIT/FBD - 5/16/2011 - ADDED LINE TO CORRECT MULTIPACKAGE MALFUNCTIONS
SET Z=$PIECE(^XPD(9.6,Z,0),U,1)
+33 WRITE !?3,Z
SET XPDA=$ORDER(^XPD(9.6,"B",Z,0))
+34 IF 'XPDA
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)
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(DIRUT)
GOTO QUIT
KILL XPDERR
+40 WRITE !!,"ORDER PACKAGE",!
+41 FOR XPDT=1:1:XPDT
SET Y=$PIECE(XPDT(XPDT),U,2)
WRITE ?2,XPDT,?7,Y
Begin DoDot:1
+42 IF $PIECE(XPDT(XPDT),U,3)
WRITE " **will use current Transport Global**"
+43 ;check if New Version and single package, has Package File Link, Package App. History
+44 IF Y["*"!'$$PAH(+XPDT(XPDT))
QUIT
+45 SET DIR(0)="Y"
SET DIR("A")="Send the PATCH APPLICATION HISTORY from the PACKAGE file"
SET DIR("B")="YES"
+46 WRITE !!
DO ^DIR
IF 'Y
SET $PIECE(XPDT(XPDT),U,5)=1
End DoDot:1
WRITE !
+47 SET DIR(0)="Y"
SET DIR("A")="OK to continue"
SET DIR("B")="YES"
SET XPDH=""
+48 WRITE !!
DO ^DIR
IF $DATA(DIRUT)!'Y
GOTO QUIT
KILL DIR
+49 IF $GET(XPDTP)
IF XPDT>1
WRITE !!,"You cannot send multiple Builds through PackMan."
+50 SET DIR(0)="SAO^HF:Host File"_$SELECT(XPDT=1:";PM:PackMan",1:"")
+51 SET DIR("A")="Transport through (HF)Host File"_$SELECT(XPDT=1:" or (PM)PackMan: ",1:": ")
+52 SET DIR("?")="Enter the method of transport for the package(s)."
+53 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO QUIT
KILL DIR
+54 IF Y=""
WRITE !,"No Transport Method selected, will only write Transport Global to ^XTMP."
SET XPDH=""
+55 ;XPDTP = transports using Packman
+56 IF Y="PM"
SET XPDTP=1
+57 IF $DATA(XPDGP)
IF Y'="HF"
WRITE !,"**Global Package can only be sent with a Host File, Transport ABORTED**"
QUIT
+58 IF Y="HF"
DO DEV
IF POP
GOTO QUIT
+59 WRITE !!
+60 FOR XPDT=1:1:XPDT
SET XPDA=XPDT(XPDT)
SET XPDNM=$PIECE(XPDA,U,2)
Begin DoDot:1
+61 WRITE !?5,XPDNM,"..."
SET XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")"
+62 ;if using current transport global, run pre-transp routine and quit
+63 IF $PIECE(XPDA,U,3)
SET XPDA=+XPDA
DO PRET
QUIT
+64 ;if package file link then set XPDVER=version number^package name
+65 SET XPDA=+XPDA
SET XPDVER=$SELECT($PIECE(^XPD(9.6,XPDA,0),U,2):$$VER^XPDUTL(XPDNM)_U_$$PKG^XPDUTL(XPDNM),1:"")
+66 ;Inc the Build number
+67 SET $PIECE(^XPD(9.6,XPDA,6.3),U)=$GET(^XPD(9.6,XPDA,6.3))+1
+68 KILL ^XTMP("XPDT",XPDA)
+69 ;GLOBAL PACKAGE
+70 IF $DATA(XPDGP)
Begin DoDot:2
+71 ;can't send global package in packman message
+72 IF $GET(XPDTP)
SET XPDERR=1
QUIT
+73 ;verify global package
+74 IF '$$GLOPKG^XPDV(XPDA)
SET XPDERR=1
QUIT
+75 ;get Environment check and Post Install routines
+76 FOR Y="PRE","INIT"
IF $GET(^XPD(9.6,XPDA,Y))]""
SET X=^(Y)
Begin DoDot:3
+77 SET ^XTMP("XPDT",XPDA,Y)=X
SET X=$PIECE(X,U,$LENGTH(X,U))
SET %=$$LOAD^XPDTA(X,"0^")
End DoDot:3
+78 DO BLD^XPDTC
DO PRET
End DoDot:2
SET XPDT=1
QUIT
+79 FOR X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC"
DO @X
IF $DATA(XPDERR)
QUIT
+80 IF '$DATA(XPDERR)
DO PRET
End DoDot:1
IF $DATA(XPDERR)
GOTO ABORT
+81 ;XPDTP - call ^XPDTP to build Packman message
+82 IF $GET(XPDTP)
SET XPDA=+XPDT(XPDT)
DO ^XPDTP
GOTO QUIT
+83 IF $LENGTH(XPDH)
DO GO
GOTO QUIT
+84 ;if no device then just create transport global
+85 WRITE !!
FOR XPDT=1:1:XPDT
WRITE "Transport Global ^XTMP(""XPDT"","_+XPDT(XPDT)_") created for ",$PIECE(XPDT(XPDT),U,2),!
+86 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:80"
SET DIR("A")="Header Comment"
SET DIR("?")="Enter a comment between 3 and 80 characters."
+7 DO ^DIR
IF $DATA(DIRUT)
SET POP=1
QUIT
+8 SET XPDH=Y
SET %ZIS=""
SET %ZIS("HFSNAME")=FIL
SET %ZIS("HFSMODE")="W"
SET IOP="HFS"
SET (XPDSIZ,XPDSIZA)=0
SET XPDSEQ=1
+9 DO ^%ZIS
IF POP
WRITE !!,"**Incorrect Host File name**",!,$CHAR(7)
QUIT
+10 ;write date and comment header
+11 SET XPDHD="KIDS Distribution saved on "_$$HTE^XLFDT($HOROLOG)
+12 USE IO
WRITE $$SUM(XPDHD),!,$$SUM(XPDH),!
+13 ;Send mail to forum of routines in HFS.
SET XPDFMSG=1
+14 ;U IO(0) is to insure I am writing to the terminal
+15 USE IO(0)
QUIT
+16 ;
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"))["VA.GOV"
SET XMY("S.A1AE HFS CHKSUM SVR@FORUM.VA.GOV")=""
+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) ;XPDA=Build ien, XPDNM=Build name, XPDREQ=Required
+1 NEW Y
+2 SET XPDT=XPDT+1
SET XPDT(XPDT)=XPDA_U_XPDNM
SET XPDT("DA",XPDA)=XPDT
+3 IF '$GET(XPDREQ)
SET XPDREQ=0
+4 SET $PIECE(XPDT(XPDT),U,4)=XPDREQ
+5 IF '$DATA(^XTMP("XPDT",XPDA))
QUIT
SET Y=$GET(^(XPDA))
+6 WRITE " **Transport Global exists**"
+7 ;Y=1 if TG is permanent
+8 IF Y
SET $PIECE(XPDT(XPDT),U,3)=1
QUIT
+9 ;ask if they want to use TG
+10 DO ^DIR
SET $PIECE(XPDT(XPDT),U,3)=Y
+11 QUIT
+12 ;
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
QUIT
+6 ;
+7 ;
+8 ;FROM DEV
+9 ;if MSM and HFS file is on device A or B, then get size for floppy disk
+10 ;XPDSIZ=disk size, XPDSIZA=accummulated size,XPDSEQ=disk sequence number
+11 IF ^%ZOSF("OS")["MSM"
IF FIL?1(1"A",1"B")1":"1.E
Begin DoDot:1
+12 SET DIR(0)="N^0:5000"
SET DIR("A")="Size of Diskette (1K blocks)"
SET DIR("B")=1400
SET DIR("?")="Enter the number of 1K blocks which each diskette will hold, 0 means unlimited space"
+13 DO ^DIR
IF $DATA(DIRUT)
SET POP=1
QUIT
+14 SET XPDSIZ=$SELECT(Y:Y*1024,1:0)
End DoDot:1
IF POP
QUIT
+15 ;FROM SUM
+16 ;ask for next disk
+17 ;this code is for MSM system only
+18 IF $GET(Z)
IF XPDSIZ
IF XPDSIZ-XPDSIZA<1024
Begin DoDot:1
+19 ;write continue flag at end of this file
+20 WRITE "**CONTINUE**",!,"**END**",!
+21 ;should call %ZIS HFS utilities to close and open file
+22 XECUTE "C IO"
USE IO(0)
+23 NEW DIR,G,GR,GCK,GL,I,X,Y
+24 WRITE !!,"Diskette #",XPDSEQ," is full."
+25 SET DIR(0)="E"
SET DIR("A")="Insert the next diskette and Press the return key"
SET DIR("?")="The current diskette is full, insert a new diskette to continue."
+26 ;$D(DIRUT)=the user aborted the distribution
+27 DO ^DIR
IF $DATA(DIRUT)
DO ABORT
QUIT
+28 WRITE !
SET XPDSEQ=XPDSEQ+1
SET XPDSIZA=0
+29 ;MSM specific code to open HFS
+30 XECUTE "O IO:IOPAR"
USE IO
+31 WRITE $$SUM("Continuation #"_XPDSEQ_" of "_XPDHD),!,$$SUM(XPDH),!,$$SUM("**SEQ**:"_XPDSEQ),!!
+32 SET XPDSIZA=XPDSIZA+2
End DoDot:1
