XPDT ;SFISC/RSD - Transport a package ;06/21/2006
 ;;8.0;KERNEL;**2,10,28,41,44,51,58,66,68,85,100,108,393**;Jul 10, 1995;Build 12
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 XPDFMSG,X,Y,Z
 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
 ..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**"
 S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="NO",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 charaters."
 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 begining 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,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="" ;Send full RTN node
 F  S RN=$O(^XTMP("XPDT",XPDA,"RTN",RN)) Q:'$L(RN)  S X=^(RN),X2=$G(^(RN,2,0)),C=C+1,@XMTEXT@(C,0)="~~3:"_RN_"^"_X_"^"_$P(X2,";",5)
 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 begining 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))
 D ^%ZISC
 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 permanet
 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
 ;
PRET ;Pre-Transport Routine
 N Y S Y=$G(^XPD(9.6,XPDA,"PRET")) Q:Y=""
 I '$$RTN^XPDV(Y) W !!,"Pre-Transportation Routine DOESN'T EXIST!!",*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