XPDIB ;SFISC/RSD - Backup installed Package ; Mar 20, 2023@14:49:13
;;8.0;KERNEL;**10,58,108,178,713,738,750,755,768,778,785,796**;Jul 10, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
EN ;
;p713 - added support to create Build from Transport Global to create a backup
N DIR,DIRUT,DUOUT,XPDA,XPDBLD,XPDTCNT,XPDH,XPDH1,XPDHD,XPDFMSG,XPDI,XPDIDVT,XPDMP,XPDNM,XPDPKG,XPDQUIT,XPDST
N XPDT,XPDTB,XPDSBJ,XPDTYP,XPDVER,X,Y,Y0,%,XPDIB
;S %="I '$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%)
S %="I $E($P(^(0),U),$L($P(^(0),U)))'=""b"",'$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%) ;p755 can't backup a backup
Q:'XPDST!$D(XPDQUIT)
;XPDST=starting install ien, XPDNM=install name, XPDBLD=build #, XPDPKG=package file pointer, XPDT(#)=Install file #^Install file name XPDIB=flag to not write errors
S XPDIB=1 D BLDV(XPDST)
S XPDTCNT=$O(XPDT("DA"),-1) ;XPDTCNT=# of installs
I XPDTYP>1 W !!,"This is a Global Package and cannot be backed up.",!! Q ;p738
;multi-package reset name to include all builds
I XPDTCNT>1 S XPDNM="" F XPDT=1:1:XPDTCNT S XPDNM=XPDNM_$P(XPDT(XPDT),U,2)_$S(XPDT'=XPDTCNT:", ",1:"")
S DIR(0)="F^3:65",DIR("A")="Subject"
S DIR("?")="characters and must not contain embedded up-arrows."
S DIR("?",1)="Enter the subject for this Backup Message"
S DIR("?",2)="This response must have at least 3 characters and no more than 63"
S DIR("B")=$E(("Backup of "_XPDNM_" on "_$$FMTE^XLFDT(DT)),1,63)
W ! D ^DIR I $D(DIRUT) G QUIT
S XPDSBJ=Y
K DIR
;Build or Routines
S DIR(0)="S^B:Build (including Routines);R:Routines Only",DIR("A")="Backup Type",DIR("B")="B"
S DIR("?")="Backup the entire Build(routines, files, options, protocols, templates, etc.) or just the Routines." ;p738
S DIR("??")="^D HELP^XPDIB" ;p750
D ^DIR G:$D(DIRUT) QUIT
;R=routine Packman msg
I Y="R" D ROUTINE G QUIT
;XPDTCNT: 1=single, >1=multi-package ;p738
I XPDTCNT=1 S (XPDT,XPDTB)=1,XPDA=$$BLD(XPDST),XPDNM=$P(XPDTB(1),U,2) D PM(XPDA),DELBLD(XPDA) G QUIT ;p778 delete backup build
I XPDTCNT>1 D G QUIT
. N XPDSEQ,XPDSIZ,XPDSIZA,POP ;used in GO^XPDT
. S XPDH=XPDSBJ ;XPDH is HF header needed in DEV^XPDT
. D DEV^XPDT Q:POP
. S XPDTB=0
. ;loop thru installs, XPDT(#)=install file #^name, XPDTB(#)=build file #^name
. F XPDT=1:1:XPDTCNT S XPDTB=XPDTB+1,XPDA=+XPDT(XPDT),XPDA=$$BLD(XPDA,XPDST) ;p738
. ;move XPDTB to XPDT
. K XPDT M XPDT=XPDTB
. S XPDFMSG=0 ;open Host File, XPDFMSG=1 is flag to send HF to Forum
. D GO^XPDT ;write ^XTMP("XPDT" to HF
. ;loop thru backup builds and delete the builds ;p778
. F XPDT=1:1:XPDTCNT S XPDA=+XPDT(XPDT) D DELBLD(XPDA)
. Q
Q
BLD(XPDST,XPDMP) ;XPDST=Install #,XPDMP=master build or first Install # of multi-package; returns XPDA=new Build #
N XPDA,XPDBLD,XPD,XPDERR,XPDFILE,XPDFL,XPDFLD,XPDGREF,XPDI,XPDNM,XPDOLDA,XPDREST,I,J,X,Y,Y0
N XPDSD,XPDSUBDD
D BLDV(XPDST)
;create new build, add "b" to mark as backup & change ^XTMP(
S XPDI=XPDNM,XPDNM=XPDNM_"b",$P(^XTMP("XPDI",XPDST,"BLD",XPDBLD,0),U)=XPDNM
;$$BLD^XPDIP needs: XPDA, XPDBLD, XPDNM, XPDPKG
S XPDA=XPDST,XPDA=$$BLD^XPDIP(XPDBLD) Q:'XPDA 0
;reset ^XTMP back to original value
S $P(^XTMP("XPDI",XPDST,"BLD",XPDBLD,0),U)=XPDI,XPDTB(XPDTB)=XPDA_"^"_XPDNM
;change TRACK NATIONALLY(5)=no, ALPHA/BETA TESTING(20),INSTALLATION MSG(21),ADDRESS(22),Build number(63)
S %=XPDA_",",XPD(9.6,%,5)="n",XPD(9.6,%,20)="n",XPD(9.6,%,21)="n",XPD(9.6,%,22)="n",XPD(9.6,%,63)=0
S XPD(9.6,%,3)="XPDI",XPDI(1,0)=XPDSBJ,XPDI(2,0)=" " ;DESCRIPTION(3)
;add warning msg and file Description
D WARN("XPDI",3),FILE^DIE("","XPD")
;delete multiples: REQUIRED BUILD(11), PACKAGE NAMESPACE(23), INSTALL QUESTIONS(50), XPFn(51.01-51.13), TEST/SEQ/TRANS(61-62)
K ^XPD(9.6,XPDA,"REQB"),^("ABNS"),^("QUES"),^("QDEF"),^(6)
;Restore Routine ;p768
I $G(^XPD(9.6,XPDA,"REST"))]"" M XPDREST=^XTMP("XPDI",XPDST,"REST")
;delete PRE-T(900), ENVIR(913), POST(914), PRE-IN(916), DELETE routine, RESTORE(917)
K ^XPD(9.6,XPDA,"PRET"),^("PRE"),^("INIT"),^("INI"),^("INID"),^("REST")
;scan BUILD COMPONENTS(7) and reset actions
S XPDFILE=0
F S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)),XPDOLDA=0 Q:'XPDFILE D
. F S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)) D
.. S Y=$P(Y0,U,3) ; action
.. I XPDFILE=19!(XPDFILE=101),Y>1 D:Y'=3 DELKRN(Y0) Q ;link=2,attach=4,disable=5:delete component;merge=3:leave as merge ;p778
.. D KRN(XPDFILE,Y0)
.. Q
. Q
;scan FILE(#6) ^XPD(file#,222)=update DD^Security^f=full,p=partial DD^^resolve pointers^data list^data comes^site data^may override
S XPDFILE=0
F S XPDFILE=$O(^XPD(9.6,XPDA,4,XPDFILE)) Q:'XPDFILE S XPDFL=$G(^(XPDFILE,222)) D
. I $P(XPDFL,U,3)="f" D Q ;full DD
.. I '$D(^DD(XPDFILE)) D DELF(XPDFILE) Q ;delete if new
.. ;can't backup data in file, set to 'no', kill 'select data screen' p738
.. I $P(XPDFL,U,7)="y" S $P(XPDFL,U,7)="n",^XPD(9.6,XPDA,4,XPDFILE,222)=XPDFL K ^(223)
.. Q
. ;Partial DD, loop thru subDD (XPDSUBDD) to find the fields (XPDFLD). subDD with no fields=send all fields.
. S (XPDSD,XPDSUBDD)=0
. F S XPDSUBDD=$O(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD)),XPDFLD=0 Q:'XPDSUBDD D
.. I $O(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,0)) D Q ;fields are specified
... F S XPDFLD=$O(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,XPDFLD)) Q:'XPDFLD D FLD(XPDSUBDD,XPDFLD) ;loop thru fields
... D:'$O(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,0)) DEL(XPDFILE,XPDSUBDD) ;if all fields were removed, remove subDD
... Q
.. D:'($D(^DD(XPDSUBDD,0))#10) DEL(XPDFILE,XPDSUBDD) ;fields not specified & subDD is new - remove subDD
.. Q
. D:'$O(^XPD(9.6,XPDA,4,XPDFILE,2,0)) DEL(XPDFILE) ;if all subDDs removed, remove file ;p768
. Q
;kill transport global before we rebuild it
K ^XTMP("XPDT",XPDA)
;XPDFREF is a documented variable for use in PRE-TRANSPORTATION routine
S XPDVER="",XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")"
;from XPDT, transport build
F X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC" D @X ;p755 don't check for errors $D(XPDERR)
;Load RESTORE routine ;p768
I $D(XPDREST) D
. S I=+$O(^XTMP("XPDT",XPDA,"BLD",0)) S:I ^XTMP("XPDT",XPDA,"BLD",I,"INIT")=XPDREST ;save RESTORE as POST-INIT in Build
. S ^XTMP("XPDT",XPDA,"INIT")=XPDREST,Y=$P(XPDREST,"("),Y=$P(Y,U,$L(Y,U)) Q:$D(^("RTN",Y))
. M ^XTMP("XPDT",XPDA,"RTN",Y)=XPDREST(Y) ;save RESTORE routine
. ;^XTMP("XPDT",XPDA,"RTN",Y)=action^ien in Build^checksum
. S X="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",Y))),^XTMP("XPDT",XPDA,"RTN",Y)="0^^"_X
. ;update count node
. S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
. Q
Q XPDA
;
BLDV(XPDA) ;variable setup for BLD, XPDA=Install #
N Y0
;XPDNM=install name, XPDBLD=build #, Y0=zero node of build, XPDPKG=package file name
S XPDBLD=+$O(^XTMP("XPDI",XPDA,"BLD",0)),Y0=$G(^(XPDBLD,0)),XPDNM=$P(Y0,U),XPDPKG=$P(Y0,U,2),XPDTYP=+$P(Y0,U,3)
S:XPDPKG]"" XPDPKG=$$LKPKG^XPDUTL(XPDPKG) ;XPDPKG=package file #
Q
;XPDTP to build Packman message
PM(XPDA) ;build MailMan message
N DIFROM,XCNP,DIF,XMSUB,XMDUZ,XMDISPI,XMZ
S DIFROM=1,XMDUZ=+DUZ,XMSUB=XPDSBJ ;p738
W !!," **This Backup mail message should be sent to a Mail Group. This will allow" ;p768
W !," anyone in the Mail Group to back out the changes.**"
K ^TMP("XMP",$J) ;create message text for Packman
D WARN("^TMP(""XMP"",$J)",1),KD^XPDTP
Q:$D(DTOUT)!$D(DUOUT)
W !!,"Message sent",!
Q
;
ROUTINE ;Packman msg
N XCNP,DIF,XMSUB,XMDUZ,XMDISPI,XMZ
S XMSUB=XPDSBJ_". Routines Only",XMDUZ=+DUZ
D XMZ^XMA2 I XMZ<1 D QUIT^XPDI1(XPDST) Q
S Y=$$NOW^XLFDT,%=$$DOW^XLFDT(Y),Y=$$FMTE^XLFDT(Y,2)
S X="PACKMAN BACKUP Created on "_%_", "_$P(Y,"@")_" at "_$P(Y,"@",2)
I $D(^VA(200,DUZ,0)) S X=X_" by "_$P(^(0),U)_" "
S:$D(^XMB("NAME")) X=X_"at "_$P(^("NAME"),U)_" "
S ^XMB(3.9,XMZ,2,0)="^3.92A^^^"_DT,^(1,0)="$TXT "_X,XCNP=1
S XPDT=0
F S XPDT=$O(XPDT(XPDT)) Q:'XPDT D
. S XPDA=+XPDT(XPDT),XPDNM=$P(XPDT(XPDT),U,2),X=""
. I '$D(^XTMP("XPDI",XPDA,"RTN")) W !,"No routines for ",XPDNM,! Q
. W !,"Loading Routines for ",XPDNM
. F S X=$O(^XTMP("XPDI",XPDA,"RTN",X)) Q:X="" D W "."
.. N %N,DIF
.. X ^%ZOSF("TEST") E W !,X,?10,"Doesn't Exist" Q ;p713
.. S XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)="$ROU "_X_" (PACKMAN_BACKUP)",DIF="^XMB(3.9,XMZ,2,"
.. X ^%ZOSF("LOAD")
.. S $P(^XMB(3.9,XMZ,2,0),U,3,4)=XCNP_U_XCNP,^(XCNP,0)="$END ROU "_X_" (PACKMAN-BACKUP)"
.. Q
. Q
D EN3^XMD
Q
;
KRN(FILE,XPDY) ;FILE=file #, XPDY=^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA,0)
N DA,FGR,X
S X=$P(XPDY,U)
;$P(XPDY,U,2) is file # for FileMan templates, reset name in XPDY before getting DA
S:$P(XPDY,U,2) $P(XPDY,U)=$P(XPDY," FILE #") ;p785
;Routine file, just check if routine exists, don't call FILE or ENTRY
I FILE=9.8 S DA=($T(^@X)]"") ;p796
E S FGR=$$FILE^XPDV(FILE),DA=$$ENTRY^XPDV(XPDY) ;DA=ien or 0 if doesn't exists
;If X exists, set to 0 - send, else set to 1 - delete
S $P(XPDY,U,3)='DA
;save component
S ^XPD(9.6,XPDA,"KRN",FILE,"NM",XPDOLDA,0)=XPDY ;p778
Q
;
DELKRN(XPDY) ;delete BUILD COMPONENTS(7) & "B" index for XPDY ;p778
K ^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA,0),^XPD(9.6,XPDA,"KRN",XPDFILE,"NM","B",$P(XPDY,U),XPDOLDA)
Q
;
FLD(DD,FIELD) ;check FIELD exists
D:'($D(^DD(DD,FIELD,0))#10) DEL(XPDFILE,DD,FIELD) ;field is new, delete
Q
;
DEL(FILE,SUBDD,FIELD) ;deletes partials: FILE=file#, SUBDD=sub dictionary#, FIELD=field#, XPDA=ien in Build file
I $G(FIELD) K ^XPD(9.6,XPDA,4,FILE,2,SUBDD,1,FIELD),^XPD(9.6,XPDA,4,"APDD",FILE,SUBDD,FIELD) Q ;delete FIELD & index
I $G(SUBDD) K ^XPD(9.6,XPDA,4,FILE,2,SUBDD),^XPD(9.6,XPDA,4,"APDD",FILE,SUBDD) Q ;delete SUBDD & index
I $G(FILE) K ^XPD(9.6,XPDA,4,FILE),^XPD(9.6,XPDA,4,"APDD",FILE),^XPD(9.6,XPDA,4,"B",FILE) ;delete FILE & index
Q
;
DELF(FILE) ;delete full file DD
N DIK,DA
S DIK="^XPD(9.6,"_XPDA_",4,",DA=FILE,DA(1)=XPDA
D ^DIK
Q
;
DELBLD(DA) ;delete backup build ;p778
Q:'$G(DA)
N DIK
S DIK="^XPD(9.6,"
D ^DIK
Q
;
WARN(X,Y) ;create warning message in array X starting at Y ;p738
S @X@(Y,0)="Warning: Installing this backup patch message will install older versions"
S @X@(Y+1,0)="of routines and Build Components (options, protocols, templates, etc.)."
S @X@(Y+2,0)="Please verify with the Development Team that it is safe to install."
Q
;
QUIT ;unlock Install # XPDST
D QUIT^XPDI1(XPDST)
Q
;
HELP ;Help (DIR("??")) for DIR (Build/Routine) read ;p750
W !," Enter 'B' to create a backup of this Build. A new Build will be created using",!,"the same Build name with a 'b' appended to the end. This new Build will be used"
W !,"to create a KIDS backup of routines, files, options, protocols, templates, etc.",!,"If this backup is a single build, a Packman email is created. If it is a multi-package a Host File is created."
W !," Enter 'R' to create a Packman email of only the routines."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIB 11031 printed Apr 09, 2024@21:13:34 Page 2
XPDIB ;SFISC/RSD - Backup installed Package ; Mar 20, 2023@14:49:13
+1 ;;8.0;KERNEL;**10,58,108,178,713,738,750,755,768,778,785,796**;Jul 10, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
EN ;
+1 ;p713 - added support to create Build from Transport Global to create a backup
+2 NEW DIR,DIRUT,DUOUT,XPDA,XPDBLD,XPDTCNT,XPDH,XPDH1,XPDHD,XPDFMSG,XPDI,XPDIDVT,XPDMP,XPDNM,XPDPKG,XPDQUIT,XPDST
+3 NEW XPDT,XPDTB,XPDSBJ,XPDTYP,XPDVER,X,Y,Y0,%,XPDIB
+4 ;S %="I '$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%)
+5 ;p755 can't backup a backup
SET %="I $E($P(^(0),U),$L($P(^(0),U)))'=""b"",'$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))"
SET XPDST=$$LOOK^XPDI1(%)
+6 if 'XPDST!$DATA(XPDQUIT)
QUIT
+7 ;XPDST=starting install ien, XPDNM=install name, XPDBLD=build #, XPDPKG=package file pointer, XPDT(#)=Install file #^Install file name XPDIB=flag to not write errors
+8 SET XPDIB=1
DO BLDV(XPDST)
+9 ;XPDTCNT=# of installs
SET XPDTCNT=$ORDER(XPDT("DA"),-1)
+10 ;p738
IF XPDTYP>1
WRITE !!,"This is a Global Package and cannot be backed up.",!!
QUIT
+11 ;multi-package reset name to include all builds
+12 IF XPDTCNT>1
SET XPDNM=""
FOR XPDT=1:1:XPDTCNT
SET XPDNM=XPDNM_$PIECE(XPDT(XPDT),U,2)_$SELECT(XPDT'=XPDTCNT:", ",1:"")
+13 SET DIR(0)="F^3:65"
SET DIR("A")="Subject"
+14 SET DIR("?")="characters and must not contain embedded up-arrows."
+15 SET DIR("?",1)="Enter the subject for this Backup Message"
+16 SET DIR("?",2)="This response must have at least 3 characters and no more than 63"
+17 SET DIR("B")=$EXTRACT(("Backup of "_XPDNM_" on "_$$FMTE^XLFDT(DT)),1,63)
+18 WRITE !
DO ^DIR
IF $DATA(DIRUT)
GOTO QUIT
+19 SET XPDSBJ=Y
+20 KILL DIR
+21 ;Build or Routines
+22 SET DIR(0)="S^B:Build (including Routines);R:Routines Only"
SET DIR("A")="Backup Type"
SET DIR("B")="B"
+23 ;p738
SET DIR("?")="Backup the entire Build(routines, files, options, protocols, templates, etc.) or just the Routines."
+24 ;p750
SET DIR("??")="^D HELP^XPDIB"
+25 DO ^DIR
if $DATA(DIRUT)
GOTO QUIT
+26 ;R=routine Packman msg
+27 IF Y="R"
DO ROUTINE
GOTO QUIT
+28 ;XPDTCNT: 1=single, >1=multi-package ;p738
+29 ;p778 delete backup build
IF XPDTCNT=1
SET (XPDT,XPDTB)=1
SET XPDA=$$BLD(XPDST)
SET XPDNM=$PIECE(XPDTB(1),U,2)
DO PM(XPDA)
DO DELBLD(XPDA)
GOTO QUIT
+30 IF XPDTCNT>1
Begin DoDot:1
+31 ;used in GO^XPDT
NEW XPDSEQ,XPDSIZ,XPDSIZA,POP
+32 ;XPDH is HF header needed in DEV^XPDT
SET XPDH=XPDSBJ
+33 DO DEV^XPDT
if POP
QUIT
+34 SET XPDTB=0
+35 ;loop thru installs, XPDT(#)=install file #^name, XPDTB(#)=build file #^name
+36 ;p738
FOR XPDT=1:1:XPDTCNT
SET XPDTB=XPDTB+1
SET XPDA=+XPDT(XPDT)
SET XPDA=$$BLD(XPDA,XPDST)
+37 ;move XPDTB to XPDT
+38 KILL XPDT
MERGE XPDT=XPDTB
+39 ;open Host File, XPDFMSG=1 is flag to send HF to Forum
SET XPDFMSG=0
+40 ;write ^XTMP("XPDT" to HF
DO GO^XPDT
+41 ;loop thru backup builds and delete the builds ;p778
+42 FOR XPDT=1:1:XPDTCNT
SET XPDA=+XPDT(XPDT)
DO DELBLD(XPDA)
+43 QUIT
End DoDot:1
GOTO QUIT
+44 QUIT
BLD(XPDST,XPDMP) ;XPDST=Install #,XPDMP=master build or first Install # of multi-package; returns XPDA=new Build #
+1 NEW XPDA,XPDBLD,XPD,XPDERR,XPDFILE,XPDFL,XPDFLD,XPDGREF,XPDI,XPDNM,XPDOLDA,XPDREST,I,J,X,Y,Y0
+2 NEW XPDSD,XPDSUBDD
+3 DO BLDV(XPDST)
+4 ;create new build, add "b" to mark as backup & change ^XTMP(
+5 SET XPDI=XPDNM
SET XPDNM=XPDNM_"b"
SET $PIECE(^XTMP("XPDI",XPDST,"BLD",XPDBLD,0),U)=XPDNM
+6 ;$$BLD^XPDIP needs: XPDA, XPDBLD, XPDNM, XPDPKG
+7 SET XPDA=XPDST
SET XPDA=$$BLD^XPDIP(XPDBLD)
if 'XPDA
QUIT 0
+8 ;reset ^XTMP back to original value
+9 SET $PIECE(^XTMP("XPDI",XPDST,"BLD",XPDBLD,0),U)=XPDI
SET XPDTB(XPDTB)=XPDA_"^"_XPDNM
+10 ;change TRACK NATIONALLY(5)=no, ALPHA/BETA TESTING(20),INSTALLATION MSG(21),ADDRESS(22),Build number(63)
+11 SET %=XPDA_","
SET XPD(9.6,%,5)="n"
SET XPD(9.6,%,20)="n"
SET XPD(9.6,%,21)="n"
SET XPD(9.6,%,22)="n"
SET XPD(9.6,%,63)=0
+12 ;DESCRIPTION(3)
SET XPD(9.6,%,3)="XPDI"
SET XPDI(1,0)=XPDSBJ
SET XPDI(2,0)=" "
+13 ;add warning msg and file Description
+14 DO WARN("XPDI",3)
DO FILE^DIE("","XPD")
+15 ;delete multiples: REQUIRED BUILD(11), PACKAGE NAMESPACE(23), INSTALL QUESTIONS(50), XPFn(51.01-51.13), TEST/SEQ/TRANS(61-62)
+16 KILL ^XPD(9.6,XPDA,"REQB"),^("ABNS"),^("QUES"),^("QDEF"),^(6)
+17 ;Restore Routine ;p768
+18 IF $GET(^XPD(9.6,XPDA,"REST"))]""
MERGE XPDREST=^XTMP("XPDI",XPDST,"REST")
+19 ;delete PRE-T(900), ENVIR(913), POST(914), PRE-IN(916), DELETE routine, RESTORE(917)
+20 KILL ^XPD(9.6,XPDA,"PRET"),^("PRE"),^("INIT"),^("INI"),^("INID"),^("REST")
+21 ;scan BUILD COMPONENTS(7) and reset actions
+22 SET XPDFILE=0
+23 FOR
SET XPDFILE=$ORDER(^XPD(9.6,XPDA,"KRN",XPDFILE))
SET XPDOLDA=0
if 'XPDFILE
QUIT
Begin DoDot:1
+24 FOR
SET XPDOLDA=$ORDER(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA))
if 'XPDOLDA
QUIT
SET Y0=$GET(^(XPDOLDA,0))
Begin DoDot:2
+25 ; action
SET Y=$PIECE(Y0,U,3)
+26 ;link=2,attach=4,disable=5:delete component;merge=3:leave as merge ;p778
IF XPDFILE=19!(XPDFILE=101)
IF Y>1
if Y'=3
DO DELKRN(Y0)
QUIT
+27 DO KRN(XPDFILE,Y0)
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 ;scan FILE(#6) ^XPD(file#,222)=update DD^Security^f=full,p=partial DD^^resolve pointers^data list^data comes^site data^may override
+31 SET XPDFILE=0
+32 FOR
SET XPDFILE=$ORDER(^XPD(9.6,XPDA,4,XPDFILE))
if 'XPDFILE
QUIT
SET XPDFL=$GET(^(XPDFILE,222))
Begin DoDot:1
+33 ;full DD
IF $PIECE(XPDFL,U,3)="f"
Begin DoDot:2
+34 ;delete if new
IF '$DATA(^DD(XPDFILE))
DO DELF(XPDFILE)
QUIT
+35 ;can't backup data in file, set to 'no', kill 'select data screen' p738
+36 IF $PIECE(XPDFL,U,7)="y"
SET $PIECE(XPDFL,U,7)="n"
SET ^XPD(9.6,XPDA,4,XPDFILE,222)=XPDFL
KILL ^(223)
+37 QUIT
End DoDot:2
QUIT
+38 ;Partial DD, loop thru subDD (XPDSUBDD) to find the fields (XPDFLD). subDD with no fields=send all fields.
+39 SET (XPDSD,XPDSUBDD)=0
+40 FOR
SET XPDSUBDD=$ORDER(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD))
SET XPDFLD=0
if 'XPDSUBDD
QUIT
Begin DoDot:2
+41 ;fields are specified
IF $ORDER(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,0))
Begin DoDot:3
+42 ;loop thru fields
FOR
SET XPDFLD=$ORDER(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,XPDFLD))
if 'XPDFLD
QUIT
DO FLD(XPDSUBDD,XPDFLD)
+43 ;if all fields were removed, remove subDD
if '$ORDER(^XPD(9.6,XPDA,4,XPDFILE,2,XPDSUBDD,1,0))
DO DEL(XPDFILE,XPDSUBDD)
+44 QUIT
End DoDot:3
QUIT
+45 ;fields not specified & subDD is new - remove subDD
if '($DATA(^DD(XPDSUBDD,0))#10)
DO DEL(XPDFILE,XPDSUBDD)
+46 QUIT
End DoDot:2
+47 ;if all subDDs removed, remove file ;p768
if '$ORDER(^XPD(9.6,XPDA,4,XPDFILE,2,0))
DO DEL(XPDFILE)
+48 QUIT
End DoDot:1
+49 ;kill transport global before we rebuild it
+50 KILL ^XTMP("XPDT",XPDA)
+51 ;XPDFREF is a documented variable for use in PRE-TRANSPORTATION routine
+52 SET XPDVER=""
SET XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")"
+53 ;from XPDT, transport build
+54 ;p755 don't check for errors $D(XPDERR)
FOR X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC"
DO @X
+55 ;Load RESTORE routine ;p768
+56 IF $DATA(XPDREST)
Begin DoDot:1
+57 ;save RESTORE as POST-INIT in Build
SET I=+$ORDER(^XTMP("XPDT",XPDA,"BLD",0))
if I
SET ^XTMP("XPDT",XPDA,"BLD",I,"INIT")=XPDREST
+58 SET ^XTMP("XPDT",XPDA,"INIT")=XPDREST
SET Y=$PIECE(XPDREST,"(")
SET Y=$PIECE(Y,U,$LENGTH(Y,U))
if $DATA(^("RTN",Y))
QUIT
+59 ;save RESTORE routine
MERGE ^XTMP("XPDT",XPDA,"RTN",Y)=XPDREST(Y)
+60 ;^XTMP("XPDT",XPDA,"RTN",Y)=action^ien in Build^checksum
+61 SET X="B"_$$SUMB^XPDRSUM($NAME(^XTMP("XPDT",XPDA,"RTN",Y)))
SET ^XTMP("XPDT",XPDA,"RTN",Y)="0^^"_X
+62 ;update count node
+63 SET ^("RTN")=$GET(^XTMP("XPDT",XPDA,"RTN"))+1
+64 QUIT
End DoDot:1
+65 QUIT XPDA
+66 ;
BLDV(XPDA) ;variable setup for BLD, XPDA=Install #
+1 NEW Y0
+2 ;XPDNM=install name, XPDBLD=build #, Y0=zero node of build, XPDPKG=package file name
+3 SET XPDBLD=+$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
SET Y0=$GET(^(XPDBLD,0))
SET XPDNM=$PIECE(Y0,U)
SET XPDPKG=$PIECE(Y0,U,2)
SET XPDTYP=+$PIECE(Y0,U,3)
+4 ;XPDPKG=package file #
if XPDPKG]""
SET XPDPKG=$$LKPKG^XPDUTL(XPDPKG)
+5 QUIT
+6 ;XPDTP to build Packman message
PM(XPDA) ;build MailMan message
+1 NEW DIFROM,XCNP,DIF,XMSUB,XMDUZ,XMDISPI,XMZ
+2 ;p738
SET DIFROM=1
SET XMDUZ=+DUZ
SET XMSUB=XPDSBJ
+3 ;p768
WRITE !!," **This Backup mail message should be sent to a Mail Group. This will allow"
+4 WRITE !," anyone in the Mail Group to back out the changes.**"
+5 ;create message text for Packman
KILL ^TMP("XMP",$JOB)
+6 DO WARN("^TMP(""XMP"",$J)",1)
DO KD^XPDTP
+7 if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 WRITE !!,"Message sent",!
+9 QUIT
+10 ;
ROUTINE ;Packman msg
+1 NEW XCNP,DIF,XMSUB,XMDUZ,XMDISPI,XMZ
+2 SET XMSUB=XPDSBJ_". Routines Only"
SET XMDUZ=+DUZ
+3 DO XMZ^XMA2
IF XMZ<1
DO QUIT^XPDI1(XPDST)
QUIT
+4 SET Y=$$NOW^XLFDT
SET %=$$DOW^XLFDT(Y)
SET Y=$$FMTE^XLFDT(Y,2)
+5 SET X="PACKMAN BACKUP Created on "_%_", "_$PIECE(Y,"@")_" at "_$PIECE(Y,"@",2)
+6 IF $DATA(^VA(200,DUZ,0))
SET X=X_" by "_$PIECE(^(0),U)_" "
+7 if $DATA(^XMB("NAME"))
SET X=X_"at "_$PIECE(^("NAME"),U)_" "
+8 SET ^XMB(3.9,XMZ,2,0)="^3.92A^^^"_DT
SET ^(1,0)="$TXT "_X
SET XCNP=1
+9 SET XPDT=0
+10 FOR
SET XPDT=$ORDER(XPDT(XPDT))
if 'XPDT
QUIT
Begin DoDot:1
+11 SET XPDA=+XPDT(XPDT)
SET XPDNM=$PIECE(XPDT(XPDT),U,2)
SET X=""
+12 IF '$DATA(^XTMP("XPDI",XPDA,"RTN"))
WRITE !,"No routines for ",XPDNM,!
QUIT
+13 WRITE !,"Loading Routines for ",XPDNM
+14 FOR
SET X=$ORDER(^XTMP("XPDI",XPDA,"RTN",X))
if X=""
QUIT
Begin DoDot:2
+15 NEW %N,DIF
+16 ;p713
XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,X,?10,"Doesn't Exist"
QUIT
+17 SET XCNP=XCNP+1
SET ^XMB(3.9,XMZ,2,XCNP,0)="$ROU "_X_" (PACKMAN_BACKUP)"
SET DIF="^XMB(3.9,XMZ,2,"
+18 XECUTE ^%ZOSF("LOAD")
+19 SET $PIECE(^XMB(3.9,XMZ,2,0),U,3,4)=XCNP_U_XCNP
SET ^(XCNP,0)="$END ROU "_X_" (PACKMAN-BACKUP)"
+20 QUIT
End DoDot:2
WRITE "."
+21 QUIT
End DoDot:1
+22 DO EN3^XMD
+23 QUIT
+24 ;
KRN(FILE,XPDY) ;FILE=file #, XPDY=^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA,0)
+1 NEW DA,FGR,X
+2 SET X=$PIECE(XPDY,U)
+3 ;$P(XPDY,U,2) is file # for FileMan templates, reset name in XPDY before getting DA
+4 ;p785
if $PIECE(XPDY,U,2)
SET $PIECE(XPDY,U)=$PIECE(XPDY," FILE #")
+5 ;Routine file, just check if routine exists, don't call FILE or ENTRY
+6 ;p796
IF FILE=9.8
SET DA=($TEXT(^@X)]"")
+7 ;DA=ien or 0 if doesn't exists
IF '$TEST
SET FGR=$$FILE^XPDV(FILE)
SET DA=$$ENTRY^XPDV(XPDY)
+8 ;If X exists, set to 0 - send, else set to 1 - delete
+9 SET $PIECE(XPDY,U,3)='DA
+10 ;save component
+11 ;p778
SET ^XPD(9.6,XPDA,"KRN",FILE,"NM",XPDOLDA,0)=XPDY
+12 QUIT
+13 ;
DELKRN(XPDY) ;delete BUILD COMPONENTS(7) & "B" index for XPDY ;p778
+1 KILL ^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA,0),^XPD(9.6,XPDA,"KRN",XPDFILE,"NM","B",$PIECE(XPDY,U),XPDOLDA)
+2 QUIT
+3 ;
FLD(DD,FIELD) ;check FIELD exists
+1 ;field is new, delete
if '($DATA(^DD(DD,FIELD,0))#10)
DO DEL(XPDFILE,DD,FIELD)
+2 QUIT
+3 ;
DEL(FILE,SUBDD,FIELD) ;deletes partials: FILE=file#, SUBDD=sub dictionary#, FIELD=field#, XPDA=ien in Build file
+1 ;delete FIELD & index
IF $GET(FIELD)
KILL ^XPD(9.6,XPDA,4,FILE,2,SUBDD,1,FIELD),^XPD(9.6,XPDA,4,"APDD",FILE,SUBDD,FIELD)
QUIT
+2 ;delete SUBDD & index
IF $GET(SUBDD)
KILL ^XPD(9.6,XPDA,4,FILE,2,SUBDD),^XPD(9.6,XPDA,4,"APDD",FILE,SUBDD)
QUIT
+3 ;delete FILE & index
IF $GET(FILE)
KILL ^XPD(9.6,XPDA,4,FILE),^XPD(9.6,XPDA,4,"APDD",FILE),^XPD(9.6,XPDA,4,"B",FILE)
+4 QUIT
+5 ;
DELF(FILE) ;delete full file DD
+1 NEW DIK,DA
+2 SET DIK="^XPD(9.6,"_XPDA_",4,"
SET DA=FILE
SET DA(1)=XPDA
+3 DO ^DIK
+4 QUIT
+5 ;
DELBLD(DA) ;delete backup build ;p778
+1 if '$GET(DA)
QUIT
+2 NEW DIK
+3 SET DIK="^XPD(9.6,"
+4 DO ^DIK
+5 QUIT
+6 ;
WARN(X,Y) ;create warning message in array X starting at Y ;p738
+1 SET @X@(Y,0)="Warning: Installing this backup patch message will install older versions"
+2 SET @X@(Y+1,0)="of routines and Build Components (options, protocols, templates, etc.)."
+3 SET @X@(Y+2,0)="Please verify with the Development Team that it is safe to install."
+4 QUIT
+5 ;
QUIT ;unlock Install # XPDST
+1 DO QUIT^XPDI1(XPDST)
+2 QUIT
+3 ;
HELP ;Help (DIR("??")) for DIR (Build/Routine) read ;p750
+1 WRITE !," Enter 'B' to create a backup of this Build. A new Build will be created using",!,"the same Build name with a 'b' appended to the end. This new Build will be used"
+2 WRITE !,"to create a KIDS backup of routines, files, options, protocols, templates, etc.",!,"If this backup is a single build, a Packman email is created. If it is a multi-package a Host File is created."
+3 WRITE !," Enter 'R' to create a Packman email of only the routines."
+4 QUIT
