- 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 Mar 13, 2025@21:08:29 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
