11:12 AM  19-FEB-99
XPD routines for IHS Patch 5
XPDCOM
XPDCOM ;SFISC/RSD - Compare Transport Global ;02/03/97  14:18
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21,58**;Jul 10, 1995
EN1 ;compare to current system
 N DIC,DIR,DIRUT,POP,XPD,XPDA,XPDC,XPDNM,Y,Z,%ZIS
 S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I '$P(^(0),U,9),$D(^XTMP(""XPDI"",Y))"
 D ^DIC Q:Y<0  S XPDA=+Y,XPDNM=Y(0,0)
 S DIR(0)="S^1:Full Comparison;2:Second line of Routines only;3:Routines only",DIR("A")="Type of Compare",DIR("?")="Enter the type of comparison."
 D ^DIR Q:$D(DTOUT)!$D(DUOUT)
 S XPDC=Y,Y="COM^XPDCOM("_XPDA_")",Z="Transport Global Compare",XPD("XPDNM")="",XPD("XPDC")=""
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
COM(XPDA) ;XPDA=ien of package in ^XTMP("XPDI"
 Q:'$D(^XTMP("XPDI",$G(XPDA)))
 D HDR,COMR(5),EN^XPDCOMG:XPDC=1
 Q
 ;compare routines
COMR(NL) ;NL=number of lines to check ahead
 N DL,XL,XPDI,X,XL,Y,YL
 S:'$G(NL) NL=5 S XPDI=""
 F  S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDI)) Q:XPDI=""  S X=$G(^(XPDI)) D
 .I X W:X=1 !!,"DELETE Routine: ",XPDI,! Q
 .S X=XPDI X ^%ZOSF("TEST") E  W !!,"ADD Routine: ",XPDI,! Q
 .W !!," Routine: ",XPDI
 .;check 2nd line only
 .I XPDC=2 D  Q
 ..S X=$G(^XTMP("XPDI",XPDA,"RTN",XPDI,2,0)),Y=$T(+2^@XPDI)
 ..W !,"<TG> ",X,!,"<SYS>",Y Q:X=Y!(X'["**")
 ..;check patch string
 ..S X=$P(X,"**",2),XL=$L(X,","),Y=$P(Y,"**",2),YL=$L(Y,",")
 ..Q:X=Y
 ..;incoming has more patches than system, check for missing patches
 ..I XL>YL W:$P(X,",",1,(XL-1))'=Y !,"*** WARNING, you are missing one or more Patches ***" Q
 ..I YL>XL W !,"*** WARNING, your routine has more patches than the incoming routine ***" Q
 .F %=1:1 Q:'$D(^XTMP("XPDI",XPDA,"RTN",XPDI,%))
 .;XL=lines in routine in XTMP, DL=line in routine on disk
 .S XL=%-1,DL=$$LD(XPDI)
 .D COMP K ^TMP($J,XPDI)
 Q
COMP ;taken from XMPC routine
 N D1,DI,I,J,K,X1,XI,Y1
 S (XI,DI)=0
 ;check each line in the incoming routine,X1, against the routine on disk,D1
 F  S XI=XI+1,DI=DI+1 Q:XI>XL!(DI>DL)  D:^XTMP("XPDI",XPDA,"RTN",XPDI,XI,0)'=^TMP($J,XPDI,DI,0)
 .S X1=^XTMP("XPDI",XPDA,"RTN",XPDI,XI,0),Y1=0
 .;if lines are not the same, look ahead five lines in D1
 .F I=DI:1:$S(DI+NL<DL:DI+NL,1:DL) S D1=^TMP($J,XPDI,I,0) D  Q:Y1
 ..F K=1:5:26 Q:$L($E(D1,K,K+10))<7  I $F(X1,$E(D1,K,K+10))  D  Q
 ...;print the lines upto the line that are the same
 ...F J=DI:1:I-1 D WP(^TMP($J,XPDI,J,0),2)
 ...;quit if the lines are equal
 ...S DI=I,Y1=1 Q:D1=X1
 ...;if lines are equal, print old and new
 ...D WP(D1,3),WP(X1,4)
 .Q:Y1  D WP(X1,1) S DI=DI-1
 ;check remaining lines in routines
 I XI>XL&(DI<(DL+1)) F I=DI:1:DL D WP(^TMP($J,XPDI,I,0),2)
 I DI>DL&(XI<(XL+1)) F I=XI:1:XL D WP(^XTMP("XPDI",XPDA,"RTN",XPDI,I,0),1)
 Q
WP(X,Y) W !,"* "_$P("ADD^DEL^OLD^NEW",U,Y)_" *  ",X
 Q
 ;load system routine into TMP global
LD(X) N %N,DIF,XCNP
 K ^TMP($J,X)
 S DIF="^TMP($J,X,",XCNP=0
 X ^%ZOSF("LOAD")
 Q %N-1
 ;
HDR S $P(XPDUL,"-",80)=""
 W @IOF,"Compare ",XPDNM," to current site",!
 I XPDC>1 W:XPDC=2 "2nd Line of " W "Routines Only",!
 W XPDUL,!
 Q

XPDCOMG
XPDCOMG ;SFISC/RSD - compare globals ; 3 Feb 95 09:04
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;;Jul 10, 1995
EN D FIA,KRN
 Q
FIA N DIC,OLDA,XPDFIL,XPDFILO,XPDFILS,XPDS,XPDS0,XPDX,XPDX0,XPDY,XPDY1,XPDZ,XPDZ1,X,Y
 S XPDFIL=0
 F  S XPDFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPDFIL)) Q:'XPDFIL  S XPDZ1=^(XPDFIL,0),XPDFILO=^(0,1) D
 .I '$D(^DIC(XPDFIL)) W !!," File # ",XPDFIL," is NEW",! Q
 .Q:$P(XPDFILO,U)'="y"
 .W !!," File # ",XPDFIL," Data Dictionary ",!
 .S XPDZ="^XTMP(""XPDI"","_XPDA,XPDY=XPDZ_",""^DIC"","_XPDFIL_","_XPDFIL_",0",XPDX=XPDY_")",XPDY=XPDY_",",XPDY1="^DIC("_XPDFIL_",0",XPDS=XPDY1_")",XPDY1=XPDY1_","
 .D COMPAR(1)
 .S XPDFILS=0 F  S XPDFILS=$O(^XTMP("XPDI",XPDA,"^DD",XPDFIL,XPDFILS)) Q:'XPDFILS  D
 ..S XPDY=XPDZ_",""^DD"","_XPDFIL_","_XPDFILS,XPDX=XPDY_")",XPDY=XPDY_",",XPDY1="^DD("_XPDFILS,XPDS=XPDY1_")",XPDY1=XPDY1_","
 ..D COMPAR(1)
 .Q:'$D(^XTMP("XPDI",XPDA,"DATA",XPDFIL))
 .W !!," File # ",XPDFIL," Data ",!
 .K DIC
 .S DIC=XPDFIL,DIC(0)="X",XPDZ=XPDZ_",""DATA"","_XPDFIL,OLDA=0
 .F  S OLDA=$O(^XTMP("XPDI",XPDA,"DATA",XPDFIL,OLDA)) Q:'OLDA  S OLDA(0)=^(OLDA,0) D
 ..S X=$P(OLDA(0),U) D ^DIC
 ..I Y<0 W !,X," will be ADDED " Q
 ..S XPDY=XPDZ_","_OLDA_",",XPDX=XPDZ_","_OLDA_")",XPDY1=XPDZ1_+Y_",",XPDS=XPDZ1_+Y_")"
 ..D COMPAR(0)
 W !! Q
KRN N DEL,DIC,OLDA,ORD,X,XPDFIL,XPDFILNM,XPDI,XPDS,XPDS0,XPDX,XPDX0,XPDY,XPDY1,XPDZ,XPDZ1,Y
 S ORD=0
 F  S ORD=$O(^XTMP("XPDI",XPDA,"ORD",ORD)) Q:'ORD  S XPDFIL=+$O(^(ORD,0)),XPDFILNM=$G(^(XPDFIL,0)) D:XPDFIL
 .I $P($G(^DIC(XPDFIL,0)),U)'=XPDFILNM W !!," File "_XPDFIL_" is not "_XPDFILNM_", nothing can be installed.",! Q
 .W !!,XPDFILNM,! K DIC
 .S DIC=XPDFIL,DIC(0)="X",XPDZ="^XTMP(""XPDI"","_XPDA_",""KRN"","_XPDFIL_",",XPDZ1=^DIC(XPDFIL,0,"GL"),OLDA=0
 .F  S OLDA=$O(^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)) Q:'OLDA  S DEL=$G(^(OLDA,-1)),OLDA(0)=^(0) D
 ..I XPDFIL<.44 S DIC("S")="I $P(^(0),U,"_$S(XPDFIL'=.403:"4)",1:"8)")_"="_$P(OLDA(0),U,$S(XPDFIL'=.403:4,1:8))
 ..I DEL=1,XPDFIL<.44 S %=$P(OLDA(0),U),$P(OLDA(0),U)=$P(%,"    FILE #"),DIC("S")="I $P(^(0),U,"_$S(XPDFIL'=.403:4,1:8)_")="_+$P(%,"    FILE #",2)
 ..S X=$P(OLDA(0),U) D ^DIC
 ..I Y<0,DEL'=1 W !,XPDFILNM,": ",X," will be ADDED " Q
 ..I DEL=1 W:Y>0 !,XPDFILNM,": ",X," will be DELETED " Q
 ..S XPDY=XPDZ_OLDA_",",XPDX=XPDZ_OLDA_",-1)",XPDY1=XPDZ1_+Y_",",XPDS=XPDZ1_+Y_")" D COMPAR(0)
 Q
 ;taken from XTVGC2 routine
COMPAR(XPDFL) S XPDFL=$G(XPDFL)
 N XPDS1,XPDX1
 F  D  Q:XPDX=""&(XPDS="")
 .S XPDX0=$$QU(.XPDX,XPDY),XPDX1=$P(XPDX,XPDY,2)
 .S XPDS0=$$QU(.XPDS,XPDY1),XPDS1=$P(XPDS,XPDY1,2) Q:XPDX=""&(XPDS="")
 .D CHECK
 Q
CHECK N FL,I,X1,X1,S1,S2
CHK1 I XPDX="" W:'XPDFL !,"* DEL *   ",XPDS," = ",XPDS0 Q
 I XPDS="" W !,"* ADD *   ",XPDY1_XPDX1," = ",XPDX0 Q
 S FL=$S(XPDX1=XPDS1:0,1:1)
 I FL S X1=$E(XPDX1,1,$L(XPDX1)-1),S1=$E(XPDS1,1,$L(XPDS1)-1) D
 .F I=1:1 S X2=$P(X1,",",I),S2=$P(S1,",",I) I X2'=S2 S FL=$S(+X2=X2:$S(+S2'=S2:1,X2<S2:1,1:-1),+S2=S2:-1,S2]X2:1,1:-1) Q
 I FL<0 W:'XPDFL !,"* DEL *   ",XPDS," = ",XPDS0 S XPDS0=$$QU(.XPDS,XPDY1),XPDS1=$P(XPDS,XPDY1,2) G CHK1
 I FL>0 W !,"* ADD *   ",XPDY1_XPDX1," = ",XPDX0 S XPDX0=$$QU(.XPDX,XPDY),XPDX1=$P(XPDX,XPDY,2) G CHK1
 I XPDX0'=XPDS0 W !,"* OLD *   ",XPDS," = ",XPDS0,!,"* NEW *   ",XPDY1_XPDX1," = ",XPDX0
 Q
QU(X,Y) ;X=gr, Y=root
 Q:$G(X)="" ""
 S X=$Q(@X)
 I X=""!(X'[$G(Y)) S X="" Q ""
 Q @X

XPDCPU
XPDCPU ;SFISC/RWF,RSD - Code that update each cpu ;09/09/96  08:01
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**41,44**;JUL 03, 1995
 N DIC,X,XPDA
 S DIC("S")="I $P(^(0),U,9)=2,$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))"
 D EN1 Q:'XPDA
 S X=$O(^XPD(9.7,XPDA,"VOL","B",^%ZOSF("VOL"),0)) Q:'X
 D EN(XPDA,X)
 Q
 ;
MOVE ;move routines to other CPU
 N DIC,DIR,DIRUT,X,XPDA,XPDJ,Y
 S DIC("S")="I $P(^(0),U,9)=3"
 D EN1 Q:'XPDA
 S DIR(0)="Y",DIR("A")="Want to move the Routine for this Package to another CPU",DIR("B")="YES",DIR("?")="YES means you want to update the routines on another CPU"
 D ^DIR Q:'Y!$D(DIRUT)
 K ^XTMP("XPDR",XPDA)
 S ^XTMP("XPDR",0)=DT_U_DT,XPDJ=""
 F  S XPDJ=$O(^XPD(9.7,XPDA,"RTN","B",XPDJ)) Q:XPDJ=""  D
 .Q:XPDJ="XPDCPU"
 .N DIF,XCNP,%N
 .S DIF="^XTMP(""XPDR"",XPDA,""RTN"",XPDJ,",XCNP=0,X=XPDJ
 .X ^%ZOSF("LOAD")
 I $D(^XTMP("XPDR",XPDA)) W !!,"Run INSTALL^XPDCPU on the other CPU to install the Routines.",!
 Q
INSTALL ;install routines
 N DIC,DIR,DIRUT,X,XPDA,XPDJ,Y
 S DIC("S")="I $P(^(0),U,9)=3,$D(^XTMP(""XPDR"",Y))"
 D EN1 Q:'XPDA
 S DIR(0)="Y",DIR("A")="Want to install the Routine for this Package",DIR("B")="YES",DIR("?")="YES means you want to install the routines on this CPU"
 D ^DIR Q:'Y!$D(DIRUT)
 S XPDJ=""
 F  S XPDJ=$O(^XTMP("XPDR",XPDA,"RTN",XPDJ)) Q:XPDJ=""  D
 .N %,DIE,XCM,XCN,XCS
 .S DIE="^XTMP(""XPDR"",XPDA,""RTN"",XPDJ,",XCN=0,X=XPDJ
 .X ^%ZOSF("SAVE")
 W !!,"Done",!!
 Q
 ;
EN(XPDA,XPDVDA) ;XPDA=ien of INSTALL file, XPDVDA=VOLUME SET ien
 L +^XPD(9.7,XPDA,"VOL",XPDVDA):2 E  W:IO]"" !,"Can't Lock global, another XPDCPU must be running",! Q
 N Y,%,XPDNM
 S Y=0,ZTREQ="@"
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S %=$O(^(Y,0)) D:%  Q:$D(XPDABORT)
 .N XPDA,Y
 .S XPDA=%,XPDNM=$P($G(^XPD(9.7,XPDA,0)),U) D EN2
 Q
EN1 ;ask for Install
 N Y S XPDA=0
 I $D(DUZ)_$D(DUZ(0))_$D(U)[0 D DT^DICRW
 S DIC(0)="QEAMZ",DIC="^XPD(9.7,"
 D ^DIC K DIC Q:Y'>0
 S XPDA=+Y
 Q
EN2 N X,XPD,XPDBLD,XPDI,ZTUCI,ZTCPU,ZTRTN,ZTDTH,ZTIO,ZTDESC
 ;must have XTMP & entry in file 9.7
 Q:'$D(^XTMP("XPDI",XPDA))!'$D(^XPD(9.7,XPDA,0))
 ;hang 1 hr or until VOLUME multiple is set, XPDIJ sets VOL multiple
 F X=0:1:60 Q:$D(^XPD(9.7,XPDA,"VOL",+$G(XPDVDA),0))  H 60 W:IO]"" "."
 I X=60 W:IO]"" !!,"Package ",$P(^XPD(9.7,XPDA,0),U)," never installed",! Q
 S XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0))
 D FILE(2),UPDT
 W:IO]"" !,"Loading Routines"
 I $D(^XTMP("XPDI",XPDA,"RTN","XPDCPU")) S X=$$RTNUP^XPDUTL("XPDCPU",2)
 ;make sure routines have been loaded
 F X=0:1:240 Q:$P($G(^XPD(9.7,XPDA,1)),U,2)  H 15 W:IO]"" "." D UPDT
 D UPDT,RTN^XPDIJ(XPDA),UPDT
 W:IO]"" !!,"Recompiling Template routines"
 F XPD="DIKZ","DIEZ","DIPZ" D
 .S XPDI="" Q:'$$CHCK
 .F  S XPDI=$O(^XTMP("XPDI",XPDA,XPD,XPDI)) Q:'XPDI  S X=^(XPDI) D:X]"" @("EN2^"_XPD_"("""_XPDI_""","""","""_X_""")"),UPDT
 D UPDT,FILE(1)
 Q
CHCK() ;check if the component is installed, return 1 if installed, 0 to abort
 N XPDC,Y
 I XPD="DIKZ" S XPDC="S Y=$G(^(+$O(^XPD(9.7,XPDA,4,""A""),-1),0))"
 E  S Y=$S(XPD="DIPZ":.4,1:.402),XPDC="S Y=$G(^XPD(9.7,XPDA,""KRN"","_Y_",0))"
 F  X XPDC Q:'Y!$P(Y,U,2)  H 60 D UPDT W:IO]"" "." I $D(ZTMQUE),$$STOP^%ZTLOAD S Y=0 Q
 Q ''Y
FILE(XPDF) ;set NOW into the VOLUME SET multiple, XPDF=field number
 N XPD
 S XPD(9.703,XPDVDA_","_XPDA_",",XPDF)=$$NOW^XLFDT
 D FILE^DIE("","XPD")
 Q
UPDT ;update $H into VOLUME SET multiple, field 4
 S ^XPD(9.7,XPDA,"VOL",XPDVDA,1)=$H
 Q

XPDCUST
XPDCUST ;SLC/STAFF-SITE TRACKING UPDATE ALL VERSIONS ;7/20/94  15:34
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;7.1;Kernel;**22,35**;Oct 25, 1993
 ;
ALL ;
 W !,"This routine is used to check the package file (9.4) for the current"
 W !,"versions of software installed at your site.  This information will"
 W !,"be used to update the site tracking file on FORUM.  Package names will also"
 W !,"be checked to make sure they conform to the official package name assigned"
 W !,"to the software.  If needed, the name in the package file will be changed."
 W !,"This routine should only be used in your production account."
 W !!,"The data collected will be sent to FORUM automatically via MailMan."
 W !,"A message with the changes made to site tracking will be sent back via MailMan."
 ;
 N DIC,DIR,PERSON,SERVER,SITE,X,Y K DIC,DIR
 I $G(^XMB("NETNAME"))'[".VA.GOV" W !,"This routine should only be used by a VA site." Q
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") W !,"This routine must be run in a production account." Q
 S SERVER="S.A5CSTS@FORUM.VA.GOV",SITE=^XMB("NETNAME")
 W !!,"Enter the person who will receive this message at ",SITE,"."
 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select Person: ",DIC("B")=$S('$D(DUZ):"",1:$P($G(^VA(200,DUZ,0)),U)) D ^DIC K DIC Q:Y<0  S PERSON=$P(Y,U,2)
 S DIR(0)="YAM",DIR("A")="Proceed to collect data for site tracking? ",DIR("B")="YES" D ^DIR K DIR Q:Y'=1
 D ^XPDCUSTP
 Q
TASK ; this entry point is no longer used
 Q

XPDCUSTL
XPDCUSTL ;SLC/STAFF-SITE TRACKING UPDATE ALL VERSIONS, LOAD ;7/20/94  15:37
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;7.1;Kernel;**22,35**;Oct 25, 1993
 ;
LOAD ; from XPDCUSTP
 N DATA,I,II,NAME,OLDNM,ROUTINE
 F I=1:1 S DATA=$P($T(PAC+I),";",3,99) S NAME=$P(DATA,";") Q:'$L(NAME)  S ROUTINE=$P(DATA,";",2) D
 .S $P(^TMP("XPDCUP",$J,NAME),U,4)=ROUTINE
 .F II=3:1  S OLDNM=$P(DATA,";",II) Q:'$L(OLDNM)  D
 ..S $P(^TMP("XPDCUP",$J,OLDNM),U,4,5)=ROUTINE_U_NAME
 Q
 ;
 ; Format used for package updates:
 ; ;;official name;routine1,routine2,...;old name1;old name2;...
PAC ;;
 ;;ACCOUNTS RECEIVABLE;PRCAAD,PRCADEL;
 ;;ADP PLANNING (PLANMAN);PRAPB,PRAPQ;
 ;;AUTO REPLENISHMENT/WARD STOCK;PSGWAR,PSGWPL;
 ;;AUTOMATED MED INFO EXCHANGE;DVBAPEND,DVBCDCK;
 ;;CLINICAL LEXICON UTILITY;GMTA1,GMPTU;
 ;;CLINICAL MONITORING SYSTEM;QAMEDT0,QAMUTL0;
 ;;CONSULT/REQUEST TRACKING;GMRCA,GMRCAR;
 ;;CONTROLLED SUBSTANCES;PSDCOR,PSDEXP;
 ;;CPT/AMB PROCEDURE UPDATE;DGYA,DGYAPRN;
 ;;CREDENTIALS TRACKING;QARCRF,QARCS;
 ;;D&PPM;PSUA,PSUB;
 ;;DENTAL;DENTA,DENT;
 ;;DIETETICS;FH,FHORD;
 ;;DISCHARGE SUMMARY;GMRDU,GMRDLIBS;
 ;;DRG GROUPER;ICDDRG,ICDDRGM;
 ;;DRUG ACCOUNTABILITY;PSACON,PSADA;
 ;;EEO COMPLAINT TRACKING;EEOEEXE,EEOEOE2;
 ;;ENGINEERING;ENEQ,ENETRAN;
 ;;EXTERNAL PEER REVIEW;DGYEPRN,DGYEUTL;
 ;;FEE BASIS;FBCHCD,FBAASAP;
 ;;GEN. MED. REC. - ALLERGIES;GMRADPT,GMRAUTL;ALLERGY TRACKING SYSTEM
 ;;GEN. MED. REC. - GENERATOR;GMRGED0,GMRGRUT0;TEXT GENERATOR
 ;;GEN. MED. REC. - VITALS;GMRVADM,GMRVDS0;VITALS
 ;;GENERIC CODE SHEET;GECSA,GECSX;
 ;;HEALTH LEVEL SEVEN;HLLP,HLTRANS;
 ;;HEALTH SUMMARY;GMTSADH2,GMTSLRA;
 ;;HINQ;DVBHDEL,DVBHQM4;
 ;;ICR - IMMUNOLOGY CASE REGISTRY;IMRDD,IMRTST;
 ;;IFCAP;PRCHSP,PRCHE;IFCAP PACKAGE
 ;;INCIDENT REPORTING;PRMRHINC,PRMRTYPO;
 ;;INCOME VERIFICATION MATCH;IVMXZEL,IVMXZEM;
 ;;INPATIENT MEDICATIONS;PSJADT,PSJAC;
 ;;INTEGRATED BILLING;DGCRMENU,DGCRC;
 ;;INTERIM MANAGEMENT SUPPORT;ECTASP,ECTPFY;
 ;;KERNEL;XUS,XQ1;
 ;;LAB SERVICE;LRPARAM,LRORD;
 ;;LIBRARY;LBRYPPR,LBRYPG;LIBRARY SERVICE
 ;;LIST MANAGER;VALM,VALM1;
 ;;MAILMAN;XMD,XMAP;
 ;;MCCR NATIONAL DATABASE;PRQSD,PRQSG;MCCR NATIONAL DATABASE - FIELD
 ;;MEDICINE;MCAR,MCARP;
 ;;MENTAL HEALTH;YSSR,YSUTL;MENTAL HEALTH SYSTEM
 ;;MISSING PATIENT REGISTER;A4ELOCK,A4ELOCO;
 ;;NATIONAL DRUG FILE;PSNBLD,PSNPFN;
 ;;NURSING SERVICE;NURSUT0,NURSCPL;
 ;;OCCURRENCE SCREEN;QAOSPSM0,QAOSENTR;OCCURRENCE SCREEN/MONITOR
 ;;ONCOLOGY;ONCOUTC,ONCOAS;
 ;;ORDER ENTRY/RESULTS REPORTING;OR,ORSU;
 ;;OUTPATIENT PHARMACY;PSONEW,PSOREF;
 ;;PAID;PRSTKE,PRSTTL;
 ;;PATIENT CARE ENCOUNTER;PXPTNPAT,PTXTXDPT;
 ;;PATIENT DATA EXCHANGE;VAQADD,VAQPRT;
 ;;PATIENT FEEDBACK;A4A8DLT0,A4A8DSRV;
 ;;PATIENT REPRESENTATIVE;QACNEW,QACSTAT;
 ;;PROBLEM LIST;GMPL,GMPL1;
 ;;POLICE & SECURITY;ESPEVID,ESPFM;
 ;;PROGRESS NOTES;GMRPDD,GMRPNKEY;
 ;;PROSTHETICS;RMPRAP,RMPRM;
 ;;QUALITY IMPROVEMENT CHECKLIST;QIPUTL,QIP5;
 ;;RADIOLOGY;RABTCH,RAORD;
 ;;RECORD TRACKING;RTB,RTT;
 ;;REGISTRATION;DGBT1,DGL;
 ;;REMOTE ORDER/ENTRY SYSTEM;RMPFET,RMPFDS;
 ;;SAGG PROJECT;A1B5GE,A1B5UTL;
 ;;SOCIAL WORK;SOWKCO,SOWKRF;
 ;;SURGERY;SROAMIS,SRONR;
 ;;SURVEY GENERATOR;QAPTOT,QAPSTAT;
 ;;TOOLKIT;XTSUMBLD,XTVNUM;
 ;;UNWINDER;XQOR,XQORM;
 ;;UTILIZATION REVIEW;PRMQS,PMRQQ;
 ;;VA FILEMAN;DIC,DIE;FILE MANAGER
 ;;VISIT TRACKING;VSIT,VSITVAR;
 ;;VOLUNTARY SERVICE;ABSVE,ABSVLS;
 ;;

XPDCUSTP
XPDCUSTP ;SLC/STAFF-SITE TRACKING UPDATE ALL VERSIONS, PROCESS ;7/20/94  15:37
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;7.1;Kernel;**22,35**;Oct 25, 1993
 ;
 ; from XPDCUST
PAC N ANUM,DA,DATE,DIC,DIE,DR,NEWNM,NUM,PACKAGE,VERSION,XMDUZ,XMSUB,XMTEXT,XMY K ^TMP("XPDCUP",$J),^TMP("XPDCUS",$J)
 ;
 ; LOAD^XPDCUSTL returns ^TMP("XPDCUP",$J, which is used to find the
 ; version of packages.  The format for package names is:
 ; ^TMP("XPDCUP",$J,name) = version # ^ date installed ^ ^ routine names
 ; ^TMP("XPDCUP",$J,old name) =  ^ ^ ^ routine names ^ name
 D LOAD^XPDCUSTL
 ;
 ; Go thru names in the package file that are used in site tracking
 W !!,"Checking application version numbers and install dates.",!
 S PACKAGE="" F  S PACKAGE=$O(^DIC(9.4,"B",PACKAGE)) Q:PACKAGE=""  I $D(^TMP("XPDCUP",$J,PACKAGE)) D
 .;
 .; If this is an official name and no version number has been assigned,
 .; setup the version and date
 .I '$L($P(^TMP("XPDCUP",$J,PACKAGE),U,5)),'$L($P(^TMP("XPDCUP",$J,PACKAGE),U)) D  Q
 ..D VERSION^XPDCUSTU S ^TMP("XPDCUP",$J,PACKAGE)=VERSION_U_DATE
 ..W !,PACKAGE,"   ",VERSION
 ..I VERSION,DATE W "   ",$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)
 .;
 .; If this is an old name, setup the version and date for the new name
 .; and change the name of the package to the new name.
 .I $L($P(^TMP("XPDCUP",$J,PACKAGE),U,5)) D  Q
 ..S DA=+$O(^DIC(9.4,"B",PACKAGE,0)) I 'DA Q
 ..S NEWNM=$P(^TMP("XPDCUP",$J,PACKAGE),U,5)
 ..I $D(^DIC(9.4,"B",NEWNM)) Q
 ..D VERSION^XPDCUSTU S ^TMP("XPDCUP",$J,NEWNM)=VERSION_U_DATE
 ..L +^DIC(9.4,DA,0) S (DIC,DIE)=9.4,DR=".01///"_NEWNM D ^DIE L -^DIC(9.4,DA,0)
 ..W !,PACKAGE," changed to ",NEWNM,"   ",VERSION I VERSION,DATE W "   ",$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)
 ;
 ; Setup mail message for server
 S ^TMP("XPDCUS",$J,1,0)="ALL PACKAGE VERSIONS"
 S ^TMP("XPDCUS",$J,2,0)="SITE: "_SITE
 S ^TMP("XPDCUS",$J,3,0)="PERSON: "_PERSON
 S ^TMP("XPDCUS",$J,4,0)="PACKAGES:"
 S NUM=4
 S PACKAGE="" F  S PACKAGE=$O(^TMP("XPDCUP",$J,PACKAGE)) Q:PACKAGE=""  D
 .I '$L($P(^TMP("XPDCUP",$J,PACKAGE),U,5)) S NUM=NUM+1,^TMP("XPDCUS",$J,NUM,0)=PACKAGE_U_$P(^TMP("XPDCUP",$J,PACKAGE),U,1,3)
 S NUM=NUM+1
 S ^TMP("XPDCUS",$J,NUM,0)="AUTO INSTRUMENTS: "
 ;
 ; Send message to server
 S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""XPDCUS"",$J,",XMSUB="Site Tracking - "_SITE
 D ^XMD
 W !!,"A message to update site tracking is being sent to ",$P(SERVER,"@",2)
 W !,"ALL DONE",!
 Q

XPDCUSTU
XPDCUSTU ;SLC/STAFF-SITE TRACKING UPDATE ALL VERSIONS, UTILITY ;7/20/94  15:38
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;7.1;Kernel;**22,35**;Oct 25, 1993
 ;
VERSION ; from XPDCUSTP
 ; return version and date of package
 N IFN
 ;
 S IFN=+$O(^DIC(9.4,"B",PACKAGE,0))
 S VERSION=$G(^DIC(9.4,IFN,"VERSION"))
 S DATE=$$DATE(IFN,VERSION)
 S ROUTINES=$P(^TMP("XPDCUP",$J,PACKAGE),U,4) I '$L(ROUTINES) Q
 S ROUTINE="" F CNT=1:1 S ROUTINE=$P(ROUTINES,",",CNT) Q:ROUTINE=""  D
 .S VERSION=$$MAX(VERSION,$$VER(ROUTINE))
 ; if package installed but no 'CURRENT VERSION' in Package file
 I VERSION,'DATE S DATE=$$DATE(IFN,VERSION)
 I 'DATE,VERSION,VERSION'[".",VERSION=+VERSION S VERSION=VERSION_".0",DATE=$$DATE(IFN,VERSION)
 Q
 ;
DATE(IFN,VERSION) ; $$(package ifn,version) -> date of install
 N IFN1
 ;
 I 'VERSION Q ""
 S IFN1=+$O(^DIC(9.4,IFN,22,"B",VERSION,0))
 Q $P($G(^DIC(9.4,IFN,22,IFN1,0)),U,3)
 ;
VER(ROUTINE) ; $$(routine) -> version #
 N STRIP,VER
 ;
 ; get version # from 2nd line of routine
 I '$L(ROUTINE) Q ""
 S VER=$P($T(@ROUTINE+1^@ROUTINE),";",3) I '$L(VER) Q ""
 ;
 ; strip spaces and text from version #
 F  Q:$E(VER)'=" "  S VER=$E(VER,2,245)
 F STRIP="VERSION","Version","version","V","v" I $E(VER,1,$L(STRIP))=STRIP S VER=$E(VER,$L(STRIP)+1,$L(VER)) Q
 F  Q:$E(VER)'=" "  S VER=$E(VER,2,245)
 Q $P(VER," ")
 ;
MAX(V1,V2) ; $$(version1,version2) -> highest version #
 I V1=V2 Q V1
 I +V1>+V2 Q V1
 I +V2>+V1 Q V2
 I V1'?.NP,V1?.ANP,V2?.NP Q V2 ;version1 is test, version2 is verified
 I V2'?.NP,V2?.ANP,V1?.NP Q V1 ;version2 is test, version1 is verified
 I V1?.NP,V2?.NP Q $S($L(V1)>$L(V2):V1,1:V2) ;ex. 4.0 vs 4
 I V1["T",V2["V" Q V2 ;test vs verify
 I V1["V",V2["T" Q V1 ;" "
 I V1["T",V2["T" Q $S(+$P(V1,"T",2)>+$P(V2,"T",2):V1,1:V2) ;highest test
 I V1["V",V2["V" Q $S(+$P(V1,"V",2)>+$P(V2,"V",2):V1,1:V2) ;highest verify
 Q V1 ;give up

XPDDCS
XPDDCS ;SFISC/RSD - Display Checksum for a package ;09/12/96  09:10
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,44**;Jul 10, 1995
EN1 ;print from Transport Global
 N D0,DIC,X,XPD,Y,Z
 S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I $D(^XTMP(""XPDI"",Y))"
 D ^DIC Q:Y<0
 S D0=+Y,XPD("D0")="",X="XUTMDEVQ"
 ;during Virgin install, XUTMDEVQ might not exists
 X ^%ZOSF("TEST") E  D  Q
 .S IOSL=99999,IOM=80,IOF="#",IOST="",$Y=0 D PNT(9.7)
 S Y="PNT^XPDDCS(9.7)",Z="Checksum Print"
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
EN2 ;print from system
 N D0,DIC,XPD,Y,Z
 S DIC="^XPD(9.6,",DIC(0)="AEQMZ"
 D ^DIC Q:Y<0
 S D0=+Y,XPD("D0")="",Y="PNT^XPDDCS(9.6)",Z="Checksum Print"
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
 ;
PNT(XPDFIL) ;print
 N XPD0,XPDC,XPDDT,XPDE,XPDI,XPDJ,XPDPG,XPDQ,XPDUL,X
 Q:'$D(^XPD(XPDFIL,D0,0))  S XPD0=^(0),XPDPG=1,$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM")
 W:$E(IOST,1,2)="C-" @IOF D HDR
 W !
 S XPDI="",(XPDQ,XPDE)=0
 ;XPDFIL=9.7  use transport global exists
 I XPDFIL=9.7 D
 .I '$D(^XTMP("XPDI",D0)) W !!," ** Transport Global doesn't exist **" S XPDQ=1 Q
 .;check for missing nodes in transport global
 .I '$D(^XTMP("XPDI",D0,"BLD"))="" W !!," **Transport Global corrupted, please reload **" S XPDQ=1 Q
 .F XPDC=0:1 S XPDI=$O(^XTMP("XPDI",D0,"RTN",XPDI)) Q:XPDI=""  S XPDJ=$G(^(XPDI)) D  Q:XPDQ
 ..I XPDJ="" W !," **Transport Global corrupted, please reload **" S XPDQ=1 Q
 ..;if deleting at site, there is no checksum
 ..I +XPDJ=1 S XPDC=XPDC-1 Q
 ..D SUM(XPDI,$NA(^XTMP("XPDI",D0,"RTN",XPDI)),$P(XPDJ,U,3))
 ..S XPDQ=$$CHK(4)
 ;check build file
 E  D
 .F XPDC=0:1 S XPDI=$O(^XPD(9.6,D0,"KRN",9.8,"NM","B",XPDI)) Q:XPDI=""  S XPDJ=$O(^(XPDI,0)) D  Q:XPDQ
 ..Q:'$D(^XPD(9.6,D0,"KRN",9.8,"NM",+XPDJ,0))  S XPDJ=$P(^(0),U,4)
 ..;quit if no checksum, routine wasn't loaded
 ..I XPDJ="" S XPDC=XPDC-1 Q
 ..N DIF,XCNP,%N
 ..S X=XPDI,DIF="^TMP($J,""RTN"",XPDI,",XCNP=0
 ..X ^%ZOSF("TEST") E  W !,XPDI,?10,"Doesn't Exist" Q
 ..X ^%ZOSF("LOAD")
 ..D SUM(XPDI,$NA(^TMP($J,"RTN",XPDI)),XPDJ)
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 W !!?3,XPDC," Routine checked, ",XPDE," failed.",!
 Q
 ;
 ;XPDR=routine name, Z=global root, XPD=check sum
SUM(XPDR,Z,XPD) ;check checksum
 N Y
 ;first char. is the sum tag used in XPDRSUM
 I XPD'?1U1.N W !,XPDR,?10,"ERROR in Checksum" S XPDE=XPDE+1 Q
 S @("Y=$$SUM"_$E(XPD)_"^XPDRSUM(Z)"),XPD=$E(XPD,2,255)
 I Y'=XPD W !,XPDR,?10,"Calculated "_$C(7)_Y_", should be "_XPD S XPDE=XPDE+1
 Q
 ;
CHK(Y) ;Y=excess lines, return 1 to exit
 Q:$Y<(IOSL-Y) 0
 I $E(IOST,1,2)="C-" D  Q:'Y 1
 .N DIR,I,J,K,X
 .S DIR(0)="E" D ^DIR
 S XPDPG=XPDPG+1
 W @IOF D HDR
 Q 0
 ;
HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!,XPDUL,!
 Q

XPDDI
XPDDI ;SFISC/RSD - Display an Install ; 29 Feb 96 13:10
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21**;Jul 10, 1995
EN1 ;print from Install file
 N DIC,D0,XPD,Y,Z
 S DIC="^XPD(9.7,",DIC(0)="AEMQZ" D ^DIC Q:Y'>0
 S D0=+Y,XPD("D0")="",Y="PNT^XPDDI",Z="Install File Print"
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
 ;
PNT ;print a package
 N X,XPD,XPDDT,XPDI,XPDJ,XPD0,XPDPG,XPDQ,XPDUL
 Q:'$D(^XPD(9.7,D0,0))  S XPD0=^(0),XPDJ=$G(^(1)),XPDPG=1,$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM")
 W:$E(IOST,1,2)="C-" @IOF D HDR
 W "STATUS: ",$$EXTERNAL^DILFD(9.7,.02,"",$P(XPD0,U,9)),?42,"DATE LOADED: ",$$EXTERNAL^DILFD(9.7,2,"",$P(XPD0,U,3))
 W !,"INSTALLED BY: ",$$EXTERNAL^DILFD(9.7,9,"",$P(XPD0,U,11))
 W !,"NATIONAL PACKAGE: ",$$EXTERNAL^DILFD(9.7,1,"",$P(XPD0,U,2))
 W !!,"INSTALL STARTED: ",$$EXTERNAL^DILFD(9.7,11,"",$P(XPDJ,U))
 W:$P(XPDJ,U,3) ?45,$P($$EXTERNAL^DILFD(9.7,17,"",$P(XPDJ,U,3)),"@",2),?65,$$DIFF($P(XPDJ,U,3),$P(XPDJ,U))
 ;XPD is start date/time
 S XPD=+$P(XPDJ,U)
 W !!,"ROUTINES:",?45,$P($$EXTERNAL^DILFD(9.7,12,"",$P(XPDJ,U,2)),"@",2),?65,$$DIFF($P(XPDJ,U,2),XPD),!
 ;XPD is the last complete time, it is also the next start time
 S XPDQ=0 S:$P(XPDJ,U,2) XPD=$P(XPDJ,U,2)
 I $O(^XPD(9.7,D0,"INI",1)) D
 .W !,"PRE-INIT CHECK POINTS:",! S XPDI=1
 .F  S XPDI=$O(^XPD(9.7,D0,"INI",XPDI)) Q:'XPDI  S X=^(XPDI,0) D  Q:XPDQ
 ..W $P(X,U),?45,$P($$EXTERNAL^DILFD(9.713,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 ..S XPDQ=$$CHK(4)
 .Q:XPDQ  S X=^XPD(9.7,D0,"INI",1,0)
 .W $P(X,U),?45,$P($$EXTERNAL^DILFD(9.713,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 .S XPDQ=$$CHK(4)
 Q:XPDQ
 I $O(^XPD(9.7,D0,4,0)) D
 .W !,"FILES:",! S XPDI=0
 .F  S XPDI=$O(^XPD(9.7,D0,4,XPDI)) Q:'XPDI  S X=^(XPDI,0) D  Q:XPDQ
 ..W $P($G(^DIC(+$P(X,U),0)),U),?45,$P($$EXTERNAL^DILFD(9.714,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 I $O(^XPD(9.7,D0,"KRN","AC",0)) D
 .W ! S XPDI=0
 .F  S XPDI=$O(^XPD(9.7,D0,"KRN","AC",XPDI)) Q:'XPDI  S XPDJ=$O(^(XPDI,0)) D  Q:XPDQ
 ..Q:'$D(^XPD(9.7,D0,"KRN",XPDJ,0))  S X=^(0)
 ..Q:'$D(^DIC(XPDJ,0))#2  W $P(^(0),U)
 ..W ?45,$P($$EXTERNAL^DILFD(9.715,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 I $O(^XPD(9.7,D0,"GLO",0)) D
 .W !,"GLOBALS:",! S XPDI=0
 .F  S XPDI=$O(^XPD(9.7,D0,"GLO",XPDI)) Q:'XPDI  S X=^(XPDI,0) D  Q:XPDQ
 ..W $P(X,U),?45,$P($$EXTERNAL^DILFD(9.718,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 I $O(^XPD(9.7,D0,"INIT",1)) D
 .W !,"POST-INIT CHECK POINTS:",! S XPDI=1
 .F  S XPDI=$O(^XPD(9.7,D0,"INIT",XPDI)) Q:'XPDI  S X=^(XPDI,0) D  Q:XPDQ
 ..W $P(X,U),?45,$P($$EXTERNAL^DILFD(9.716,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 ..S XPDQ=$$CHK(4)
 .Q:XPDQ  S X=^XPD(9.7,D0,"INIT",1,0)
 .W $P(X,U),?45,$P($$EXTERNAL^DILFD(9.716,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),XPD),!
 .S XPDQ=$$CHK(4)
 I $O(^XPD(9.7,D0,"VOL",0)) D
 .W !,"OTHER CPUs:",! S XPDI=0
 .F  S XPDI=$O(^XPD(9.7,D0,"VOL",XPDI)) Q:'XPDI  S X=^(XPDI,0) D  Q:XPDQ
 ..W $P(X,U),"  STARTED ",$P($$EXTERNAL^DILFD(9.703,2,"",$P(X,U,3)),"@",2)
 ..W ?45,$P($$EXTERNAL^DILFD(9.703,1,"",$P(X,U,2)),"@",2),?65,$$DIFF($P(X,U,2),$P(X,U,3)),!
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 I $O(^XPD(9.7,D0,"QUES",0)) D
 .W !,"INSTALL QUESTION PROMPT",?70,"ANSWER",! S XPDI=0
 .F  S XPDI=$O(^XPD(9.7,D0,"QUES",XPDI)) Q:'XPDI  S X=$P(^(XPDI,0),U),XPD=$G(^("A")),XPDJ=$G(^("B")) D  Q:XPDQ
 ..W !,X,"   ",XPD,?70,XPDJ
 ..S XPDQ=$$CHK(4)
 Q:XPDQ
 W !,"MESSAGES:",!
 S XPDI=0
 F  S XPDI=$O(^XPD(9.7,D0,"MES",XPDI)) Q:'XPDI  I $D(^(XPDI,0)) W ^(0),! S XPDQ=$$CHK(4) Q:XPDQ
 Q
 ;
CHK(Y) ;Y=excess lines, return 1 to exit
 Q:$Y<(IOSL-Y) 0
 I $E(IOST,1,2)="C-" D  Q:'Y 1
 .N DIR,I,J,K,X
 .S DIR(0)="E" D ^DIR
 S XPDPG=XPDPG+1
 W @IOF D HDR
 Q 0
 ;
DIFF(X,Y) ;returns diff of X-Y
 I 'X Q ""
 S XPD=X
 Q $$FMDIFF^XLFDT(X,Y,3)
 ;
HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!,?45,"COMPLETED",?65,"ELAPSED",!,XPDUL,!
 Q

XPDDP
XPDDP ;SFISC/RSD - Display a package ;03/10/98  13:44
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
EN1 ;print from Build file
 N DIC,D0,XPD,Y,Z
 S DIC="^XPD(9.6,",DIC(0)="AEMQZ" D ^DIC Q:Y'>0
 S D0=+Y,XPD("D0")="",Y="PNT^XPDDP(""XPD(9.6,D0)"")",Z="Build File Print"
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
EN2 ;print from Distribution
 N D0,DIC,POP,XPD,XPDA,XPDNM,Y,Z,%ZIS
 S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I $D(^XTMP(""XPDI"",Y))"
 D ^DIC Q:Y<0
 S XPD("D0")="",XPD("XPDA")="",XPDA=+Y,Y="PNT^XPDDP(""XTMP(""""XPDI"""",XPDA,""""BLD"""",D0)"")",Z="Transport Global Print",D0=$O(^XTMP("XPDI",XPDA,"BLD",0))
 Q:'D0
 D EN^XUTMDEVQ(Y,Z,.XPD)
 Q
 ;
PNT(XPDGR) ;print a package, XPDGR=global root
 ;XPDFL=0 - Build - ^XPD(9.7 global root, 1 - Install - ^XTMP global root
 ;2 - Packman ^TMP($J, global root
 N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK
 Q:$G(XPDGR)=""  S XPDGR="^"_XPDGR
 Q:'$D(@XPDGR@(0))
 S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5)
 W:$E(IOST,1,2)="C-" @IOF D HDR W XPDUL,!
 W "TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
 W !,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
 W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
 W !,"DESCRIPTION:",!
 S XPDI=0 F  S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI  I $D(^(XPDI,0)) W ^(0),! Q:$$CHK(4)
 Q:$D(DIRUT)  G:XPDTYPE=1 MULT
 W !,"ENVIRONMENT CHECK : ",$G(@XPDGR@("PRE")),!
 W:'XPDTYPE " PRE-INIT ROUTINE : ",$G(@XPDGR@("INI")),!
 Q:$$CHK(4)  W "POST-INIT ROUTINE : ",$G(@XPDGR@("INIT")),!
 W:'XPDTYPE "PRE-TRANSPORT RTN : ",$G(@XPDGR@("PRET")),!
 G:XPDTYPE=2 GLOBAL
 I '$O(@XPDGR@(4,0)) Q:$$CHK(4)  G COMP
 S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !! D HDR1 W XPDUL,!
PNT2 S XPDI=0 F  S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,222)) Q:$$CHK(4,1)  D
 .;file number, file name, partial DD
 .W !,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
 .W ?41,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?47,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?53,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
 .W ?60,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?67,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?73,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)),!
 .;print partial DD information
 .I $P(XPD,U,3)="p" S J=0 D
 ..W "Partial DD:"
 ..F  S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J  W ?12,"subDD: ",J D  Q:$$CHK(4,1)
 ...I '$O(@XPDGR@(4,"APDD",XPDI,J,0)) W ! Q
 ...S I=0 F  S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I  W ?30,"fld: ",I,!
 .I $D(@XPDGR@(4,XPDI,223)) W ?2,"DD SCREEN  : ",^(223),!
 .I $D(@XPDGR@(4,XPDI,224)) W ?2,"DATA SCREEN: ",^(224),!
COMP Q:$D(DIRUT)  W ! Q:$$CHK(3)  S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
 ;print build components
 F  S I=$O(@XPDGR@("KRN",I)),K=0,J="" Q:$D(DIRUT)!'I  F  S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J=""  S X=$O(^(J,0)) Q:$$CHK(4)  D:X
 .S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
 .;K is flag to write type of component
 .I 'K W !,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",! S K=1
 .;write the entry name and write the action
 .W ?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2),!
 Q:XPDFL=2
 ;XPDFL=2 this is a Packman message, called from XMP2 - Summarize
 ;XPDFL=1 this is a Install, the call backs are already Build Components
 Q:$D(DIRUT)  Q:$$CHK(3)
 I $O(@XPDGR@("QUES",0)) W !,"INSTALL QUESTIONS: " S I=0 D
 .F  S I=$O(@XPDGR@("QUES",I)) Q:'I  S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) Q:$$CHK(5)  D
 ..W !?5,"SUBSCIRPT: ",X,!,"DIR(0)=",J W:K]"" !,"DIR(""A"")=",K,!
 ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"A1",J,0))  W "DIR(""A"",",J,")=",^(0),!
 ..I $G(@XPDGR@("QUES",I,"B"))]"" W "DIR(""B"")=",^("B"),!
 ..I $G(@XPDGR@("QUES",I,"Q"))]"" W "DIR(""?"")=",^("Q"),!
 ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"Q1",J,0))  W "DIR(""?"",",J,")=",^(0),!
 ..I $G(@XPDGR@("QUES",I,"QQ"))]"" W "DIR(""??"")=",^("QQ"),!
 ..I $G(@XPDGR@("QUES",I,"M"))]"" W "M CODE: ",^("M"),!
 Q:$D(DIRUT)  Q:$$CHK(3)
 I $L($G(@XPDGR@("ABPKG"))) S XPD=^("ABPKG") D:$P(XPD,U)="y"
 .W !,"ALPHA/BETA TESTING:",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?40,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
 .W !,"ADDRESS: ",$P(XPD,U,3),!!,"INCLUDE NAMESPACE",?30,"EXCLUDE NAMESPACE" S I=0
 .F  S I=$O(@XPDGR@("ABNS",I)),J=0 Q:'I  W !?5,^(I,0) F  S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J  W ?35,^(J,0),! Q:$$CHK(3)
REQB Q:$D(DIRUT)  Q:$$CHK(4)
 I $O(@XPDGR@("REQB",0)) W !,"REQUIRED BUILDS:",?50,"ACTION:" D
 .S XPDI=0 F  S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
 ..W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
 Q
GLOBAL ;globals listing
 S I=$$CHK(8,1) Q:I  I '$P(I,"^",2) W !!,"GLOBAL:",?20,"KILL GLOBAL BEFORE INSTALL:"
 S XPDI=0 F  S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
 .W !?3,$P(XPD,U),?33,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
 W ! Q
 ;
MULT ;multiple-package
 S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !,"PACKAGE:"
 S XPDI=0 F  S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
 .W !?3,$P(XPD,U)
 W ! Q
 ;
 ;return 0 if header was not written, else "0^1"
CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
 Q:$Y<(IOSL-Y) 0
 I $E(IOST,1,2)="C-" D  Q:'Y 1
 .N DIR,I,J,K,X
 .S DIR(0)="E" D ^DIR
 S XPD=$G(XPD),XPDPG=XPDPG+1
 W @IOF D HDR,HDR1:XPD
 W XPDUL,!
 Q "0^1"
 ;
XMP2(X,D0) ;called from ^XMP2
 N XPDA S XPDA=-1
 D PNT(X) Q
 ;
HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!
 Q
HDR1 W ?41,"UP",?47,"SEND",?53,"DATA",?73,"USER",!,?41,"DATE",?47,"SEC.",?53,"COMES",?60,"SITE",?67,"RSLV",?73,"OVER"
 W !,"FILE #",?12,"NAME",?41,"DD",?47,"CODE",?53,"W/FILE",?60,"DATA",?67,"PTS",?73,"RIDE",!
 Q

XPDDPCK
XPDDPCK ;SFISC/RSD - Display a Package file information ;10/03/96  10:15
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**44**;Jul 05, 1995
EN1 ;print all Patches for Package version
 N DIC,DIR,DIRUT,XPD,XPD0,XPDFL,XPDNM,XPDV,Y,Z
 S DIC="^DIC(9.4,",DIC(0)="AEMQZ" D ^DIC Q:Y'>0
 I '$D(^DIC(9.4,+Y,22,0)) W !!,"This Package has no VERSION multiple",! Q
 S XPD0=+Y,DIC=DIC_XPD0_",22," S:$G(^DIC(9.4,XPD0,"VERSION")) DIC("B")=$P(^("VERSION"),U)
 D ^DIC Q:Y'>0
 S XPDV=+Y,DIR(0)="Y",DIR("A")="Do you want to see the Descriptions",DIR("B")="NO"
 D ^DIR Q:$D(DIRUT)
 S XPDFL=Y,X="PNT^XPDDPCK",Z="Package File Print"
 F Y="XPD0","XPDFL","XPDV" S XPD(Y)=""
 D EN^XUTMDEVQ(X,Z,.XPD)
 Q
 ;
PNT ;print a package
 N DIRUT,I,J,K,X,XPD,XPDDT,XPDI,XPDPG,XPDUL,XPDV0
 Q:'$G(XPD0)!'$G(XPDV)!'$D(XPDFL)
 Q:'$D(^DIC(9.4,XPD0,0))  S XPDNM=$P(^(0),U) Q:'$D(^(22,XPDV,0))  S XPDV0=^(0)
 S XPDPG=1,$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM")
 W:$E(IOST,1,2)="C-" @IOF D HDR
 W "VERSION: ",$P(XPDV0,U),?20,$$EXTERNAL^DILFD(9.49,2,"",$P(XPDV0,U,3)),?50,$$EXTERNAL^DILFD(9.49,3,"",$P(XPDV0,U,4))
 ;diplay version description
 I XPDFL W ! D DES("^DIC(9.4,"_XPD0_",22,"_XPDV_",1)") Q:$D(DIRUT)
 W ! S XPDI=0
 F  S XPDI=$O(^DIC(9.4,XPD0,22,XPDV,"PAH",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4)  D  Q:$D(DIRUT)
 .;patch history
 .W !?3,$P(XPD,U),?20,$$EXTERNAL^DILFD(9.4901,.02,"",$P(XPD,U,2)),?50,$$EXTERNAL^DILFD(9.4901,.03,"",$P(XPD,U,3))
 .I XPDFL W ! D DES("^DIC(9.4,"_XPD0_",22,"_XPDV_",""PAH"","_XPDI_",1)") 
 W ! Q
 ;
CHK(Y) ;Y=excess lines, return 1 to exit & DIRUT is set
 Q:$Y<(IOSL-Y) 0
 I $E(IOST,1,2)="C-" D  Q:'Y 1
 .N DIR,I,J,K,X
 .S DIR(0)="E" D ^DIR
 S XPDPG=XPDPG+1
 W @IOF D HDR
 Q 0
 ;
DES(XPDGR) ;display description, XPDGR=global root
 N XPDI S XPDI=0
 F  S XPDI=$O(@XPDGR@(XPDI)) Q:'XPDI  I $D(^(XPDI,0)) W ^(0),! Q:$$CHK(4)
 Q
 ;
HDR W !,"PACKAGE: ",XPDNM,"     ",XPDDT,?70,"PAGE ",XPDPG,!,"PATCH #",?20,"INSTALLED",?50,"INSTALLED BY"
 W:XPDFL !?5,"DESCRIPTION"
 W !,XPDUL,!
 Q

XPDE
XPDE ;SFISC/RSD - Package Edit ;03/10/98  10:29 [ 05/11/98  4:38 PM ]
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,15,21,44,51,68**;Jul 10, 1995
 Q
 ;these tags are called from options.
EDIT ;edit Build file package
 N DA,DIR,DDSFILE,DR,Y,Z
 Q:'$$DIC("AEMQLZ","",1)  S DA=+Y
 I $P(Y,U,3) D NEW(DA)
 S Z=$P(^XPD(9.6,DA,0),U,3)+1,DR="["_$P("XPD EDIT BUILD^XPD EDIT MP^XPD EDIT GP",U,Z)_"]",DDSFILE="^XPD(9.6,"
 D ^DDS Q:'$G(DA)
 ;if full DD, kill multiple for partial DD
 S Y=0 F  S Y=$O(^XPD(9.6,DA,4,Y)) Q:'Y  S Z=$G(^(Y,222)) D
 .K:$P(Z,U,3)="f" ^XPD(9.6,DA,4,Y,2),^XPD(9.6,DA,4,"APDD",Y)
 D QUIT(DA)
 Q
COPY ;copy a Build file package
 N DA,DIK,DIR,FR,FR0,TO,TO0,X,Y,Z W !
 Q:'$$DIC("QEAMZ","Copy FROM what Package: ")
 S FR=+Y,FR0=Y(0),Z="QEAMZL",Z("S")="I Y'="_FR
 I '$$DIC(.Z,"Copy TO what Package: ") D QUIT(FR) Q
 S TO=Y,TO0=Y(0)
 ;if this is not new, then it will be purged before copy.
 I '$P(TO,U,3) W !,$P(TO0,U)," package will be PURGED before the copy."
 W ! S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
 S DIK="^XPD(9.6,",DA=+TO
 I 'Y!$D(DIRUT) D  W ! Q
 .;they didn't want to continue, kill if it was a new package.
 .I $P(TO,U,3) D ^DIK W $P(TO0,U)," being deleted!"
 .;unlock both packages
 .D QUIT(FR),QUIT(TO)
 D WAIT^DICD
 ;if not new, kill old data
 K:'$P(TO,U,3) ^XPD(9.6,DA)
 M ^XPD(9.6,DA)=^XPD(9.6,FR) S $P(^(DA,0),U)=$P(TO0,U)
 D NEW(+TO)
 ;if new National Package name, then kill x-ref
 I $P(TO0,U,2)]"",$P(FR0,U,2)'=$P(TO0,U,2) K ^XPD(9.6,"C",$E($P(TO0,U,2),1,30),DA) S DIK(1)=1 D EN1^DIK
 D QUIT(FR),QUIT(TO)
 W "...Done.",!
 Q
BUILD ;build package from a namespace
 N DIR,DIRUT,XPDA,XPDI,XPDF,XPDN,XPDX,XPDXL,X,X1,Y,Y1 W !
 Q:'$$DIC("QEAML")
 S XPDA=+Y W !
 I $P(^XPD(9.6,XPDA,0),U,3) W !,"The Build Type must be SINGLE PACKAGE!!",! Q
 ;if not a new package
 I '$P(Y,U,3) D  I $D(DIRUT) D QUIT(XPDA) Q
 .S DIR(0)="Y",DIR("A")="Package already exists, Want to PURGE the existing data",DIR("B")="NO",DIR("?")="YES will delete all the KERNEL FILE information for this package in the BUILD file."
 .D ^DIR K DIR Q:'Y
 .S Y=0 F  S Y=$O(^XPD(9.6,XPDA,"KRN",Y)) Q:'Y  K ^(Y,"NM")
 E  D NEW(XPDA)
 ;XPDN(0=excluded names or 1=include names, namespace)=""
 W ! S DIR(0)="FO^1:15^K:X'?.1""-""1U.15UNP X",DIR("A")="Namespace",DIR("?")="Enter 1 to 15 characters, preceed with ""-"" to exclude namespace"
 F  D ^DIR Q:$D(DIRUT)  S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))=""
 I '$D(XPDN)!$D(DTOUT)!$D(DUOUT) D QUIT(XPDA) Q
 W !!,"NAMESPACE  INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
 S (X,Y)="",(X1,Y1)=1
 F  D  W !?11,X,?35,Y Q:'X1&'Y1
 .S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
 S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
 I 'Y!$D(DIRUT) D QUIT(XPDA) Q
 D WAIT^DICD S XPDX="",XPDI("IEN")=0
 F  S XPDX=$O(XPDN(1,XPDX)),XPDXL=$L(XPDX),XPDF=0 Q:XPDX=""  D
 .F  S XPDF=$O(^XPD(9.6,XPDA,"KRN",XPDF)) Q:'XPDF  D
 ..N XPD,XPDIC,XPDJ W "."
 ..;XPDIC is used in $$SCR1^XPDET
 ..S XPDIC="^XPD(9.6,"_XPDA_",""KRN"","_XPDF_",""NM"","
 ..D LIST^DIC(XPDF,"","","","*",.XPDI,XPDX,"","I $E(^(0),1,XPDXL)=XPDX,$$SCR1^XPDET(Y)")
 ..F XPDJ=1:1 S X=$G(^TMP("DILIST",$J,1,XPDJ)) Q:X=""  D
 ...S:XPDF<.404 %=^TMP("DILIST",$J,2,XPDJ)_",",X=$$TX^XPDET(X,$$GET1^DIQ(XPDF,%,$$TF^XPDET(XPDF),"I"))
 ...S Y="+"_XPDJ_","_XPDF_","_XPDA_",",XPD(9.68,Y,.01)=X,XPD(9.68,Y,.03)=0
 ..Q:'$D(XPD)  D UPDATE^DIE("","XPD")
 D QUIT(XPDA)
 W "...Done.",!
 Q
VER ;verify a Build file package
 N XPDA,Y
 Q:'$$DIC("AEMQZ")  S XPDA=+Y
 D EN^XPDV
 Q
DIC(DIC,A,XPDL) ;DIC lookup to Build file, 9.6
 N DLAYGO
 S DIC(0)=$G(DIC),DIC="^XPD(9.6," S:$G(A)]"" DIC("A")=A
 S:DIC(0)["L" DLAYGO=9.6,DIC("DR")="1;2//SINGLE PACKAGE;5//YES"
 D ^DIC Q:Y<0 0
 I '$G(XPDL) L +^XPD(9.6,+Y):0 E  W !,"Being accessed by another user" Q 0
 Q +Y
 ;
NEW(DA) ;create Kernel Files multiple for package DA
 N I,J,X,XPDNEWF,XPD,XPDI
 S:'$D(^XPD(9.6,DA,"KRN",0)) ^XPD(9.6,DA,"KRN",0)=U_$P(^DD(9.6,7,0),U,2)
 S I=0
 F J=1:1 S X=+$P($T(FILES+J),";;",2) Q:'X  S:$D(^DD(X))&'$D(^XPD(9.6,DA,"KRN",X)) I=I+1,(XPDI(I),XPD(9.67,"+"_I_","_DA_",",.01))=X
 Q:'$D(XPD)
 ;XPDNEWF is a flag in INPUT transform of BUILD COMPONENT multiple
 S XPDNEWF=1
 D UPDATE^DIE("","XPD","XPDI")
 Q
QUIT(Y) ;unlock Y
 L -^XPD(9.6,Y)
 Q
 ;
 ;;file;install order;x-ref;file build;entry build;file pre;entry pre;file post;entry post;delete
FILES ;kernel files for field 7 in file 9.6
 ;;9.8;;1;RTNF^XPDTA;RTNE^XPDTA
 ;;9.2;1;;;HELP^XPDTA1;HLPF1^XPDIA1;HLPE1^XPDIA1;HLPF2^XPDIA1;;HLPDEL^XPDIA1
 ;;3.6;2;1;;BUL^XPDTA1;;BULE1^XPDIA1;;;BULDEL^XPDIA1
 ;;19.1;3;1;;KEY^XPDTA1;;;;;KEYDEL^XPDIA1
 ;;.5;4;;;EDEOUT^DIFROMSO(.5,DA,"",XPDA);FPRE^DIFROMSI(.5,"",XPDA);EPRE^DIFROMSI(.5,DA,"",XPDA,"",OLDA);;EPOST^DIFROMSI(.5,DA,"",XPDA)
 ;;.4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%)
 ;;.401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%)
 ;;.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
 ;;.403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%)
 ;;.84;9;;;EDEOUT^DIFROMSO(.84,DA,"",XPDA);FPRE^DIFROMSI(.84,"",XPDA);EPRE^DIFROMSI(.84,DA,"",XPDA,"",OLDA);;EPOST^DIFROMSI(.84,DA,"",XPDA);DEL^DIFROMSK(.84,"",%)
 ;;3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1
 ;;869.2;12;1;;HLLLP^XPDTA1;;HLLLPE^XPDIA1
 ;;870;13;1;;HLLL^XPDTA1;;HLLLE^XPDIA1
 ;;771;14;;;HLAP^XPDTA1;HLAPF1^XPDIA1;HLAPE1^XPDIA1;HLAPF2^XPDIA1
 ;;101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA
 ;;8994;16;1;;;;;;;RPCDEL^XPDIA1
 ;;409.61;17;1;;;;;;;LMDEL^XPDIA1
 ;;19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA

XPDER
XPDER ;SFISC/RSD - Rollup Patches into Build ;09/13/96  09:04
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**44**;Jul 10, 1995
EN1 ;rollup patches into new build
 N DIR,DIRUT,XPD,XPDA,XPDIT,XPDF,XPDFL,XPDJ,XPDNM,XPDVER,XPDPKG,XPDT,XPDY,X,Y,Z W !
 ;only find Single packages, not patches, that have a Package file link
 S Z="AEMQZ",Z("S")="S %=$G(^(0)) I $P(%,U)'[""*"",$D(^DIC(9.4,+$P(%,U,2),0)),'$P(%,U,3)"
 Q:'$$DIC^XPDE(.Z,"Rollup patches into Build: ")
 S XPDA=+Y,XPDNM=$P(Y(0),U),XPDPKG=+$P(Y(0),U,2),XPDVER=$$VER^XPDUTL(XPDNM)
 ;check if package contains patches
 S (Y,Z)=0
 F  S Y=$O(^XPD(9.6,XPDA,10,Y)) Q:'Y  S X=^(Y,0) D
 .I 'Z W !,"This package already contains the following patches:" S Z=1
 .W !?3,X
 W !!,"The following patches can be rolled into Package ",XPDNM,!
 S X=0 F  S X=$O(^XPD(9.6,"C",XPDPKG,X)) Q:'X  D
 .Q:'$D(^XPD(9.6,X,0))  S Y=$P(^(0),U)
 .I $P(Y,"*",2)=XPDVER,'$D(^XPD(9.6,XPDA,10,"B",Y))  S XPDT(X)=Y W ?5,Y,!
 I '$D(XPDT) W !!,"No patches exist" D QUIT^XPDE(XPDA) Q
 S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
 I 'Y!$D(DIRUT) D QUIT^XPDE(XPDA) W ! Q
 D WAIT^DICD S XPDIT=0
 F  S XPDIT=$O(XPDT(XPDIT)),(XPDF,XPDFL)=0 Q:'XPDIT  D
 .;loop through Files
 .N DA,DIK
 .F  W "." S XPDF=$O(^XPD(9.6,XPDIT,4,XPDF)) Q:'XPDF  K XPD M XPD(XPDF)=^(XPDF) D
 ..;if file doesn't exist in original build
 ..I '$D(^XPD(9.6,XPDA,4,XPDF)) M ^(XPDF)=XPD(XPDF) S XPDFL=1 Q
 ..S Y=$G(^XPD(9.6,XPDA,4,XPDF,222))
 ..;if original is a full DD do nothing
 ..I $P(Y,U,3)="f" K XPD(XPDF) Q
 ..I $P($G(XPD(XPDF,222)),U,3)="f" K ^XPD(9.6,XPDA,4,XPDF) M ^(XPDF)=XPD(XPDF) S XPDFL=1 Q
 ..;since it must be a partial, don't need these nodes
 ..K XPD(XPDF,0),XPD(XPDF,222),XPD(XPDF,223),XPD(XPDF,224)
 ..S XPDJ=0
 ..;loop thru incoming partial subDD's
 ..F  S XPDJ=$O(XPD(XPDF,2,XPDJ)) Q:'XPDJ  D
 ...;if original has this subDD and doesn't have any field, then it is taking the entire subDD, so don't care about incoming
 ...I '$D(^XPD(9.6,XPDA,4,XPDF,2,XPDJ)) M ^(XPDJ)=XPD(XPDF,2,XPDJ) Q
 ...I '$O(^XPD(9.6,XPDA,4,XPDF,2,XPDJ,1,0)) K XPD(XPDF,2,XPDJ) Q
 ...S XPDY=0
 ...F  S XPDY=$O(XPD(XPDF,2,XPDJ,1,XPDY)) Q:'XPDY  D
 ....I $D(^XPD(9.6,XPDA,4,XPDF,2,XPDJ,1,XPDY)) K XPD(XPDF,2,XPDJ,1,XPDY) Q
 ....M ^XPD(9.6,XPDA,4,XPDF,2,XPDJ,1,XPDY)=XPD(XPDF,2,XPDJ,1,XPDY)
 ...Q:'$O(XPD(XPDF,2,XPDJ,1,0))
 ...K DA,XPD(XPDF,2,XPDJ)
 ...S DA(3)=XPDA,DA(2)=XPDF,DA(1)=XPDJ,DIK="^XPD(9.6,"_XPDA_",4,"_XPDF_",2,"_XPDJ_",1," D IXALL^DIK
 ..Q:'$O(XPD(XPDF,2,0))
 ..K DA,XPD(XPDF)
 ..S DA(2)=XPDA,DA(1)=XPDF,DIK="^XPD(9.6,"_XPDA_",4,"_XPDF_",2," D IXALL^DIK
 .;XPDFL=1 if we merged data into node 4 at top level
 .I XPDFL K DA S DA(1)=XPDA,DIK="^XPD(9.6,"_XPDA_",4," D IXALL^DIK
 .;loop through Build Components
 .S XPDF=0 F  S XPDF=$O(^XPD(9.6,XPDIT,"KRN",XPDF)) Q:'XPDF  D
 ..K XPD S (XPDJ,XPDY)=0 W "."
 ..F  S XPDY=$O(^XPD(9.6,XPDIT,"KRN",XPDF,"NM",XPDY)) Q:XPDY=""  S XPDX=$G(^(XPDY,0)) D:$P(XPDX,U)]""
 ...;quit if components exist in original build
 ...Q:$D(^XPD(9.6,XPDA,"KRN",XPDF,"NM","B",$P(XPDX,U)))
 ...S XPDJ=XPDJ+1,Y="+"_XPDJ_","_XPDF_","_XPDA_",",XPD(9.68,Y,.01)=$P(XPDX,U),XPD(9.68,Y,.03)=$P(XPDX,U,3)
 ..Q:'$D(XPD)  D UPDATE^DIE("","XPD")
 .;put patch in mulitple
 .K XPD S XPD(9.63,"+1,"_XPDA_",",.01)=XPDT(XPDIT)
 .D UPDATE^DIE("","XPD")
 D QUIT^XPDE(XPDA) W "...Done.",!
 Q

XPDET
XPDET ;SFISC/RSD - Input tranforms & help for file 9.6 & 9.7 ;06/11/97  14:42
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,39,41,44,51,58,66**;Jul 10, 1995
 Q
INPUTB(X) ;input tranfrom for NAME in BUILD file
 ;X=user input
 ;name must be unique
 I $L(X)>50!($L(X)<3)!$D(^XPD(9.6,"B",X)) K X Q
 I X["*" K:$P(X,"*",2,3)'?1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N X Q
 S %=$L(X," ") I %<2 K X Q
 S %=$P(X," ",%) K:%'?1.2N1"."1.2N.1(1"V",1"T").2N X
 Q
INPUTE(X) ;input transform for ENTRIES in KERNEL FILES multiple
 ;X=user input
 N D,DD,DIC,DICR,DIX,DIY,DS,DO,XPDLK,Y
 S XPDLK=$$GR(D1)
 I XPDLK=""!X["*" K X Q
 S DIC(0)="QEMZ",DIC=XPDLK
 S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]"""""
 D ^DIC K:Y<0 X Q:'$D(X)
 S X=Y(0,0)
 ;check that this doesn't exist already
 I $D(^XPD(9.6,D0,"KRN",D1,"NM","B",X)) K X Q
 ;if fm file, change X to contain file # of template
 I D1<.404 S X=$$TX(X,$P(Y(0),U,$S(D1=.403:8,1:4)))
 Q
GLOBALE(X) ;input transform for GLOBAL multiple .01 field in file 9.6
 I $L(X)>30!($L(X)<2) K X Q
 I X["(",X'[")" K X Q
 ;change ' back to " for subscripts, they were changed in the Pre-Lookup node of the DD, 7.5. This was done to trick FM, which doesn't allow " in .01 fields
 S X=$TR(X,"'","""")
 I '$D(@("^"_X)) K X
 Q
INPUTMB(X) ;input transform for field 10 and 11 in file 9.6
 ;X=user input
 N D,DD,DIC,DICR,DIX,DIY,DS,DO,Y
 ;can't select a global or multi package or itself (D0)
 S DIC(0)="QEMZ",DIC="^XPD(9.6,",DIC("S")="I '$P(^(0),U,3),Y'="_D0
 D ^DIC K:Y<0 X Q:'$D(X)
 S X=Y(0,0)
 Q
LOOKE(X) ;special lookup for ENTRIES in KERNEL FILES multiple
 Q:X'?1.E1"*"
 N %,XPD,XPDI,XPDIC,XPDF,XPDLK,XPDX,Y
 S XPDLK=$$GR(D1),XPDIC=DIC,XPDF=D1
 I XPDLK="" K X Q
 G:$E(X)="-" DEL
 S XPDX=$P(X,"*"),XPDI("IEN")=0
 D LIST^DIC(D1,"","","","*",.XPDI,XPDX,"","I $$SCR^XPDET(Y)")
 I '$G(^TMP("DILIST",$J,0)) K X Q
 K ^TMP("XPDX",$J)
 ;loop thru list from lister and file using UPDATE^DIE
 F XPDI=1:1 S X=$G(^TMP("DILIST",$J,1,XPDI)) Q:X=""  D
 .S:D1<.404 %=^TMP("DILIST",$J,2,XPDI)_",",X=$$TX(X,$$GET1^DIQ(D1,%,$$TF(D1),"I"))
 .S Y="+"_XPDI_","_D1_","_D0_",",^TMP("XPDX",$J,9.68,Y,.01)=X,^(.03)=0
 I $D(^TMP("XPDX",$J)) D UPDATE^DIE("","^TMP(""XPDX"",$J)","^TMP(""XPD"",$J)")
 ;if in Screenman then call MLOAD to update screen
 I $D(DDS),$D(^TMP("XPD",$J)) D MLOAD^DDSUTL("^TMP(""XPD"",$J)")
 S X=""
 K ^TMP("XPDX",$J),^TMP("XPD",$J)
 Q
DEL ;delete using wild card
 I X'?1"-"1.E1"*" K X Q
 S X=$E(X,2,$L(X)-1),XPDX=X S:$L(X) XPDI("IEN")=0
 D LIST^DIC(9.68,","_D1_","_D0_",","","","*",.XPDI,XPDX)
 I '$G(^TMP("DILIST",$J,0)) K X Q
 N DIK,DA,D2
 S DIK=XPDIC,DA(1)=D1,DA(2)=D0
 F XPDI=1:1 S (DA,D2)=$G(^TMP("DILIST",$J,2,XPDI)) Q:'DA  D
 .D ^DIK
 I $D(DDS) D MDEL^DDSUTL("^TMP(""DILIST"",$J,2)")
 S X=""
 K ^TMP("DILIST",$J)
 Q
HELP ;executable help of ENTRIES in KERNEL FILE multiple
 N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
 ;file 9.8 is routine file, check that routine exists
 S DIC=$$GR(D1),DIC(0)="M",X="??" Q:DIC=""  S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]"""""
 D ^DIC Q
 ;
HELPO ;executable help of INSTALL ORDER in KERNEL FILES multiple
 N Y
 W !,"Numbers in use:  ORDER     FILE#" S Y=0
 F  S Y=$O(^XPD(9.6,D0,"KRN","AC",Y)) Q:'Y  W !,?18,$J(Y,2),?28,$O(^(Y,0))
 W ! Q
 ;
HELPMB ;executable help of fields 10 & 11 in file 9.6
 N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
 S DIC="^XPD(9.6,",DIC(0)="M",X="??",DIC("S")="I '$P(^(0),U,3),Y'="_D0
 D ^DIC Q
 ;
SCRA(Y) ;screen of ACTION field in ENTRIES multiple in KERNEL FILES multiple, Y=action
 ;Y=0 - send, 1 - delete, 2 - link, 3 - merge, 4 - attach, 5 - disable
 ;all entries can send to site or disable
 Q:Y=5!'Y 1
 ;.5=function file, can't delete, all others can
 I Y=1 Q (D1'=.5)
 ;then rest of code check if it is a Option or Protocal and can have MENU ITEMS
 Q:D1'=19&(D1'=101) 0
 ;all Options and Protocols can be attached
 Q:Y=4 1
 N FGR,X
 S X=$P(^XPD(9.6,D0,"KRN",D1,"NM",D2,0),U),FGR=$$FILE^XPDV(D1)
 Q:X="" 0
 S X=+$O(@FGR@("B",X,0))
 ;if it has ITEMs, node 10 then ok
 I $O(@FGR@(X,10,0)) Q 1
 ;if type is menu,potocol,protocol menu,limited,extended,window suite
 I "MOQLXZ"[$P($G(@FGR@(X,0)),U,4) Q 1
 Q 0
 ;
 ;only Fileman templates need to know what file they are associated with.
 ;this value is also triggered to field .02 in the DD.
TX(X,Y) ;X=template name, Y=file #
 Q X_"    FILE #"_Y
 ;
TF(F) ;F=file, return field of file# for templates
 Q $S(F>.403:"",F<.403:4,1:7)
 ;
GR(X) Q $G(^DIC(X,0,"GL"))
 ;
 ;screens checks that X is not already in the ENTRIES multiple
SCR(Y) ;screen logic for ENTRIES multiple in file 9.6
 N %,X,Z
 S Z=^(0),X=$P(Z,U)
 ;FM files are less than .44
 I XPDF<.44 D  Q:X="" 0
 .S %=$S(XPDF=.403:$P(Z,U,8),1:$P(Z,U,4)),X=X_"    FILE #"_%
 .S:XPDF'=.403&($P(Z,U,8)>2) %=0 S:'% X=""
 ;routine must exist and must be type 'R'
 I XPDF=9.8 Q:$T(^@X)=""!($P(Z,U,2)'="R") 0
 Q '$D(@(XPDIC_"""B"",X)"))
 ;
 ;screen checks that X is not in the exclude list, XPDN(0)
SCR1(Y) ;screen logic for exclude list
 N %,X
 ;if name X is in the exclude list, XPDN(0,X), then fail
 S Y(0)=^(0),X=$P(Y(0),U) Q:$D(XPDN(0,X)) 0
 ;check if X is refered in the namespace by check the subscript
 ;before X, if sub exist and $P(X,sub)="" then it is part of the
 ;namespace, fail and return 0
 S %=$O(XPDN(0,X),-1) I $L(%) Q:$P(X,%)="" 0
 Q $$SCR(.Y)
 ;
 ;screen on PACKAGE LINK field in file 9.6,
PCK(Y) ;check Package File name, Y=ien in package file
 N %,Y,Z
 S Z=^(0)
 ;DA is undef when you are adding a new Build without a version number
 Q:'$D(^XPD(9.6,+$G(DA),0)) 1
 S Y=$L($P(Z,U)),%=$P(^XPD(9.6,DA,0),U),%=$$PKG^XPDUTL(%)
 Q $P(Z,U)=$E(%,1,Y)!($P(Z,U,2)=%)
VOLE(X) ;input transform for VOLUME SET multiple in INSTALL file
 ;X=user input
 N D,DD,DIC,DICR,DIX,DIY,DO,DS,XPD,Y,%
 ;(0;11)=SIGNON/PRODUCTION
 S DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)"
 D ^DIC K:Y<0 X Q:'$D(X)
 S X=Y(0,0)
 Q
VOLH ;executable help for VOLUME SET multiple in INSTALL file
 N D,DD,DIC,DIE,DIX,DIY,DO,DS,DZ,X,Y,%
 S X="??",DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)"
 D ^DIC
 Q
ID97 ;identifier for Install file
 N XPDET,XPD,XPD0,XPD1,XPD2,XPD9
 S XPD0=$G(^(0)),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD9=$P(XPD0,U,9),XPD="" Q:XPD9=""
 D
 .;Loaded, get DATE LOADED
 .I 'XPD9 S XPD=$$FMTE^XLFDT($P(XPD0,U,3),2) Q
 .Q:XPD9>3
 .;Started, get INSTALL START TIME
 .I XPD9=2 S XPD=$$FMTE^XLFDT($P(XPD1,U),2) Q
 .;Completed, get INSTALL COMPLETE TIME
 .I XPD9=3 S XPD=$$FMTE^XLFDT($P(XPD1,U,3),2) Q
 .;Queued, get QUEUED TASK NUMBER
 .I XPD9=1 S XPD="#"_$P(XPD0,U,6) Q
 S XPDET(1)="   "_$$EXTERNAL^DILFD(9.7,.02,"",XPD9)_"  "_XPD,XPDET(1,"F")="?0"
 S:XPD2]"" XPDET(2)="=> "_$E(XPD2,1,70),XPDET(2,"F")="!?5"
 D EN^DDIOL(.XPDET)
 Q
 ;not being used right now,
DEL97(Y) ;delete access to file 9.7, 0-can't delete, 1-can
 N %
 S %=$P(^XPD(9.7,Y,0),U,9)
 Q $S(%=3:1,%=2:0,$D(^XPD(9.7,"ASP",Y,1,Y)):1,1:0)

XPDGCDEL
XPDGCDEL ;SFISC.SEA/JLI - Delete specified Objects (if not required) ; 3 Feb 95 09:14
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;;Jul 10, 1995
 ;
EN(XGCROOT) ; Entry is with the root under which IENs for the objects to be
 ; deleted will be found.
 N TMPROOT,DAXGC,TMPEVNT,DA,I,J,K,X,XGCOBJ,XGEVNT,XQUIT,DIE,DR
 S TMPROOT=$NA(^TMP("XPDGCDEL",$J))
 S TMPEVNT=$NA(^TMP("XPDGCEVN",$J))
 K @TMPROOT ; array to save those currently in use
 K @TMPEVNT
 S XGCOBJ=""
 D OBJECTS
 I $D(@TMPROOT) S XGCROOT=TMPROOT D OBJECTS
 D EVENTS
 K @TMPROOT
 K @TMPEVNT
 Q
 ;
OBJECTS ;
 F  S XGCOBJ=$O(@XGCROOT@(XGCOBJ)) Q:XGCOBJ=""  D
 . S DAXGC=XGCOBJ
 . S XQUIT=0
 . F I=0:0 S I=$O(^XTV(8995,I)) Q:I'>0  I $O(^(I,2,0))>0 D  Q:XQUIT
 . . F J=0:0 S J=$O(^XTV(8995,I,2,J)) Q:J'>0  I $P(^(J,0),U,2)=DAXGC D  Q:XQUIT
 . . . I $D(@XGCROOT@($P(^XTV(8995,I,0),U))) S @TMPROOT@(XGCOBJ)=""
 . . . S XQUIT=1 ; Mark as currently used
 . . Q:XQUIT
 . Q:XQUIT
 . D CHKEVNTS
 . D CHKPARNT
 . S DA=DAXGC
 . S DIK="^XTV(8995,"
 . D ^DIK
 . K DIK
 Q
 ;
CHKEVNTS ;
 F I=0:0 S I=$O(^XTV(8995,DAXGC,1,I)) Q:I'>0  S X=^(I,0) D
 . S X=+$P(X,U,2)
 . S X=$P(^XTV(8995.8,X,0),U)
 . S @TMPEVNT@(X)=""
 F I=0:0 S I=$O(^XTV(8995,DAXGC,2,I)) Q:I'>0  D
 . F J=0:0 S J=$O(^XTV(8995,DAXGC,2,I,1,J)) Q:J'>0  S X=^(J,0) D
 . . S X=+$P(X,U,2)
 . . S X=$P(^XTV(8995.8,X,0),U)
 . . S @TMPEVNT@(X)=""
 F I=0:0 S I=$O(^XTV(8995,DAXGC,3,I)) Q:I'>0  S X=^(I,0) D
 . S X=+$P(X,U,4)
 . S X=$P(^XTV(8995.8,X,0),U)
 . S @TMPEVNT@(X)=""
 Q
 ;
CHKPARNT ;
 F I=0:0 S I=$O(^XTV(8995,I)) Q:I'>0  I I'=DAXGC,$P(^(I,0),U,2)=DAXGC D
 . S DR=".02///@;",DIE="^XTV(8995,",DA=DAXGC
 . D ^DIE
 . K DIE,DR
 Q
 ;
EVENTS ;
 S XGEVNT=""
 F  S XGEVNT=$O(@TMPEVNT@(XGEVNT)) Q:XGEVNT=""  D
 . S DAXGC=$O(^XTV(8995.8,"B",XGEVNT)) Q:DAXGC'>0
 . S XQUIT=0
 . F I=0:0 Q:XQUIT  S I=$O(^XTV(8995,I)) Q:I'>0  D
 . . F J=0:0 S J=$O(^XTV(8995,I,1,J)) Q:J'>0  I $P(^(J,0),U,2)=DAXGC S XQUIT=1 Q
 . . F J=0:0 Q:XQUIT  S J=$O(^XTV(8995,I,2,J)) Q:J'>0  D
 . . . F K=0:0 S K=$O(^XTV(8995,I,2,J,1,K)) Q:K'>0  I $P(^(K,0),U,2)=DAXGC S XQUIT=1 Q
 . . F J=0:0 S J=$O(^XTV(8995,I,3,J)) Q:J'>0  I $P(^(J,0),U,4)=DAXGC S XQUIT=1 Q
 . S DA=DAXGC
 . S DIK="^XTV(8995.9,"
 . D ^DIK
 . K DIK
 Q

XPDH
XPDH ;SFISC/XAK,RSD - help for answering install questions ;08/17/98  13:33
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**58,95**;Jul 10, 1995
REP ;changing your file name
 W !!?5,"If YES, then the incoming file name and Data Dictionary will"
 W !?5,"overwrite the existing file ",FLAG,"."
 W !!?5,"If NO, then the Install Process will abort.",!
 Q
DTA ;help for adding data
 W !!?5,"YES means that the data coming in with this INSTALL process"
 W !?5,"will ",FLAG," the data on file if a match is found."
 W !!?5,"Entries will be added if they do not match exactly"
 W !?5,"on Name and Identifiers."
 W !!?5,"NO means that everything will be left as is."
 Q
OPT ;disable options
 W !!?5,"YES means you want to mark Options and Protocols out of"
 W !?5,"order during the Install Process."
 W !!?5,"NO means no action will be taken."
 Q
RTN ;moving routines
 W !!?5,"YES means you want to update the routines on other CPUs"
 W !?5,"during the Install Process.  This will work only if Taskman"
 W !?5,"is running during the Install Process."
 W !!?5,"NO means that only routines on this CPU will be updated."
 Q
MSG ;creating a Packman message
 W !!?5,"YES means that you are going to send this Package over"
 W !?5,"the Network as a message."
 W !?5,"NO means that a Transport Global will be created."
 Q
MG ;adding Coordinator to a Mail Group
 W !!?5,"Enter the person responsible for maintaining the membership"
 W !?5,"of the incoming Mail Group.  The person must exist in the"
 W !?5,"New Person file, #200.  This person will be the coordinator"
 W !?5,"only if this Mail Group is new on your system."
 Q
MENU ;rebuild menu trees if an Option was added
 W !!?5,"YES means that KIDS will run the Menu Trees rebuild routines"
 W !?5,"as part of the installation at the end."
 W !?5,"NO means that the Menu Trees will not be rebuilt."
 W !?5,"It is highly recommended that you rebuild Menu Trees"
 W !?5,"immediately whenever KIDS adds an Option."
 Q

XPDI
XPDI ;SFISC/RSD - Install Process ;12/10/97  10:20
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**10,21,39,41,44,58,68**;Jul 10, 1995
EN ;install
 N DIR,DIRUT,POP,XPD,XPDA,XPDD,XPDIJ,XPDDIQ,XPDIT,XPDIABT,XPDNM,XPDNOQUE,XPDPKG,XPDREQAB,XPDST,XPDSET,XPDSET1,XPDT,XPDQUIT,XPDQUES,Y,ZTSK,%
 S %="I '$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%)
 Q:'XPDST!$D(XPDQUIT)
 S XPDIT=0,(XPDSET,XPDSET1)=$P(^XPD(9.7,XPDST,0),U) K ^TMP($J)
 F  S XPDIT=$O(XPDT(XPDIT)) Q:'XPDIT  D  Q:'$D(XPDT)!$D(XPDQUIT)
 .S XPDA=+XPDT(XPDIT),XPDNM=$P(XPDT(XPDIT),U,2),XPDPKG=+$P($G(^XPD(9.7,+XPDT(XPDIT),0)),U,2),%=$P(^(0),U,5)
 .W !?3,XPDNM
 .;check that Install file was created correctly
 .I '$D(^XPD(9.7,XPDA,"INI"))!'$D(^("INIT")) W !,"**INSTALL FILE IS CORRUPTED**",!,*7 S XPDQUIT=1 Q
 .;run enviroment check routine
 .;XPDREQAB req. build missing, =2 global killed
 .I $$ENV^XPDIL1(1) S:$G(XPDREQAB)=2 XPDQUIT=1 Q
 .;save variables that are setup in environ. chck. routine
 .I $D(XPDNOQUE)!$D(XPDDIQ) D
 ..S:$D(XPDNOQUE) ^XTMP("XPDI",XPDA,"ENVVAR","XPDNOQUE")=XPDNOQUE
 ..I $D(XPDDIQ) M ^XTMP("XPDI",XPDA,"ENVVAR","XPDDIQ")=XPDDIQ
 .D QUES^XPDI1(XPDA) Q:'$D(XPDT(+XPDIT))!$D(XPDQUIT)
 .;XPDIJ=XPDA if XPDIJ routine is part of Build
 .S:$D(^XTMP("XPDI",XPDA,"RTN","XPDIJ")) XPDIJ=XPDA
 .D XQSET^XPDI1(XPDA)
 ;NONE = no Build to install
 G NONE:'$O(XPDT(""))!$D(XPDQUIT)!($G(XPDREQAB))
 ;check that we have all Builds to install
 S XPDA=XPDST,XPDNM=XPDSET,Y=0
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S %=+$O(^(Y,0)) I '$D(XPDT("DA",%)) G NONE
 W !
 ;disable options question
 D DIR^XPDIQ("XPZ") I $D(DIRUT) D ABRTALL(2) Q
 ;XPDSET=set name,(also build name), of options that will be disabled
 ;XPDSET1=setname or null if they don't want to disable
 D  I XPDSET1="^" D ABRTALL(2) Q
 .;if they say no, set XPDET1=""
 .S:'$G(XPDQUES("XPZ1")) XPDSET1="",Y=0
 .S ^XTMP("XQOO",XPDSET,0)=XPDSET_" is being installed by KIDS^"_DT_U_DUZ
 .I XPDSET1]"" D  Q:XPDSET1="^"!(XPDSET1="")
 ..;merge the options/protocols that were put in ^TMP($J,"XQOO",build name)
 ..M ^XTMP("XQOO",XPDSET)=^TMP($J,"XQOO",XPDSET)
 ..D INIT^XQOO(.XPDSET1) Q:"^"[XPDSET1
 ..N DIR S DIR(0)="N^0:60:0",DIR("B")=0
 ..S DIR("A")="Delay Install (Minutes)",DIR("?")="Enter the number of minutes to delay the installing of Routines after the Disable of Options"
 ..W ! D ^DIR I $D(DIRUT) S XPDSET1="^"
 .;Y is set in the call to DIR in previous .DO
 .;save setname into first Build and the Delay in minutes, Y
 .K XPD S XPD(9.7,XPDST_",",7)=(XPDSET1]"")_XPDSET,XPD(9.7,XPDST_",",8)=Y
 .D FILE^DIE("","XPD")
 ;check if they want to update other CPUs
 I $G(XPDQUES("XPZ2")) D  I $D(DIRUT) D ABRTALL(2) Q
 .N DA,DIE,DIR,DR,I,XPD,X,Y,Z
 .;if they haven't already added Volume Sets, populate the mulitple
 .I '$O(^XPD(9.7,XPDA,"VOL",0)) D  I $D(XPD) D UPDATE^DIE("","XPD")
 ..X ^%ZOSF("UCI") S Y=$P(Y,",",2),(I,Z)=0
 ..F  S I=$O(^%ZIS(14.5,I)) Q:'I  S X=$G(^(I,0)) S:$P(X,U)]""&$P(X,U,11)&($P(X,U)'=Y) Z=Z+1,XPD(9.703,"+"_Z_","_XPDA_",",.01)=$P(X,U)
 .W !!,"I will Update the following VOLUME SETS:",!
 .S I=0 F  S I=$O(^XPD(9.7,XPDA,"VOL",I)) Q:'I  W ?3,$P(^(I,0),U),!
 .W ! S DIR(0)="Y",DIR("A")="Want to edit this list",DIR("B")="NO"
 .D ^DIR Q:$D(DIRUT)  D:Y
 ..S DA=XPDA,DIE="^XPD(9.7,",DR=30,DR(2,9.703)=".01"
 ..D ^DIE
 .I '$O(^XPD(9.7,XPDA,"VOL",0)) W !!,"No VOLUME SETS selected!!" Q
 .Q:$$TM^%ZTLOAD  ;quit if Taskman is running
 .W !!,"TASKMAN is not running. If you install now, you must run the routine XPDCPU",!,"in the production UCI for each of the VOLUME SETS you have listed once"
 .W !,"the installation starts!!",!,"If you Queue the install, the VOLUME SETS will be updated automatically.",*7,*7,!!
DEV S POP=0 S:'$D(^DD(3.5,0)) POP=1
 ;check if home device is defined
 I 'POP S IOP="",%ZIS=0 D ^%ZIS
 ;Kernel Virgin Install
 I POP S XPDA=XPDST D:$G(XPDIJ) XPDIJ^XPDI1 G EN^XPDIJ
 ;set XPDA=starting Build, ask for device for messages
 ;XPDNOQUE is defined means don't let them queue output
 W !!,"Enter the Device you want to print the Install messages."
 W:'$D(XPDNOQUE) !,"You can queue the install by enter a 'Q' at the device prompt."
 W !,"Enter a '^' to abort the install.",!
 S XPDA=XPDST,%ZIS=$P("Q",U,'$D(XPDNOQUE))
 D ^%ZIS G:POP ASKABRT
 ;reset expiration date to T+7 on transport global
 S XPDD=$$FMADD^XLFDT(DT,7),^XTMP("XPDI",0)=XPDD_U_DT
 I $D(IO("Q")) D  G ASKABRT:$D(ZTSK)[0 D XPDIJ^XPDI1:$G(XPDIJ),QUIT^XPDI1(XPDST) Q
 .N %DT
 .S %DT="AEFRSX",%DT("A")="Requested Start Time: ",(%DT("B"),%DT(0))="NOW"
 .;queue time must be in the future, but not more than 7 days
 .F  D ^%DT Q:$D(DTOUT)  D:$$FMDIFF^XLFDT(XPDD,Y)<0  Q:Y>0
 ..W !!,"Start Date shouldn't be more than a week in the future!",*7
 ..S Y=-1
 .Q:$D(DTOUT)
 .S ZTDTH=Y,ZTRTN="EN^XPDIJ",ZTDESC="KIDS install",ZTSAVE("XPDA")=""
 .D ^%ZTLOAD,HOME^%ZIS K IO("Q")
 .Q:$D(ZTSK)[0
 .W !,"Install Queued!",!!
 .;save task into first Build
 .K XPD S XPD(9.7,XPDST_",",5)=ZTSK,XPDIT=0
 .F  S XPDIT=$O(XPDT(XPDIT)) Q:'XPDIT  S XPD(9.7,+XPDT(XPDIT)_",",.02)=1 D FILE^DIE("","XPD") K XPD
 ;run install
 U IO D XPDIJ^XPDI1:$G(XPDIJ),QUIT^XPDI1(XPDST) G EN^XPDIJ
 Q
 ;
 ;XPDA=ien to del, XPDK=1 kill global, XPDALL=1 deleting all
 ;XPDST=starting package.
ABORT(XPDA,XPDK,XPDALL) ;abort install of Build XPDA
 N %,DA,DIK,XPDJ,XPDNM,Y
 Q:'$D(^XPD(9.7,XPDA,0))  S XPDNM=$P(^(0),U)
 W !,XPDNM," Build will not be installed",$S(XPDK=1:", Transport Global deleted!",1:""),!
 S DIK="^XPD(9.7,",XPDJ=XPDT("NM",XPDNM),DA=XPDA
 ;kill XPDT array, but don't kill global if XPDK=2
 K XPDT("NM",XPDNM),XPDT("DA",XPDA),XPDT(XPDJ),XPDT("GP") Q:XPDK=2
 K ^XTMP("XPDI",XPDA)
 ;if we are not deleting all packages and we are deleting the starting package
 ;set the next package to the starting package. It must always be 1.
 I '$G(XPDALL),XPDA=XPDST S Y=$O(XPDT(0)) D:Y
 .;unlock starting install
 .L -^XPD(9.7,XPDST)
 .S XPDST=+XPDT(Y),XPDT(1)=XPDT(Y),XPDT("DA",XPDST)=1,XPDT("NM",$P(XPDT(Y),U,2))=1,XPDIT=0
 .K XPDT(Y) N XPD
 .S %="XPD(9.7,"""_XPDST_","")",@%@(3)=XPDST,@%@(4)=1
 .;loop thru the rest of the packages and reset the starting package field
 .F  S Y=$O(XPDT(Y)) Q:'Y  D
 ..S XPD(9.7,+XPDT(Y)_",",3)=XPDST
 .D FILE^DIE("","XPD")
 D ^DIK
 Q
ASKABRT ;ask if want to unload distribution
 N DIR,DIRUT,X,Y
 S XPDQUIT=1,DIR(0)="Y",DIR("A")="Install ABORTED, Want to remove the Transport Globals",DIR("B")="YES"
 W ! D ^DIR I Y D ABRTALL(1) Q
 L -^XPD(9.7,XPDST)
 Q
ABRTALL(XPDK) ;abort all Builds
 N XPDA
 S XPDT=0
 F  S XPDT=$O(XPDT(XPDT)) Q:'XPDT  S XPDA=+XPDT(XPDT) D ABORT(XPDA,XPDK,1)
 ;unlock starting install
 L -^XPD(9.7,XPDST)
 Q
NONE W !!,"**NOTHING INSTALLED**",!
 Q

XPDI1
XPDI1 ;SFISC/RSD - Cont of Install Process ;08/17/98  13:34
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**58,61,95**;Jul 10, 1995
 ;lookup into file 9.7, XPDS=DIC("S") for lookup
 ;return 0-fail or ien, XPDT=array of linked builds
LOOK(XPDS) ;lookup Install
 N DIC,Y,XPD,XPDIT,%
 S DIC(0)="QEAMZ",DIC="^XPD(9.7,"
 S:$L($G(XPDS)) DIC("S")=XPDS
 D ^DIC Q:Y<0 0
 L +^XPD(9.7,+Y,0):0 E  W !,"Being accessed by another user" Q 0
 S XPD=+Y,XPDIT=0
 W !!,"This Distribution was loaded on ",$$FMTE^XLFDT($P(Y(0),U,3))," with header of ",!,$G(^XPD(9.7,XPD,2)),!,"It consisted of the following Install(s):",!
 ;build XPDT array
 F  S XPDIT=$O(^XPD(9.7,"ASP",XPD,XPDIT)) Q:'XPDIT  S Y=+$O(^(XPDIT,0)) D
 .S %=$P($G(^XPD(9.7,Y,0)),U)
 .I %="" W "**ERROR in Install, You need to remove the Distribution and reload it**",!  S XPDQUIT=1 Q
 .S XPDT(XPDIT)=Y_U_%,(XPDT("DA",Y),XPDT("NM",%))=XPDIT W %,!
 I '$O(XPDT(0)) S XPDQUIT=1 D QUIT(XPD)
 Q XPD
 ;
QUIT(Y) ;unlock ien Y
 L -^XPD(9.7,+Y) Q
 ;
QUES(XPDA) ;install questions; XPDA=ien in file 9.7
 N XPDANS,XPDFIL,XPDFILN,XPDFILO,XPDFLG,XPDNM,XPDQUES,X,Y
 S XPDNM=$P(^XPD(9.7,XPDA,0),U) W !!,"Install Questions for ",XPDNM,!
 ;pre-init questions
 D DIR^XPDIQ("PRE") I $D(XPDQUIT) D ASKABRT^XPDI Q
 ;file install questions
 S (XPDFIL,XPDFLG)=0
 F  S XPDFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPDFIL)) Q:'XPDFIL  S X=^(XPDFIL),X(0)=^(XPDFIL,0),X(1)=^(XPDFIL),XPDFILO=^(0,1) D  Q:$D(XPDQUIT)
 .;check for DD screening logic
 .I $G(^(10))]"" N XPDSCR S XPDSCR=^(10) ;^(10) is ref to ^XTMP("XPDI",XPDA,"FIA",XPDFIL,0,10) from prev line
 .;XPDFILN=file name^global ref^partial DD
 .;XPDANS=new file^DD screen failed^Data exists^update file name^user
 .;doesn't want to update data  1=yes,0=no
 .S XPDFILN=X_X(0)_U_X(1),XPDANS='($D(^DIC(XPDFIL,0))#2)_"^^"_''$O(@(X(0)_"0)"))
 .I 'XPDFLG W !,"Incoming Files:" S XPDFLG=1
 .W ! D DIR^XPDIQ("XPF",XPDFIL_"#") Q:$D(XPDQUIT)
 .S:$G(XPDQUES("XPF"_XPDFIL_"#2"))=0 $P(XPDANS,U,5)=1
 .S ^XTMP("XPDI",XPDA,"FIA",XPDFIL,0,2)=XPDANS
 .;kill the answers so we can re-ask for next file
 .F I=1:1:2 K XPDQUES("XPF"_XPDFIL_"#"_I)
 ;XPDQUIT is by file questions in previous do loop, set in XPDIQ
 I $D(XPDQUIT) D ASKABRT^XPDI Q
 ;ask for coordinators to incoming mail groups
 S (XPDFIL,XPDFLG)=0
 F  S XPDFIL=$O(^XTMP("XPDI",XPDA,"KRN",3.8,XPDFIL)) Q:'XPDFIL  S X=^(XPDFIL,0) D  Q:$D(XPDQUIT)
 .;XPDANS=Mail Group name
 .S XPDANS=$P(X,U)
 .I 'XPDFLG W !!,"Incoming Mail Groups:" S XPDFLG=1
 .W ! D DIR^XPDIQ("XPM",XPDFIL_"#") Q:$D(XPDQUIT)
 .;kill the answers so we can re-ask for next MG
 .K XPDQUES("XPM"_XPDFIL_"#1")
 .Q
 I $D(XPDQUIT) D ASKABRT^XPDI Q
 ;ask to rebuild menus if Option is added
 S (XPDFIL,XPDFLG)=0
 S XPDFIL=$O(^XTMP("XPDI",XPDA,"KRN",19,XPDFIL))  D:XPDFIL
 .S X=^XTMP("XPDI",XPDA,"KRN",19,XPDFIL,0)
 .;XPDANS=Menu Rebuild Answer
 .S XPDANS=$P(X,U)
 .W ! D DIR^XPDIQ("XPO") Q:$D(XPDQUIT)
 I $D(XPDQUIT) D ASKABRT^XPDI Q
 ;post-init questions
 W ! D DIR^XPDIQ("POS") I $D(DIRUT)!$D(XPDQUIT) D ASKABRT^XPDI Q
 Q
 ;
XQSET(XPDA) ;get options & protocols to disable
 ;put in ^TMP($J,"XQOO",starting build name)
 N A,I,X,Y
 S I=0 F  S I=$O(^XTMP("XPDI",XPDA,"KRN",19,I)) Q:'I  S X=^(I,0),A=^(-1) D
 .S Y=$O(^DIC(19,"B",$P(X,U),0))
 .;check that option exist and 0=send,1=delete,3=merge or 5=disable
 .I Y,$D(^DIC(19,Y,0)),$S('A:1,1:A#2) S ^TMP($J,"XQOO",XPDSET,19,Y)=$P(^(0),U,1,2)
 S I=0 F  S I=$O(^XTMP("XPDI",XPDA,"KRN",101,I)) Q:'I  S X=^(I,0),A=^(-1) D
 .S Y=$O(^ORD(101,"B",$P(X,U),0))
 .I Y,$D(^ORD(101,Y,0)),$S(A=3:1,A=5:1,1:'A) S ^TMP($J,"XQOO",XPDSET,101,Y)=$P(^(0),U,1,2)
 Q
 ;XPDIJ need to install XPDIJ now & set routine flag to skip
XPDIJ N DIE,XPDA,XCM,XCN,XCS,X
 S XPDA=XPDIJ,DIE="^XTMP(""XPDI"",XPDIJ,""RTN"",""XPDIJ"",",XCN=0,X="XPDIJ"
 X ^%ZOSF("SAVE")
 S XCN=$$RTNUP^XPDUTL("XPDIJ",2)
 Q

XPDIA
XPDIA ;SFISC/RSD - Install Pre/Post Actions for Kernel Files ;12/02/97  13:39
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**10,15,21,28,44,58,68**;Jul 10, 1995
 Q
OPTF1 ;options file pre
 K ^TMP($J,"XPD")
 Q
OPTE1 ;options entry pre
 N %,I
 ;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
 ;attach & disable never get here
 S ^TMP($J,"XPD",DA)=XPDFL
 ;if Menu linking or merge save menu mult. and process in FPOS code
 I XPDFL>1 M ^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",19,OLDA,10) K ^XTMP("XPDI",XPDA,"KRN",19,OLDA,10)
 ;if Menu link, XPDQUIT prevents data merge
 I XPDFL=2 S XPDQUIT=1 Q
 ;if this is new to the site then disable and quit
 I $G(XPDNEW) D:XPDSET  Q
 .;quit if option already has out of order msg.
 .Q:$P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)]""
 .S $P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)=$P(XPDSET,U,3)
 .D ADD^XQOO1($P(XPDSET,U,2),19,DA)
 S I=^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),%=^DIC(19,DA,0)
 ;$P(%,U,3)=out of order message, keep sending ooo msg
 S:$P(I,U,3)="" $P(I,U,3)=$P(%,U,3)
 ;if there is no new Security Key, save the old Key
 S:$P(I,U,6)="" $P(I,U,6)=$P(%,U,6)
 ;if there is no reverse key, save the old key and flag
 I $P($G(^XTMP("XPDI",XPDA,"KRN",19,OLDA,3)),U)="",$L($P($G(^DIC(19,DA,3)),U)) S $P(I,U,16)=$P(%,U,16),$P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,3),U)=$P(^(3),U)
 S ^XTMP("XPDI",XPDA,"KRN",19,OLDA,0)=I
 ;if there is a new Description, kill the old Description
 K:$O(^XTMP("XPDI",XPDA,"KRN",19,OLDA,1,0)) ^DIC(19,DA,1)
 ;kill old RCPs (RPC)
 K ^DIC(19,DA,"RPC")
 ;if Menu Text, (U;1) is different, kill C x-ref
 S I=$G(^DIC(19,DA,"U")) I I]"",I'=$G(^XTMP("XPDI",XPDA,"KRN",19,OLDA,"U")) K ^DIC(19,"C",I)
 S I=0
 ;XPDFL=3-merge menu items, Quit
 ;the new menu items have already been saved into ^TMP, will restore in
 ;the file post action as a relink
 Q:XPDFL=3
 ;we are replacing menu items, kill the old.
 ;loop thru and kill "AD" x-ref., it will be reset with new options
 F  S I=$O(^DIC(19,DA,10,I)) Q:'I  S %=+$G(^(I,0)) K:% ^DIC(19,"AD",%,DA,I)
 ;kill Menus (10)
 K ^DIC(19,DA,10)
 Q
OPTF2 ;options file post
 N ACT,DA,DIK,I,X,Y,Y0
 ;loop thru all the new incomming options
 S DA=0,DIK=DIC F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  S ACT=^(DA) D
 .;if use as link then goto OPTFL, just update menus
 .G:ACT=2 OPTFL
 .;repoint Bulletin (220;1) and Mail Group (220;3)
 .S Y0=$G(^DIC(19,DA,220)) I Y0]"" S $P(Y0,U)=$$LK("^XMB(3.6)",$P(Y0,U)),$P(Y0,U,3)=$$LK("^XMB(3.8)",$P(Y0,U,3)),^DIC(19,DA,220)=Y0
 .;repoint RPC (RPC;1)
 .S (I,X)=0 F  S I=$O(^DIC(19,DA,"RPC",I)) Q:'I  S Y0=$P($G(^(I,0)),U) D
 ..S Y=$$LK("^XWB(8994)",Y0)
 ..I 'Y K ^DIC(19,DA,"RPC",I) D BMES^XPDUTL(" RPC "_Y0_" in Option "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
 ..S $P(^DIC(19,DA,"RPC",I,0),U)=Y,X=I_U_(X+1)
 .S:X $P(^DIC(19,DA,"RPC",0),U,3,4)=X
 .;repoint Package (0;12) and Help Frame (0;7)
 .S Y0=^DIC(19,DA,0),$P(Y0,U,12)=$$LK("^DIC(9.4)",$P(Y0,U,12)),$P(Y0,U,7)=$$LK("^DIC(9.2)",$P(Y0,U,7)),^DIC(19,DA,0)=Y0
OPTFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
 .;merged, they could also be linked menu, but treat like merge
 .S I=0 F  S I=$O(^TMP($J,"XPD",DA,10,I)) Q:'I  S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" MENU(DA,X,Y0)
 .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
 .;also need to recount all menus and reset zeroth node, use X
 .S (I,X)=0 F  S I=$O(^DIC(19,DA,10,I)) Q:'I  S Y0=$G(^(I,U)) D
 ..I $L(Y0) D  Q:'Y
 ...S Y=$$LK("^DIC(19)",Y0)
 ...K ^DIC(19,DA,10,I,U)
 ...I 'Y K ^DIC(19,DA,10,I) D BMES^XPDUTL(" Option "_Y0_" in Menu "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
 ...S $P(^DIC(19,DA,10,I,0),U)=Y
 ..S X=I_U_(X+1)
 .S:X $P(^DIC(19,DA,10,0),U,3,4)=X
 .;re-index this option
 .D IX1^DIK
 K ^TMP($J,"XPD")
 Q
OPTDEL ;option delete
 D DEL("^DIC(19,",DUZ)
 D OPT^XPDIA2
 Q
PROF1 ;protocols file pre
 K ^TMP($J,"XPD")
 Q
PROE1 ;protocols entry pre
 N %,I
 S ^TMP($J,"XPD",DA)=XPDFL
 ;if Menu linking or merge save menu mult. and process in FPOS code
 I XPDFL>1 M ^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10) K ^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
 ;if Menu link, XPDQUIT prevents data merge
 I XPDFL=2 S XPDQUIT=1 Q
 ;if this is new to the site then disable and quit
 I $G(XPDNEW) D:XPDSET  Q
 .;quit if option already has out of order msg.
 .Q:$P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)]""
 .S $P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)=$P(XPDSET,U,3)
 .D ADD^XQOO1($P(XPDSET,U,2),101,DA)
 S I=^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),%=^ORD(101,DA,0)
 ;$P(%,U,3)=disable message,
 S:$P(I,U,3)]"" $P(I,U,3)=$P(%,U,3)
 ;if there is no new Security Key, save the old Key
 S:$P(I,U,6)="" $P(I,U,6)=$P(%,U,6)
 S ^XTMP("XPDI",XPDA,"KRN",101,OLDA,0)=I
 ;if there is a new Description, kill the old Description
 K:$O(^XTMP("XPDI",XPDA,"KRN",101,OLDA,1,0)) ^ORD(101,DA,1)
 ;kill old ACCESS multiple
 K ^ORD(101,DA,3) S I=0
 ;XPDFL=3-merge menu items, Quit
 ;the new menu items have already been saved into ^TMP, will restore in
 ;the file post action as a relink
 Q:XPDFL=3
 ;we are replacing menu items, kill the old.
 ;loop thru and kill "AD" x-ref., it will be reset with new options
 F  S I=$O(^ORD(101,DA,10,I)) Q:'I  S %=+$G(^(I,0)) K:% ^ORD(101,"AD",%,DA,I)
 K ^ORD(101,DA,10)
 Q
PROF2 ;protocols file post
 N ACT,DA,DIK,I,X,Y,Y0
 ;loop thru all the new incomming options
 S DA=0,DIK=DIC F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  S ACT=^(DA) D
 .;if use as link then goto PROFL, just update menus
 .G:ACT=2 PROFL
 .;repoint Package (0;12)
 .S Y0=^ORD(101,DA,0) S:$L($P(Y0,U,12)) $P(Y0,U,12)=$$LK("^DIC(9.4)",$P(Y0,U,12)),^ORD(101,DA,0)=Y0
 .;repoint File Link (5;1), its a variable pointer
 .S Y0=$P($G(^ORD(101,DA,5)),U),Y=$P(Y0,";",2),Y0=$P(Y0,";")
 .I Y0,$L(Y) S Y0=$O(@("^"_Y_"""B"","""_Y0_""",0)")),$P(^ORD(101,DA,5),U)=$S(Y0:Y0_";"_Y,1:"")
 .;repoint HL7 fields, node 770
 .S Y0=$G(^ORD(101,DA,770)) I $L(Y0) D  S ^ORD(101,DA,770)=Y0
 ..S $P(Y0,U)=$$LK("^HL(771)",$P(Y0,U)),$P(Y0,U,2)=$$LK("^HL(771)",$P(Y0,U,2))
 ..S $P(Y0,U,3)=$$LK("^HL(771.2)",$P(Y0,U,3)),$P(Y0,U,11)=$$LK("^HL(771.2)",$P(Y0,U,11))
 ..S $P(Y0,U,4)=$$LK("^HL(779.001)",$P(Y0,U,4)),$P(Y0,U,7)=$$LK("^HLCS(870)",$P(Y0,U,7))
 ..S $P(Y0,U,8)=$$LK("^HL(779.003)",$P(Y0,U,8)),$P(Y0,U,9)=$$LK("^HL(779.003)",$P(Y0,U,9))
 ..S $P(Y0,U,10)=$$LK("^HL(771.5)",$P(Y0,U,10))
 .;loop thru Access and resolve (3;1), kill if it doesn't resolve
 .S (I,X)=0 F  S I=$O(^ORD(101,DA,3,I)) Q:'I  S Y0=$P($G(^(I,0)),U) D
 ..;Y0=.01 of Access(Security Key)
 ..S Y=$$LK("^DIC(19.1)",Y0)
 ..I 'Y K ^ORD(101,DA,3,I) D BMES^XPDUTL(" Key "_Y0_" in Protocol "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
 ..S $P(^ORD(101,DA,3,I,0),U)=Y,X=I_U_(X+1)
 .S:X $P(^ORD(101,DA,3,0),U,3,4)=X
PROFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
 .;merged, they are also linked menu, but treat like merge
 .S I=0 F  S I=$O(^TMP($J,"XPD",DA,10,I)) Q:'I  S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" MENU(DA,X,Y0)
 .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
 .;also need to recount all menus and reset zeroth node, use X
 .S (I,X)=0 F  S I=$O(^ORD(101,DA,10,I)) Q:'I  S Y0=$G(^(I,U)) D
 ..I $L(Y0) D  Q:'Y
 ...S Y=$$LK("^ORD(101)",Y0)
 ...K ^ORD(101,DA,10,I,U)
 ...I 'Y K ^ORD(101,DA,10,I) D BMES^XPDUTL(" Protocol "_Y0_" in Protocol Menu "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
 ...S $P(^ORD(101,DA,10,I,0),U)=Y
 ..S X=I_U_(X+1)
 .S:X $P(^ORD(101,DA,10,0),U,3,4)=X
 .;re-index this option
 .D IX1^DIK
 K ^TMP($J,"XPD")
 Q
PRODEL ;option delete
 D DEL("^ORD(101,",DUZ)
 D PRO^XPDIA2
 Q
LK(GR,X) ;lookup, GR=global root, X=lookup value
 Q:$G(X)="" ""
 N I S I=$O(@GR@("B",X,0))
 I I,$D(@GR@(I,0))#2 Q I
 Q ""
 ;
ADD(XPDSDD,XPDSDA,X) ;add to multiple, XPDSDD=sub DD#, XPDSDA=DA, X=value
 Q:$G(X)=""
 N XPD
 S XPD(XPDSDD,"?+1,"_XPDSDA_",",.01)=X
 D UPDATE^DIE("E","XPD")
 Q
 ;this is used to add menu items to an option or protocol
MENU(DA,X,X0) ;DA=ien of option/protocol, X=Menu item, X0=0 node of menu item
 N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
 S DIC=$S(XPDFIL=19:"^DIC(19,",1:"^ORD(101,")_DA_",10,",DIC(0)="L",DLAYGO=XPDFIL,(D0,DA(1))=DA
 S:'$D(@(DIC_"0)")) @(DIC_"0)")=U_$P(^DD(XPDFIL,10,0),U,2)
 S:$L($G(X0)) DIC("DR")="2///"_$P(X0,U,2)_";3///"_$P(X0,U,3)_$S($L($P(X0,U,4)):";4///"_$P(X0,U,4)_";5///"_$P(X0,U,5)_";6///"_$P(X0,U,6),1:"")
 D ^DIC
 Q
DEL(DIK,DUZ) ;delete
 N DA,XPDI,XPDF
 S XPDI=0,DUZ(0)="@",XPDF=+$P(DIK,"(",2)
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI  D
 .K ^TMP("DIFIXPT",$J) S DA=XPDI
 .D ^DIK ;FIXPT^DIA3("D",XPDF,XPDI)
 .I $D(^TMP("DIFIXPT",$J))  D WP^XPDUTL("^TMP(""DIFIXPT"",$J)")
 Q

XPDIA1
XPDIA1 ;SFISC/RSD - Install Pre/Post Actions for Kernel files cont. ;05/21/98  09:51
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,44,51,58,68,85**;Jul 10, 1995
 Q
HLPF1 ;help frames file pre
 K ^TMP($J,"XPD")
 Q
HLPE1 ;entry pre
 S ^TMP($J,"XPD",DA)="" K ^DIC(9.2,DA,1),^(2),^(3),^(10)
 Q
HLPF2 ;file post
 N DA,DIK,I,X,Y,Y0
 ;need to send error message, need to setup message
 S DA=0,DIK=DIC F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  D
 .;repoint Related Frame (2;0)
 .S I=0 F  S I=$O(^DIC(9.2,DA,2,I)) Q:'I  S Y0=$G(^(I,0)),Y=$$LK^XPDIA("^DIC(9.2)",$P(Y0,U,2)),$P(^DIC(9.2,DA,2,I,0),U,2)=Y
 .;repoint OBJECT (10;0)
 .S (I,X)=0 F  S I=$O(^DIC(9.2,DA,10,I)) Q:'I  S Y0=$G(^(I,0)) D
 ..S Y=$$LK^XPDIA("^MAG",$P(Y0,U)) S:Y $P(^DIC(9.2,DA,10,I,0),U)=Y,X=X+1_U_I
 ..K:'Y ^DIC(9.2,DA,10,I)
 .I X S $P(^DIC(9.2,DA,10,0),U,3,4)=$P(X,U,2)_U_+X
 .D IX1^DIK
 K ^TMP($J,"XPD")
 Q
HLPDEL ;help frame delete
 N DA,DIK,XPDI,XPDJ
 S XPDI=0
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)),XPDJ=0 Q:'XPDI  D
 .S DIK="^DIC(9.2,XPDJ,2,"
 .;check other frames that point to this one
 .F  S XPDJ=$O(^DIC(9.2,"AE",XPDI,XPDJ)) Q:'XPDJ  S Z=$O(^(XPDJ,0)) D:Z
 ..K DA S DA=Z,DA(1)=XPDJ D ^DIK
 .;delete this frame
 .K DA S DA=XPDI,DIK="^DIC(9.2," D ^DIK
 Q
BULE1 ;bulletin entry pre
 N X,I S I=0
 ;save current Mail Groups (2)
 I $G(^XMB(3.6,DA,2,0))]"" S X(0)=^(0) F  S I=$O(^XMB(3.6,DA,2,I)) Q:'I  S X(I)=$G(^(I,0))
 K ^XMB(3.6,DA)
 ;after killing data, put back Mail Groups before data merge
 I $D(X) S ^XMB(3.6,DA,2,0)=X(0),I=0 F  S I=$O(X(I)) Q:'I  S ^XMB(3.6,DA,2,I,0)=X(I)
 Q
BULDEL ;del bulletins
 N DA,DIK,XPDI
 S XPDI=0,DIK="^XMB(3.6,"
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI  S DA=XPDI D ^DIK
 Q
MAILGF1 ;mail groups file pre
 K ^TMP($J,"XPD")
 Q
MAILGE1 ;mail group entry pre
 N I,J
 S ^TMP($J,"XPD",DA)=""
 ;save MEMBER GROUPS (5;0)
 I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5,0)) M ^TMP($J,"XPD",DA,5)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5)
 ;save MEMBER - REMOTE (6;0)
 I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6,0)) M ^TMP($J,"XPD",DA,6)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6)
 ;if there is a new Description, kill the old Description
 K:$O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,2,0)) ^XMB(3.8,DA,2)
 S I=^XMB(3.8,DA,0),J=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)
 ;save REFERENCE COUNT (0;4) & LAST REFERENCED (0;5)
 S:$P(I,U,4) $P(J,U,4)=$P(I,U,4) S:$P(I,U,5) $P(J,U,5)=$P(I,U,5)
 ;check COORDINATOR (0;7), if exist then save, else bring in one that was asked during install question
 D
 .I $P(I,U,7) S $P(J,U,7)=$P(I,U,7) Q
 .S %=$O(^XPD(9.7,XPDA,"QUES","B","XPM"_OLDA_"#1",0)) Q:'%
 .S:$G(^XPD(9.7,XPDA,"QUES",%,1)) $P(J,U,7)=^(1)
 S ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)=J,I=$G(^XMB(3.8,DA,3))
 ;save ORGANIZER (3;1)
 I $P(I,U) S $P(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,3),U)=$P(I,U)
 Q
MAILGF2 ;mail group file post
 N DA,DIK,XPDMDA,XPDI,Y
 S XPDMDA=0,DIK="^XMB(3.8,"
 F  S XPDMDA=$O(^TMP($J,"XPD",XPDMDA)) Q:'XPDMDA  D
 .;merge & repoint MEMBER GROUP (5;0)
 .S XPDI=0
 .F  S XPDI=$O(^TMP($J,"XPD",XPDMDA,5,XPDI)) Q:'XPDI  S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.811,XPDMDA,Y)
 .;merge & repoint MEMBER - REMOTE (6;0)
 .S XPDI=0
 .F  S XPDI=$O(^TMP($J,"XPD",XPDMDA,6,XPDI)) Q:'XPDI  S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.812,XPDMDA,Y)
 .S DA=XPDMDA D IX1^DIK
 K ^TMP($J,"XPD")
 Q
HLAPF1 ;HL7 application parameter #771 file pre
 K ^TMP($J,"XPD")
 Q
HLAPE1 ;HL7 application parameter #771 entry pre
 N I,J
 S ^TMP($J,"XPD",DA)=""
 S I=^HL(771,DA,0),J=^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)
 ;save FACILITY NAME (0;3)
 S:$P(I,U,3)]"" $P(J,U,3)=$P(I,U,3)
 ;repoint MAIL GROUP (0;4)
 S:$P(J,U,4)]"" $P(J,U,4)=$$LK^XPDIA("^XMB(3.8)",$P(J,U,4))
 ;repoint COUNTRY CODE (0;7)
 S:$P(J,U,7)]"" $P(J,U,7)=$$LK^XPDIA("^HL(779.004)",$P(J,U,7))
 S ^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)=J
 ;remove HL7 SEGMENT (SEG;0), HL7 MESSAGE (MSG;0)
 K ^HL(771,DA,"SEG"),^("MSG")
 Q
HLAPF2 ;HL7 application parameter #771 file post
 N DA,DIK,XPDI,X,Y
 S DA=0,DIK="^HL(771,"
 F  S DA=$O(^TMP($J,"XPD",DA)) Q:'DA  D
 .;repoint HL7 SEGMENT (SEG;0)
 .S XPDI=0
 .F  S XPDI=$O(^HL(771,DA,"SEG",XPDI)) Q:'XPDI  S Y=$P($G(^(XPDI,0)),U) D
 ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
 ..I X]"" S $P(^HL(771,DA,"SEG",XPDI,0),U)=X Q
 ..K ^HL(771,DA,"SEG",XPDI)
 .;repoint HL7 MESSAGE (MSG;0)
 .S XPDI=0
 .F  S XPDI=$O(^HL(771,DA,"MSG",XPDI)) Q:'XPDI  S Y=$P($G(^(XPDI,0)),U) D
 ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
 ..I X]"" S $P(^HL(771,DA,"MSG",XPDI,0),U)=X Q
 ..K ^HL(771,DA,"MSG",XPDI)
 .D IX1^DIK
 K ^TMP($J,"XPD")
 Q
HLLLPE ;HL7 lower level protocol #869.2 entry pre
 N I
 S I=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)
 ;repoint LLP TYPE (0;2)
 S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)=$$LK^XPDIA("^HLCS(869.1)",I)
 S I=$P($G(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100)),U)
 ;repoint MAIL GROUP (100;1)
 S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
 ;save HLLP DEVICE (200;1)
 S I=$G(^HLCS(869.2,DA,200))
 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,200),U)=$P(I,U)
 ;save X3.28 DEVICE (300;1)
 S I=$G(^HLCS(869.2,DA,300))
 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,300),U)=$P(I,U)
 ;save TCP/IP Start-up Node (400;6)
 S I=$G(^HLCS(869.2,DA,400))
 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,400),U,6)=$P(I,U,6)
 Q
HLLLE ;HL7 logical link #870 entry pre
 N I,J,Y
 S I=^HLCS(870,DA,0),J=^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)
 ;repoint INSTITUTION (0;2)
 I $P(J,U,2)]"" S Y=$$LK^XPDIA("^DIC(4)",$P(J,U,2)) D:Y=""  S $P(J,U,2)=Y
 .D BMES^XPDUTL(" Couldn't resolve Institution "_$P(J,U,2)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
 ;repoint LLP PARAMETER (0;3)
 S:$P(J,U,3)]"" $P(J,U,3)=$$LK^XPDIA("^HLCS(869.2)",$P(J,U,3))
 ;repoint DOMAIN (0;7)
 I $P(J,U,7)]"" S Y=$$LK^XPDIA("^DIC(4.2)",$P(J,U,7)) D:Y=""  S $P(J,U,7)=Y
 .D BMES^XPDUTL(" Couldn't resolve Domain "_$P(J,U,7)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
 ;save QUEUE SIZE (0;21)
 S:$P(I,U,21)]"" $P(J,U,21)=$P(I,U,21)
 S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)=J
 Q
KEYDEL ;del security keys
 N XPDI S XPDI=0
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI  D DEL^XPDKEY(XPDI)
 Q
LMDEL ;del list manager templates
 N DA,DIK,XPDI
 S XPDI=0,DIK="^SD(409.61,"
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI  S DA=XPDI D ^DIK
 Q
RPCDEL ;del Kernel RPCs
 N DA,DIK,XPDI
 S XPDI=0,DIK="^XWB(8994,"
 F  S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI  S DA=XPDI D ^DIK
 Q

XPDIA2
XPDIA2 ;SFISC/RSD - Delete Options and cleanup pointers ;12/05/97  09:41
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**68**;Jul 10, 1995
 Q
OPT ;options
 N XPDI,XPDJ,XPDK,XPDM,XPDX,X
 ;XPDM=ien of the XMUSER option
 S X=$O(^DIC(19,"B","XMUSER",0)),XPDM=$S(X:X,1:"@"),XPDX=0
 ;loop thru all the options that are to be deleted
 F  S XPDX=$O(^TMP($J,"XPDEL",XPDX)) Q:'XPDX  D
 .;check that the following might reference this option, XPDX
 .;file 19, menu item, 10
 .S XPDI=0 F  S XPDI=$O(^DIC(19,"AD",XPDX,XPDI)) Q:'XPDI  D
 ..S XPDJ=0 F  S XPDJ=$O(^DIC(19,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ  D
 ...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
 ...D DIK("^DIC(19,"_XPDI_",10,",.XPDA,DUZ)
 .;file 19.081, field .01
 .S XPDI=0 F  S XPDI=$O(^XUSEC(19,"B",XPDX,XPDI)) Q:'XPDI  D DIK("^XUSEC(19,",XPDI,DUZ)
 .;file 19.2, field .01
 .S XPDI=0 F  S XPDI=$O(^DIC(19.2,"B",XPDX,XPDI)) Q:'XPDI  D DIK("^DIC(19.2,",XPDI,DUZ)
 .;file 200, secondary menu item, 203
 .S XPDI=0 F  S XPDI=$O(^VA(200,"AD",XPDX,XPDI)) Q:'XPDI  D
 ..S XPDJ=0 F  S XPDJ=$O(^VA(200,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ  D
 ...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
 ...D DIK("^VA(200,"_XPDI_",203,",.XPDA,DUZ)
 .Q
 ;
 ;loop thru New Person file
 S XPDI=0 F  S XPDI=$O(^VA(200,XPDI)) Q:'XPDI  D
 .K XPDK S X="XPDK(200,"""_XPDI_","")"
 .I $D(^VA(200,XPDI,201)) S XPDX=^(201) D
 ..;check primary option field 201
 ..S:$D(^TMP($J,"XPDEL",+XPDX)) @X@(201)=XPDM
 ..;check primary window field 201.1
 ..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,2))) @X@(201.1)="@"
 .;check last option accessed field 202.1
 .I $D(^VA(200,XPDI,202.1)),$D(^TMP($J,"XPDEL",+^(202.1))) S @X@(202.1)="@"
 .D:$D(XPDK) DIE(.XPDK,DUZ)
 .;loop thru delegated options field 19.5, this multiple is dinumed
 .S XPDJ=0 F  S XPDJ=$O(^VA(200,XPDI,19.5,XPDJ)) Q:'XPDJ  D:$D(^TMP($J,"XPDEL",XPDJ))
 ..N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
 ..D DIK("^VA(200,"_XPDI_",19.5,",.XPDA,DUZ)
 .Q
 ;
 ;loop thru Kernel Site Parameter file
 S XPDI=0 F  S XPDI=$O(^XTV(8989.3,XPDI)) Q:'XPDI  D
 .;loop thru alpha/beta test options field 33, node ABOPT, multiple is dinumed
 .S XPDJ=0 F  S XPDJ=$O(^XTV(8989.3,XPDI,"ABOPT",XPDJ)) Q:'XPDJ  D:$D(^TMP($J,"XPDEL",XPDJ))
 ..N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
 ..D DIK("^XTV(8989.3,"_XPDI_",""ABOPT"",",.XPDA,DUZ)
 .;loop thru option to audit field 19.1, node 19.1
 .S XPDJ=0 F  S XPDJ=$O(^XTV(8989.3,XPDI,19.1,"B",XPDJ)) Q:'XPDJ  D:$D(^TMP($J,"XPDEL",XPDJ))
 ..N XPDA S XPDK=$O(^XTV(8989.3,XPDI,19.1,"B",XPDJ,0)),XPDA=XPDK,XPDA(1)=XPDI
 ..D DIK("^XTV(8989.3,"_XPDI_",19.1,",.XPDA,DUZ)
 .Q
 ;
 ;loop thru Device File and check primary option field 201
 S XPDI=0 F  S XPDI=$O(^%ZIS(1,XPDI)) Q:'XPDI  D:$D(^TMP($J,"XPDEL",+$G(^(XPDI,201))))
 .K XPDK S XPDK(3.5,XPDI_",",201)="@" D DIE(.XPDK,DUZ)
 Q
 ;
PRO ;protocols
 N XPDI,XPDJ,XPDK,XPDX,X
 S XPDX=0
 ;loop thru all the protocols that are to be deleted
 F  S XPDX=$O(^TMP($J,"XPDEL",XPDX)) Q:'XPDX  D
 .;check that the following might reference this protocol, XPDX
 .;file 101, menu item, 10
 .S XPDI=0 F  S XPDI=$O(^ORD(101,"AD",XPDX,XPDI)) Q:'XPDI  D
 ..S XPDJ=0 F  S XPDJ=$O(^ORD(101,"AD",XPDX,XPDI,XPDJ)) Q:'XPDJ  D
 ...N XPDA S XPDA=XPDJ,XPDA(1)=XPDI
 ...D DIK("^ORD(101,"_XPDI_",10,",.XPDA,DUZ)
 .;file 123.1, REQUEST ACTION TYPE, field 2
 .S XPDI=0 F  S XPDI=$O(^GMR(123.1,"C",XPDX,XPDI)) Q:'XPDI  D
 ..S X=$G(^GMR(123.1,XPDI,0)) Q:X=""
 ..K XPDK S XPDK(123.1,XPDI_",",2)="@"
 ..D DIE(.XPDK,DUZ)
 .Q
 ;
 ;loop thru New Person file
 S XPDI=0 F  S XPDI=$O(^VA(200,XPDI)) Q:'XPDI  D
 .K XPDK S X="XPDK(200,"""_XPDI_","")"
 .I $D(^VA(200,XPDI,100.1)) S XPDX=^(100.1) D
 ..;check  PRIMARY OE/RR MENU, field 100.11
 ..S:$D(^TMP($J,"XPDEL",+XPDX)) @X@(100.11)="@"
 ..;check PRIMARY ORDER MENU, field 100.12
 ..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,2))) @X@(100.12)="@"
 .I $D(^VA(200,XPDI,100.2)) S XPDX=^(100.2) D
 ..;check  DEFAULT RESULT REPORTING MENU, field 100.23
 ..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,3))) @X@(100.23)="@"
 ..;check  PRIMARY PROFILE MENU, field 100.24
 ..S:$D(^TMP($J,"XPDEL",+$P(XPDX,U,4))) @X@(100.24)="@"
 .D:$D(XPDK) DIE(.XPDK,DUZ)
 Q
 ;
DIK(DIK,DA,DUZ) ;delete
 S DUZ(0)="@" D ^DIK
 Q
DIE(XPD,DUZ) ;
 ;XPD(file,DA_",",field)=XMUSER option or '@' to delete
 S DUZ(0)="@"
 D FILE^DIE("","XPD")
 Q

XPDIB
XPDIB ;SFISC/RSD - Backup installed Package ;01/29/97  10:43
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**10,58**;Jul 10, 1995
EN ;
 N XCNP,DIF,DIR,DIRUT,XMSUB,XMDUZ,XMDISPI,XMZ,XPD,XPDA,XPDNM,XPDQUIT,XPDST,XPDT,X,Y,%
 S %="I '$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%)
 Q:'XPDST!$D(XPDQUIT)
 S DIR(0)="F^3:65",DIR("A")="Subject",DIR("?")="Enter the subject for this Packman Backup Message"
 D ^DIR I $D(DIRUT) D QUIT^XPDI1(XPDST) Q
 S XMSUB=Y,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),XPD=""
 .I '$D(^XTMP("XPDI",XPDA,"RTN")) W !,"No routines for ",XPDNM,! Q
 .W !,"Loading Routines for ",XPDNM
 .F  S XPD=$O(^XTMP("XPDI",XPDA,"RTN",XPD)) Q:XPD=""  D ROU(XPD) W "."
 D EN3^XMD,QUIT^XPDI1(XPDST)
 Q
 ;
ROU(X) N %N,DIF
 X ^%ZOSF("TEST") E  W !,"Routine ",X," is not on the disk." Q
 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

XPDID
XPDID ;SFISC/VYD,RSD - Display Install Progress ;05/14/98  10:29
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**81**;Jul 10, 1995
 ;;
 Q
INIT ;initialize progress screen
 N X,XPDSTR
 I IO'=IO(0)!(IOST'["C-VT") S XPDIDVT=0 Q
 I $T(PREP^XGF)="" S XPDIDVT=0 Q
 ;S X="XGF" X ^%ZOSF("TEST") E  S XPDIDVT=0 Q
 D PREP^XGF
 S XPDIDVT=1,X="IOSTBM",XPDSTR="             25             50             75               "
 D ENDR^%ZISS
 S IOTM=3,IOBM=IOSL-4
 W @IOSTBM
 D FRAME^XGF(IOTM-2,0,IOTM-2,IOM-1)
 D FRAME^XGF(IOBM,0,IOBM,IOM-1)
 D FRAME^XGF(IOBM+1,10,IOBM+3,71)
 D SAY^XGF(IOBM+2,11,XPDSTR)
 D SAY^XGF(IOBM+2,0,$J("0",5)_"%")
 D SAY^XGF(IOBM+3,0,"Complete")
 D IOXY^XGF(IOTM-2,0)
 Q
 ;
EXIT(XPDM) ;exit progress screen restore screen to normal
 I $G(XPDIDVT) D
 .S IOTM=1,IOBM=IOSL
 .W @IOSTBM,@IOF
 .W:$G(XPDM)]"" !!,XPDM,!!
 .D CLEAN^XGF
 K IOTM,IOBM,IOSTBM,XPDIDCNT,XPDIDMOD,XPDIDTOT,XPDIDVT
 Q
 ;
TITLE(X) ;display title X
 Q:'XPDIDVT
 N XPDOX,XPDOY
 S XPDOX=$X,XPDOY=$Y
 D SAY^XGF(0,0,$$CJ^XLFSTR(X,IOM_"T")),CURSOR
 Q
 ;
SETTOT(X) ;X=file # from build
 Q:'$D(XPDIDVT)
 S XPDIDTOT=$S(X=4:+$P($G(^XTMP("XPDI",XPDA,"BLD",XPDBLD,4,0)),U,4),X=9.8:+$G(^XTMP("XPDI",XPDA,"RTN")),1:+$P($G(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"KRN",X,"NM",0)),U,4))
 S XPDIDMOD=$S(XPDIDTOT<60:1,1:XPDIDTOT\60),XPDIDCNT=0
 Q:'XPDIDVT
 D UPDATE(0)
 Q
 ;
UPDATE(XPDN) ;update the progress bar
 I 'XPDIDVT W "." Q
 N XPDLEN,XPDMC,XPDOX,XPDOY,XPDS,XPDSTR
 S XPDOX=$X,XPDOY=$Y,XPDMC=60,XPDSTR="             25             50             75               "
 S XPDLEN=$S(XPDIDTOT:XPDN/XPDIDTOT*XPDMC\1,1:0),XPDS=$E(XPDSTR,1,XPDLEN)
 D SAY^XGF(IOBM+2,11,XPDS,"R1")
 S XPDS=$E(XPDSTR,XPDLEN+1,XPDMC)
 D SAY^XGF(IOBM+2,11+XPDLEN,XPDS)
 D SAY^XGF(IOBM+2,0,$J(XPDLEN/XPDMC*100,5,0)),CURSOR
 Q
 ;
CURSOR ;put cursor back
 S:XPDOY>(IOBM-1) XPDOY=IOBM-1
 D IOXY^XGF(XPDOY,XPDOX)
 Q

XPDIGP
XPDIGP ;SFISC/RSD - load Global Distribution ; 28 Aug 96 08:52
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**41**;Jul 10, 1995
 ;XPDT is undefine if PKG^XPDIL1 aborted, need to close device
 I '$D(XPDT) D ^%ZISC Q
 N %,XPD,XPDIST,XPDBLD,XPDNM
 S XPDA=+XPDT(1),XPDNM=$P(XPDT(1),U,2),XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0))
 ;update Install file, read in the other globals, close device
 D XPCK,GPI:'$G(XPDQUIT),^%ZISC
 I $G(XPDQUIT) D ABRTALL^XPDI(1) Q
 ;run post install routine
 S XPD=$$INRTN^XPDIL1("INIT") I XPD]"" D
 .;% = routine name only, remove tag
 .S %=$P(XPD,U,$L(XPD,U)) Q:'$D(^XTMP("XPDI",XPDA,"RTN",%))
 .W ! D SAVE^XPDIJ(%),BMES^XPDUTL(" Running Post Install routine "_XPD),@XPD
 .;update Package file
 ;XPDIST is flag for site tracking, it is set in PKG^XPDIP
 S XPDIST=0 D BMES^XPDUTL(" Updating KIDS files... "),PKG^XPDIP
 ;sends site tracking bulletin
 I XPDIST S %=$$EN^XPDIST(XPDA) D BMES^XPDUTL(" "_$P("NO ",U,'%)_"Install Message sent to FORUM ")
 W !! D BMES^XPDUTL(" "_XPDNM_" Installed."),STMP^XPDIJ1(17) W !!
 K ^XTMP("XPDI",XPDA),XPD
 ;update the status field
 S XPD(9.7,XPDA_",",.02)=3 D FILE^DIE("","XPD")
 Q
DISP ;display the contents
 N X,Y,Z
 W !,"This is a Global Distribution. It contains Global(s) that will",!,"update your system at this time. The following Global(s) will be installed:",!!
 F Y=1:1 S X=$P(XPDGP,"^",Y) Q:X=""  D
 .S Z=+$P(X,";"),X=$P(X,";",2),XPDT("GP",X)=Z_U_Y
 .W "^"_X,?12,$P("Overwrite^Replace",U,Z+1),!
 .;if unsubscripted global and replacing
 .W:X'["("&Z "**WARNING - Global will be KILLED before install,",!,"Check global protection on ALL systems before continuing.",!
 W !,"If you continue with the Load, the Global(s) will be",!,"Installed at this time.",!
 Q
GPI ;global package input
 N DIRUT,GP,GR,X,XPDSEQ,Y,Z
 ;start reading the HFS again
 U IO R X:0,Y:0
 ;the next read must be the GLOBAL
 I X'="**GLOBAL**" U IO(0) W !!,"ERROR in HFS file format!" S XPDQUIT=1 Q
 U IO(0) D BMES^XPDUTL(" "_Y) U IO
 ;XPDSEQ is the disk sequence number
 S GP=$P(Y,U,2),GR=$S(Y[")":$E(Y,1,$L(Y)-1)_",",1:Y_"("),XPDSEQ=1
 K:XPDT("GP",GP) @Y
 ;X=global ref, Y=global value. DIRUT is when user is prompted for
 ;next disk in NEXTD and they abort
 F  R X:0,Y:0 Q:X="**END**"  D  I $D(DIRUT) S XPDQUIT=1 Q
 .;new global
 .I X="**GLOBAL**" D  Q
 ..;completes last global check point
 ..D XPCOM(GP,Y)
 ..;reset global ref
 ..S GP=$P(Y,U,2),GR=$S(Y[")":$E(Y,1,$L(Y)-1)_",",1:Y_"(")
 ..;kill global if flag is set
 ..K:XPDT("GP",GP) @Y
 .I X="**CONTINUE**" D NEXTD^XPDIL Q
 .S @(GR_X)=Y
 D XPCOM(GP)
 U IO(0)
 Q
 ;
 ;create Global multiple of Install file
XPCK N DIR,DIRUT,X,XPD,XPDJ,X,Y,Z
 S DIR(0)="Y",DIR("A")="Globals will now be installed, OK",DIR("B")="YES",DIR("?")="YES will continue with install, NO will abort install"
 W ! D ^DIR I $D(DIRUT)!'Y S XPDQUIT=1 Q
 W ! D BMES^XPDUTL(" Install Started for "_XPDNM_" : "),STMP^XPDIJ1(11),BMES^XPDUTL(" Installing Globals:")
 S X=""
 F  S X=$O(XPDT("GP",X)) Q:X=""  S Z=$P(XPDT("GP",X),U,2),XPD(9.718,"+"_Z_","_XPDA_",",.01)=X,XPDJ(Z)=Z
 D:$D(XPD)>9 UPDATE^DIE("S","XPD","XPDJ")
 Q
 ;
XPCOM(X,XPDN) ;complete checkpoint for global X,XPDN=next global
 N GR,GP,XPD,Y,Z
 U IO(0)
 S Y=$$NOW^XLFDT,Z=+$P(XPDT("GP",X),U,2),XPD(9.718,Z_","_XPDA_",",1)=Y
 D MES^XPDUTL("               "_$$FMTE^XLFDT(Y)),FILE^DIE("","XPD")
 D:$L($G(XPDN)) BMES^XPDUTL(" "_XPDN)
 U IO
 Q

XPDIJ
XPDIJ ;SFISC/RSD - Install Job ;08/17/98  13:34
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,21,28,41,44,68,81,95**;Jul 10, 1995
EN ;install all packages
 ;XPDA=ien of first package
 ;this is needed to restore XPDIJ1
 I $D(^XTMP("XPDI",XPDA,"RTN","XPDIJ1")) D
 .N DIE,XCM,XCN,XCS,X
 .S DIE="^XTMP(""XPDI"",XPDA,""RTN"",""XPDIJ1"",",XCN=0,X="XPDIJ1"
 .X ^%ZOSF("SAVE")
 .S XCN=$$RTNUP^XPDUTL("XPDIJ1",2)
 N IEN,XPDI,XPD0,XPDSET,XPDABORT,XPDMENU,XPDQUIT,XPDVOL,X,Y,ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK
 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XPDIJ"
 E  S X="ERR^XPDIJ",@^%ZOSF("TRAP")
 Q:'$D(^XPD(9.7,+$G(XPDA),0))  S XPD0=^(0)
 D INIT^XPDID
 ;disable options & protocols for setname, XPDSET=1/0^setname^out of order msg.
 S Y=$P(XPD0,U,8),XPDSET=+Y_U_$E(Y,2,99)_U_$S($L(Y):$P($G(^XTMP("XQOO",$E(Y,2,99),0)),U),1:"")
 ;hang the number of seconds given in 0;10
 I XPDSET D OFF^XQOO1($P(XPDSET,U,2)) I $P(XPD0,U,10) H ($P(XPD0,U,10)*60)
 ;XPDVOL is set only if they want to update other CPUs
 I $O(^XPD(9.7,XPDA,"VOL",0)) M XPDVOL=^XPD(9.7,XPDA,"VOL") D
 .S Y=0
 .F  S Y=$O(XPDVOL(Y)) Q:'Y  S $P(XPDVOL(Y,0),U,2,3)="^" K XPDVOL(Y,1)
 .;jobup RTN^XPDIJ(XPDA), to install routines on other CPU if Taskman is running
 .;check that taskman is running
 .D:$$TM^%ZTLOAD
 ..N XPDU,XPDY,XPDV,XPDV0,XPDVOL,ZTUCI,ZTCPU,ZTDESC,ZTRTN,ZTDTH,ZTIO,ZTSK
 ..X ^%ZOSF("UCI") S XPDU=$P(Y,","),XPDY=$P(Y,",",2),XPDV=0
 ..F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=$P(^(XPDV,0),U) D:XPDV0'=XPDY
 ...S ZTUCI=XPDU,ZTDTH=$H,ZTIO="",ZTDESC="KIDS update CPUs "_XPDV0,ZTCPU=XPDV0,ZTRTN="EN^XPDCPU("_XPDA_","_XPDV_")"
 ...D ^%ZTLOAD
 ...;save task number under Volume set multiple
 ...Q:'$G(ZTSK)  K XPD
 ...S XPD(9.703,XPDV_","_XPDA_",",3)=ZTSK D FILE^DIE("","XPD")
 S Y=0
 ;XPDABORT can be set in pre or post install to abort install
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S %=$O(^(Y,0)) D:%  Q:$D(XPDABORT)
 .;build volume multiple for each package
 .I $D(XPDVOL),'$D(^XPD(9.7,%,"VOL")) M ^("VOL")=XPDVOL
 .N XPD,XPDA,XPDNM,XPDV,XPDV0,XPDVOL,XPDX,XPDY,Y
 .S XPDA=%,XPDNM=$P($G(^XPD(9.7,XPDA,0)),U) D IN^XPDIJ1 Q:$D(XPDABORT)
 .;check status of other cpu jobs, do if not this volume
 .X ^%ZOSF("UCI") S XPDY=$P(Y,",",2),XPDV=0
 .F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=^(XPDV,0) D:$P(XPDV0,U)'=XPDY
 ..;if completed time,write message and quit
 ..I $P(XPDV0,U,2) D BMES^XPDUTL(" Job on VOLUME SET "_$P(XPDV0,U)_" Completed.") Q
 ..;if job had no start time, write message and quit
 ..I '$P(XPDV0,U,3) D  I '$P(XPDV0,U,3)  D VOLERR($P(XPDV0,U),1) Q
 ...D BMES^XPDUTL(" Waiting for job on VOLUME SET "_$P(XPDV0,U)_" to start.")
 ...;hang 1 minute, try 5 times
 ...F %=1:1:5 H 60 S XPDV0=^XPD(9.7,XPDA,"VOL",XPDV,0) Q:$P(XPDV0,U,3)
 ..D BMES^XPDUTL(" Waiting for job on VOLUME SET "_$P(XPDV0,U)_" to complete.")
 ..S XPD=0,XPDX=$G(^XPD(9.7,XPDA,"VOL",XPDV,1))
 ..;check the last update node
 ..F  S Y=$P(^XPD(9.7,XPDA,"VOL",XPDV,0),U,2),X=$G(^(1)),XPD=XPD+1 Q:XPD>360!Y  S:X'=XPDX XPD=0,XPDX=X H 10
 ..;quit if we have a complete time
 ..I Y D BMES^XPDUTL(" Job on VOLUME SET "_$P(XPDV0,U)_" Completed.") Q
 ..D VOLERR($P(XPDV0,U),0)
 ;ZTREQ tells taskman to delete task
 I $G(ZTSK) S ZTREQ="@" D
 .;remove task # from Install File
 .N XPD S XPD(9.7,XPDA_",",5)="@"
 .D FILE^DIE("","XPD")
 ;quit if install was aborted
 I $D(XPDABORT) D EXIT^XPDID("Install Aborted!!"),^%ZISC Q
 ;put option back in order
 I $P(XPDSET,U,2)]"" D ON^XQOO1($P(XPDSET,U,2)) K ^XTMP("XQOO",$P(XPDSET,U,2))
 ;check if menu rebuild is wanted (only if option has been added)
 S IEN=""
 S IEN=$O(^XPD(9.7,XPDA,"QUES","B","XPO1",IEN))
 D:IEN
 .I ^XPD(9.7,XPDA,"QUES",IEN,1)  D
 ..D KIDS^XQ81
 ..;check if need to queue menu rebuild on other CPUs
 ..D:$O(^XPD(9.7,XPDA,"VOL",0))
 ...N XPDU,XPDY,XPDV,XPDV0,ZTUCI,ZTCPU
 ...X ^%ZOSF("UCI") S XPDU=$P(Y,","),XPDY=$P(Y,",",2),XPDV=0
 ...;loop thru VOLUMES SET and don't do current volume set
 ...F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=$P(^(XPDV,0),U) D:XPDV0'=XPDY
 ....S ZTUCI=XPDU,ZTDTH=$H,ZTIO="",ZTDESC="Install Menu Rebuild",ZTCPU=XPDV0,ZTRTN="KIDS^XQ81" D ^%ZTLOAD
 ;
 ;clean up globals
 S Y=0
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S XPDI=$O(^(Y,0)) D:XPDI
 .N Y,XPD
 .;kill transport global
 .K ^XTMP("XPDI",XPDI)
 .;update the status field
 .S XPD(9.7,XPDI_",",.02)=3
 .D FILE^DIE("","XPD")
 D EXIT^XPDID("Install Completed"),^%ZISC
 Q
 ;
SAVE(X) ;restore routine X
 N %,DIE,XCM,XCN,XCS
 S DIE="^XTMP(""XPDI"",XPDA,""RTN"",X,",XCN=0
 X ^%ZOSF("SAVE")
 Q
RTN(XPDA) ;restore all routines for package XPDA
 ;^XPD("XPDI",XPDA,"RTN",routine name)=0-install, 1-delete, 2-skip^checksum
 Q:$G(XPDA)=""
 N X,XPDI,XPDJ S XPDI=""
 F  S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDI)) Q:XPDI=""  S XPDJ=^(XPDI) D
 .;if we are doing VT graphic display, set counter
 .I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
 .I 'XPDJ D SAVE(XPDI) Q
 .;set checksum to null, since routine wasn't loaded
 .I $P(XPDJ,U,2) S $P(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"KRN",9.8,"NM",$P(XPDJ,U,2),0),U,4)=""
 .I $P(XPDJ,U)=1 S X=XPDI X ^%ZOSF("DEL")
 ;if graphic display, update full count
 I $D(XPDIDVT) D UPDATE^XPDID(XPDIDCNT)
 Q
 ;
VOLERR(V,F) ;volume set not updated,V=volume set, F=flag
 N XQA,XQAMSG,XPDMES
 S XPDMES(1)=" ",XPDMES(2)=" ** Job on VOLUME SET "_V_$S(F:" never started **",1:" has been idle for an hour.")
 S XPDMES(3)=" ** "_V_" has NOT been updated! **"
 S XQA(DUZ)="",XQAMSG="VOLUME SET "_V_" NOT updated for Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)
 D MES^XPDUTL(.XPDMES),SETUP^XQALERT
 Q
 ;come here on error, record error in Install file and cleanup var.
ERR N XPDERROR,XQA,XQAMSG
 S XPDERROR=$$EC^%ZOSV
 ;record error, write message, reset terminal
 D ^%ZTER,BMES^XPDUTL(XPDERROR),EXIT^XPDID()
 S XQA(DUZ)="",XQAMSG="Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)_" has encountered an Error."
 D SETUP^XQALERT G UNWIND^%ZTER

XPDIJ1
XPDIJ1 ;SFISC/RSD - Cont. of Install Job ;11/13/97  09:12
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**41,68**;Jul 10, 1995
IN ;install XPDA
 ;XPDA=ien of file 9.7, XPDNM=package name
 Q:'$D(^XTMP("XPDI",XPDA))!'$D(^XPD(9.7,XPDA,0))
 ;check if already installed
 I $P($G(^XPD(9.7,XPDA,1)),U,3) D BMES^XPDUTL(" "_XPDNM_" Already Installed ") Q
 N DIFROM,XPD,XPDBLD,XPDCHECK,XPDCP,XPDI,XPDGREF,XPDIST,XPDIDTOT,XPDIDCNT,XPDIDMOD,XPDRTN
 ;XPDBLD subscript for build entry i.e. ^XTMP("XPDI",XPDA,"BLD",XPDBLD
 S DIFROM=$$VER^XPDUTL(XPDNM),XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
 D TITLE^XPDID(XPDNM)
 ;the $T is there only for installing patch 41 to prevent a noline error
 ;check that Package file has entry
 I $T(PKGADD^XPDIP)]"" S Y=$$PKGADD^XPDIP
 I '$$CHK(11) D
 .D BMES^XPDUTL(" Install Started for "_XPDNM_" : "),STMP(11)
 .;update status and installed by fields
 .S XPD(9.7,XPDA_",",.02)=2,XPD(9.7,XPDA_",",9)=DUZ
 .D FILE^DIE("","XPD")
 E  D BMES^XPDUTL(" Install Restarted for "_XPDNM_" at "_$$HTE^XLFDT($H))
 I '$$CHK(12) D
 .D BMES^XPDUTL(" Installing Routines:"),SETTOT^XPDID(9.8),RTN^XPDIJ(XPDA),STMP(12)
 E  D BMES^XPDUTL(" Routines already installed.")
 S XPDCP="INI"
 ;check if pre-install has completed
 I '$$VERCP^XPDUTL("XPD PREINSTALL COMPLETED") D  Q:$D(XPDABORT)
 .;setup XPDQUES array with pre-install questions/answers
 .D QUES^XPDIQ("PRE")
 .;XPDCHECK=ien of current checkpoint, (0)=name of checkpoint
 .;XPDCP="INI"-pre install or "INIT"-post install
 .;loop thru check points starting with INSTALL STARTED
 .S XPDCHECK=1
 .F  S XPDCHECK=$O(^XPD(9.7,XPDA,"INI",XPDCHECK)) Q:'XPDCHECK  S XPD=^(XPDCHECK,0) D  Q:$D(XPDABORT)
 ..;if there is no call back, quit
 ..Q:$G(^XPD(9.7,XPDA,"INI",XPDCHECK,1))=""  S XPDRTN=^(1)
 ..;check if checkpoint has been completed
 ..Q:$P(XPD,U,2)
 ..I XPDCHECK=2 D BMES^XPDUTL(" Running Pre-Install Routine: "_XPDRTN)
 ..;zero the progress bar
 ..I $D(XPDIDVT) S XPDIDTOT=0 D UPDATE^XPDID(0)
 ..D @XPDRTN
 ..;write message and abort if developer wants
 ..I $D(XPDABORT) D BMES^XPDUTL("Install ** ABORTED ** in Pre-Install program") Q
 ..S %=$$COMCP^XPDUTL(XPDCHECK)
 .Q:$D(XPDABORT)
 .;complete pre-init check point
 .S %=$$COMCP^XPDUTL("XPD PREINSTALL COMPLETED")
 E  D BMES^XPDUTL(" Pre-Install already finished.")
 ;build XPDQUES arrays for all of the FM Files
 D QUES^XPDIQ("XPF")
 ;check the last file and see if it's already installed
 S XPD=$G(^(+$O(^XPD(9.7,XPDA,4,"A"),-1),0))
 I '$P(XPD,U,2) D:$D(^XTMP("XPDI",XPDA,"FIA"))
 .D BMES^XPDUTL(" Installing Data Dictionaries: "),SETTOT^XPDID(4),FIA^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" Data Dictionaries already installed.")
 S %=+$O(^XTMP("XPDI",XPDA,"DATA",""),-1),XPD=$G(^XPD(9.7,XPDA,4,%,0))
 I '$P(XPD,U,3) D:%
 .D BMES^XPDUTL(" Installing Data: "),DAT^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" Data already installed.")
 S (%,XPD)=""
 F  S %=+$O(^XPD(9.7,XPDA,"KRN",%)) Q:'%  S XPD=$G(^(%,0)) Q:'$P(XPD,U,2)
 I '$P(XPD,U,2) D:$D(^XTMP("XPDI",XPDA,"KRN"))
 .D BMES^XPDUTL(" Installing PACKAGE COMPONENTS: "),KRN^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" PACKAGE COMPONENTS already installed.")
 S XPDCP="INIT"
 ;check if post-install has completed
 I '$$VERCP^XPDUTL("XPD POSTINSTALL COMPLETED") D  Q:$D(XPDABORT)
 .;setup XPDQUES array with post-install questions/answers
 .D QUES^XPDIQ("POS")
 .;loop thru check points starting with INSTALL STARTED
 .S XPDCHECK=1
 .F  S XPDCHECK=$O(^XPD(9.7,XPDA,"INIT",XPDCHECK)) Q:'XPDCHECK  S XPD=^(XPDCHECK,0) D  Q:$D(XPDABORT)
 ..;if there is no call back, quit
 ..Q:$G(^XPD(9.7,XPDA,"INIT",XPDCHECK,1))=""  S XPDRTN=^(1)
 ..;quit if checkpoint has completed time
 ..Q:$P(XPD,U,2)
 ..I XPDCHECK=2 D BMES^XPDUTL(" Running Post-Install Routine: "_XPDRTN)
 ..;zero the progress bar
 ..I $D(XPDIDVT) S XPDIDTOT=0 D UPDATE^XPDID(0)
 ..D @XPDRTN
 ..;write message and abort if developer wants
 ..I $D(XPDABORT) D BMES^XPDUTL("Install ** ABORTED ** in Post-Install program") Q
 ..S %=$$COMCP^XPDUTL(XPDCHECK)
 .Q:$D(XPDABORT)
 .;complete post-init check point
 .S %=$$COMCP^XPDUTL("XPD POSTINSTALL COMPLETED")
 E  D BMES^XPDUTL(" Post-Install already finished.")
 ;move routines to install file & Routine file
 D BMES^XPDUTL(" Updating Routine file..."),SETTOT^XPDID(9.8),RTN^XPDIP
 ;XPDIST is flag for site tracking^A/B install message, it is set in PKG^XPDIP
 ;install Package file, OERR parameter multiple, and Build file
 S XPDIST="" D BMES^XPDUTL(" Updating KIDS files..."),PKG^XPDIP
 D BMES^XPDUTL(" "_XPDNM_" Installed. "),STMP(17)
 ;sends install messages
 I $L(XPDIST) S %=$$EN^XPDIST(XPDA,XPDIST) D BMES^XPDUTL(" "_$P("NO ",U,'$P(%,"#",2))_"Install Message sent "_%)
 Q
CHK(X) ;check checkpoints in file 9.7, X=field #, returns 1=completed, 0=not completed
 Q $$GET1^DIQ(9.7,XPDA_",",X,"I")]""
 ;
STMP(X) ;timestamp checkpoints in file 9.7, X=field #
 N XPD,%
 S %=$$NOW^XLFDT,XPD(9.7,XPDA_",",X)=%
 D MES^XPDUTL("               "_$$FMTE^XLFDT(%)),FILE^DIE("","XPD")
 Q

XPDIJ1Z
XPDIJ1 ;SFISC/RSD - Cont. of Install Job ;11/13/97  09:12
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**41,68**;Jul 10, 1995
IN ;install XPDA
 ;XPDA=ien of file 9.7, XPDNM=package name
 Q:'$D(^XTMP("XPDI",XPDA))!'$D(^XPD(9.7,XPDA,0))
 ;check if already installed
 I $P($G(^XPD(9.7,XPDA,1)),U,3) D BMES^XPDUTL(" "_XPDNM_" Already Installed ") Q
 N DIFROM,XPD,XPDBLD,XPDCHECK,XPDCP,XPDI,XPDGREF,XPDIST,XPDIDTOT,XPDIDCNT,XPDIDMOD,XPDRTN
 ;XPDBLD subscript for build entry i.e. ^XTMP("XPDI",XPDA,"BLD",XPDBLD
 S DIFROM=$$VER^XPDUTL(XPDNM),XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
 D TITLE^XPDID(XPDNM)
 ;the $T is there only for installing patch 41 to prevent a noline error
 ;check that Package file has entry
 I $T(PKGADD^XPDIP)]"" S Y=$$PKGADD^XPDIP
 I '$$CHK(11) D
 .D BMES^XPDUTL(" Install Started for "_XPDNM_" : "),STMP(11)
 .;update status and installed by fields
 .S XPD(9.7,XPDA_",",.02)=2,XPD(9.7,XPDA_",",9)=DUZ
 .D FILE^DIE("","XPD")
 E  D BMES^XPDUTL(" Install Restarted for "_XPDNM_" at "_$$HTE^XLFDT($H))
 I '$$CHK(12) D
 .D BMES^XPDUTL(" Installing Routines:"),SETTOT^XPDID(9.8),RTN^XPDIJ(XPDA),STMP(12)
 E  D BMES^XPDUTL(" Routines already installed.")
 S XPDCP="INI"
 ;check if pre-install has completed
 I '$$VERCP^XPDUTL("XPD PREINSTALL COMPLETED") D  Q:$D(XPDABORT)
 .;setup XPDQUES array with pre-install questions/answers
 .D QUES^XPDIQ("PRE")
 .;XPDCHECK=ien of current checkpoint, (0)=name of checkpoint
 .;XPDCP="INI"-pre install or "INIT"-post install
 .;loop thru check points starting with INSTALL STARTED
 .S XPDCHECK=1
 .F  S XPDCHECK=$O(^XPD(9.7,XPDA,"INI",XPDCHECK)) Q:'XPDCHECK  S XPD=^(XPDCHECK,0) D  Q:$D(XPDABORT)
 ..;if there is no call back, quit
 ..Q:$G(^XPD(9.7,XPDA,"INI",XPDCHECK,1))=""  S XPDRTN=^(1)
 ..;check if checkpoint has been completed
 ..Q:$P(XPD,U,2)
 ..I XPDCHECK=2 D BMES^XPDUTL(" Running Pre-Install Routine: "_XPDRTN)
 ..;zero the progress bar
 ..I $D(XPDIDVT) S XPDIDTOT=0 D UPDATE^XPDID(0)
 ..D @XPDRTN
 ..;write message and abort if developer wants
 ..I $D(XPDABORT) D BMES^XPDUTL("Install ** ABORTED ** in Pre-Install program") Q
 ..S %=$$COMCP^XPDUTL(XPDCHECK)
 .Q:$D(XPDABORT)
 .;complete pre-init check point
 .S %=$$COMCP^XPDUTL("XPD PREINSTALL COMPLETED")
 E  D BMES^XPDUTL(" Pre-Install already finished.")
 ;build XPDQUES arrays for all of the FM Files
 D QUES^XPDIQ("XPF")
 ;check the last file and see if it's already installed
 S XPD=$G(^(+$O(^XPD(9.7,XPDA,4,"A"),-1),0))
 I '$P(XPD,U,2) D:$D(^XTMP("XPDI",XPDA,"FIA"))
 .D BMES^XPDUTL(" Installing Data Dictionaries: "),SETTOT^XPDID(4),FIA^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" Data Dictionaries already installed.")
 S %=+$O(^XTMP("XPDI",XPDA,"DATA",""),-1),XPD=$G(^XPD(9.7,XPDA,4,%,0))
 I '$P(XPD,U,3) D:%
 .D BMES^XPDUTL(" Installing Data: "),DAT^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" Data already installed.")
 S (%,XPD)=""
 F  S %=+$O(^XPD(9.7,XPDA,"KRN",%)) Q:'%  S XPD=$G(^(%,0)) Q:'$P(XPD,U,2)
 I '$P(XPD,U,2) D:$D(^XTMP("XPDI",XPDA,"KRN"))
 .D BMES^XPDUTL(" Installing PACKAGE COMPONENTS: "),KRN^XPDIK,MES^XPDUTL("               "_$$HTE^XLFDT($H))
 E  D BMES^XPDUTL(" PACKAGE COMPONENTS already installed.")
 S XPDCP="INIT"
 ;check if post-install has completed
 I '$$VERCP^XPDUTL("XPD POSTINSTALL COMPLETED") D  Q:$D(XPDABORT)
 .;setup XPDQUES array with post-install questions/answers
 .D QUES^XPDIQ("POS")
 .;loop thru check points starting with INSTALL STARTED
 .S XPDCHECK=1
 .F  S XPDCHECK=$O(^XPD(9.7,XPDA,"INIT",XPDCHECK)) Q:'XPDCHECK  S XPD=^(XPDCHECK,0) D  Q:$D(XPDABORT)
 ..;if there is no call back, quit
 ..Q:$G(^XPD(9.7,XPDA,"INIT",XPDCHECK,1))=""  S XPDRTN=^(1)
 ..;quit if checkpoint has completed time
 ..Q:$P(XPD,U,2)
 ..I XPDCHECK=2 D BMES^XPDUTL(" Running Post-Install Routine: "_XPDRTN)
 ..;zero the progress bar
 ..I $D(XPDIDVT) S XPDIDTOT=0 D UPDATE^XPDID(0)
 ..D @XPDRTN
 ..;write message and abort if developer wants
 ..I $D(XPDABORT) D BMES^XPDUTL("Install ** ABORTED ** in Post-Install program") Q
 ..S %=$$COMCP^XPDUTL(XPDCHECK)
 .Q:$D(XPDABORT)
 .;complete post-init check point
 .S %=$$COMCP^XPDUTL("XPD POSTINSTALL COMPLETED")
 E  D BMES^XPDUTL(" Post-Install already finished.")
 ;move routines to install file & Routine file
 D BMES^XPDUTL(" Updating Routine file..."),SETTOT^XPDID(9.8),RTN^XPDIP
 ;XPDIST is flag for site tracking^A/B install message, it is set in PKG^XPDIP
 ;install Package file, OERR parameter multiple, and Build file
 S XPDIST="" D BMES^XPDUTL(" Updating KIDS files..."),PKG^XPDIP
 D BMES^XPDUTL(" "_XPDNM_" Installed. "),STMP(17)
 ;sends install messages
 I $L(XPDIST) S %=$$EN^XPDIST(XPDA,XPDIST) D BMES^XPDUTL(" "_$P("NO ",U,'$P(%,"#",2))_"Install Message sent "_%)
 Q
CHK(X) ;check checkpoints in file 9.7, X=field #, returns 1=completed, 0=not completed
 Q $$GET1^DIQ(9.7,XPDA_",",X,"I")]""
 ;
STMP(X) ;timestamp checkpoints in file 9.7, X=field #
 N XPD,%
 S %=$$NOW^XLFDT,XPD(9.7,XPDA_",",X)=%
 D MES^XPDUTL("               "_$$FMTE^XLFDT(%)),FILE^DIE("","XPD")
 Q

XPDIJZ
XPDIJ ;SFISC/RSD - Install Job ;08/17/98  13:34
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,21,28,41,44,68,81,95**;Jul 10, 1995
EN ;install all packages
 ;XPDA=ien of first package
 ;this is needed to restore XPDIJ1
 I $D(^XTMP("XPDI",XPDA,"RTN","XPDIJ1")) D
 .N DIE,XCM,XCN,XCS,X
 .S DIE="^XTMP(""XPDI"",XPDA,""RTN"",""XPDIJ1"",",XCN=0,X="XPDIJ1"
 .X ^%ZOSF("SAVE")
 .S XCN=$$RTNUP^XPDUTL("XPDIJ1",2)
 N IEN,XPDI,XPD0,XPDSET,XPDABORT,XPDMENU,XPDQUIT,XPDVOL,X,Y,ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK
 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XPDIJ"
 E  S X="ERR^XPDIJ",@^%ZOSF("TRAP")
 Q:'$D(^XPD(9.7,+$G(XPDA),0))  S XPD0=^(0)
 D INIT^XPDID
 ;disable options & protocols for setname, XPDSET=1/0^setname^out of order msg.
 S Y=$P(XPD0,U,8),XPDSET=+Y_U_$E(Y,2,99)_U_$S($L(Y):$P($G(^XTMP("XQOO",$E(Y,2,99),0)),U),1:"")
 ;hang the number of seconds given in 0;10
 I XPDSET D OFF^XQOO1($P(XPDSET,U,2)) I $P(XPD0,U,10) H ($P(XPD0,U,10)*60)
 ;XPDVOL is set only if they want to update other CPUs
 I $O(^XPD(9.7,XPDA,"VOL",0)) M XPDVOL=^XPD(9.7,XPDA,"VOL") D
 .S Y=0
 .F  S Y=$O(XPDVOL(Y)) Q:'Y  S $P(XPDVOL(Y,0),U,2,3)="^" K XPDVOL(Y,1)
 .;jobup RTN^XPDIJ(XPDA), to install routines on other CPU if Taskman is running
 .;check that taskman is running
 .D:$$TM^%ZTLOAD
 ..N XPDU,XPDY,XPDV,XPDV0,XPDVOL,ZTUCI,ZTCPU,ZTDESC,ZTRTN,ZTDTH,ZTIO,ZTSK
 ..X ^%ZOSF("UCI") S XPDU=$P(Y,","),XPDY=$P(Y,",",2),XPDV=0
 ..F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=$P(^(XPDV,0),U) D:XPDV0'=XPDY
 ...S ZTUCI=XPDU,ZTDTH=$H,ZTIO="",ZTDESC="KIDS update CPUs "_XPDV0,ZTCPU=XPDV0,ZTRTN="EN^XPDCPU("_XPDA_","_XPDV_")"
 ...D ^%ZTLOAD
 ...;save task number under Volume set multiple
 ...Q:'$G(ZTSK)  K XPD
 ...S XPD(9.703,XPDV_","_XPDA_",",3)=ZTSK D FILE^DIE("","XPD")
 S Y=0
 ;XPDABORT can be set in pre or post install to abort install
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S %=$O(^(Y,0)) D:%  Q:$D(XPDABORT)
 .;build volume multiple for each package
 .I $D(XPDVOL),'$D(^XPD(9.7,%,"VOL")) M ^("VOL")=XPDVOL
 .N XPD,XPDA,XPDNM,XPDV,XPDV0,XPDVOL,XPDX,XPDY,Y
 .S XPDA=%,XPDNM=$P($G(^XPD(9.7,XPDA,0)),U) D IN^XPDIJ1 Q:$D(XPDABORT)
 .;check status of other cpu jobs, do if not this volume
 .X ^%ZOSF("UCI") S XPDY=$P(Y,",",2),XPDV=0
 .F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=^(XPDV,0) D:$P(XPDV0,U)'=XPDY
 ..;if completed time,write message and quit
 ..I $P(XPDV0,U,2) D BMES^XPDUTL(" Job on VOLUME SET "_$P(XPDV0,U)_" Completed.") Q
 ..;if job had no start time, write message and quit
 ..I '$P(XPDV0,U,3) D  I '$P(XPDV0,U,3)  D VOLERR($P(XPDV0,U),1) Q
 ...D BMES^XPDUTL(" Waiting for job on VOLUME SET "_$P(XPDV0,U)_" to start.")
 ...;hang 1 minute, try 5 times
 ...F %=1:1:5 H 60 S XPDV0=^XPD(9.7,XPDA,"VOL",XPDV,0) Q:$P(XPDV0,U,3)
 ..D BMES^XPDUTL(" Waiting for job on VOLUME SET "_$P(XPDV0,U)_" to complete.")
 ..S XPD=0,XPDX=$G(^XPD(9.7,XPDA,"VOL",XPDV,1))
 ..;check the last update node
 ..F  S Y=$P(^XPD(9.7,XPDA,"VOL",XPDV,0),U,2),X=$G(^(1)),XPD=XPD+1 Q:XPD>360!Y  S:X'=XPDX XPD=0,XPDX=X H 10
 ..;quit if we have a complete time
 ..I Y D BMES^XPDUTL(" Job on VOLUME SET "_$P(XPDV0,U)_" Completed.") Q
 ..D VOLERR($P(XPDV0,U),0)
 ;ZTREQ tells taskman to delete task
 I $G(ZTSK) S ZTREQ="@" D
 .;remove task # from Install File
 .N XPD S XPD(9.7,XPDA_",",5)="@"
 .D FILE^DIE("","XPD")
 ;quit if install was aborted
 I $D(XPDABORT) D EXIT^XPDID("Install Aborted!!"),^%ZISC Q
 ;put option back in order
 I $P(XPDSET,U,2)]"" D ON^XQOO1($P(XPDSET,U,2)) K ^XTMP("XQOO",$P(XPDSET,U,2))
 ;check if menu rebuild is wanted (only if option has been added)
 S IEN=""
 S IEN=$O(^XPD(9.7,XPDA,"QUES","B","XPO1",IEN))
 D:IEN
 .I ^XPD(9.7,XPDA,"QUES",IEN,1)  D
 ..D KIDS^XQ81
 ..;check if need to queue menu rebuild on other CPUs
 ..D:$O(^XPD(9.7,XPDA,"VOL",0))
 ...N XPDU,XPDY,XPDV,XPDV0,ZTUCI,ZTCPU
 ...X ^%ZOSF("UCI") S XPDU=$P(Y,","),XPDY=$P(Y,",",2),XPDV=0
 ...;loop thru VOLUMES SET and don't do current volume set
 ...F  S XPDV=$O(^XPD(9.7,XPDA,"VOL",XPDV)) Q:'XPDV  S XPDV0=$P(^(XPDV,0),U) D:XPDV0'=XPDY
 ....S ZTUCI=XPDU,ZTDTH=$H,ZTIO="",ZTDESC="Install Menu Rebuild",ZTCPU=XPDV0,ZTRTN="KIDS^XQ81" D ^%ZTLOAD
 ;
 ;clean up globals
 S Y=0
 F  S Y=$O(^XPD(9.7,"ASP",XPDA,Y)) Q:'Y  S XPDI=$O(^(Y,0)) D:XPDI
 .N Y,XPD
 .;kill transport global
 .K ^XTMP("XPDI",XPDI)
 .;update the status field
 .S XPD(9.7,XPDI_",",.02)=3
 .D FILE^DIE("","XPD")
 D EXIT^XPDID("Install Completed"),^%ZISC
 Q
 ;
SAVE(X) ;restore routine X
 N %,DIE,XCM,XCN,XCS
 S DIE="^XTMP(""XPDI"",XPDA,""RTN"",X,",XCN=0
 X ^%ZOSF("SAVE")
 Q
RTN(XPDA) ;restore all routines for package XPDA
 ;^XPD("XPDI",XPDA,"RTN",routine name)=0-install, 1-delete, 2-skip^checksum
 Q:$G(XPDA)=""
 N X,XPDI,XPDJ S XPDI=""
 F  S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDI)) Q:XPDI=""  S XPDJ=^(XPDI) D
 .;if we are doing VT graphic display, set counter
 .I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
 .I 'XPDJ D SAVE(XPDI) Q
 .;set checksum to null, since routine wasn't loaded
 .I $P(XPDJ,U,2) S $P(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"KRN",9.8,"NM",$P(XPDJ,U,2),0),U,4)=""
 .I $P(XPDJ,U)=1 S X=XPDI X ^%ZOSF("DEL")
 ;if graphic display, update full count
 I $D(XPDIDVT) D UPDATE^XPDID(XPDIDCNT)
 Q
 ;
VOLERR(V,F) ;volume set not updated,V=volume set, F=flag
 N XQA,XQAMSG,XPDMES
 S XPDMES(1)=" ",XPDMES(2)=" ** Job on VOLUME SET "_V_$S(F:" never started **",1:" has been idle for an hour.")
 S XPDMES(3)=" ** "_V_" has NOT been updated! **"
 S XQA(DUZ)="",XQAMSG="VOLUME SET "_V_" NOT updated for Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)
 D MES^XPDUTL(.XPDMES),SETUP^XQALERT
 Q
 ;come here on error, record error in Install file and cleanup var.
ERR N XPDERROR,XQA,XQAMSG
 S XPDERROR=$$EC^%ZOSV
 ;record error, write message, reset terminal
 D ^%ZTER,BMES^XPDUTL(XPDERROR),EXIT^XPDID()
 S XQA(DUZ)="",XQAMSG="Install "_$E($P($G(^XPD(9.7,+$G(XPDA),0)),"^"),1,30)_" has encountered an Error."
 D SETUP^XQALERT G UNWIND^%ZTER

XPDIK
XPDIK ;SFISC/RSD - Install Kernel Files & FM Files ;03/21/97  11:41
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,58**;Jul 10, 1995
 Q
KRN ;
 ;XPDA=package ien in INSTALL FILE, XPDNM=package name, XPDCP= check points
 N DA,DIC,DIOVRD,EPOS,EPRE,FDEL,FPOS,FPRE,OLDA,ORD,X,XGCEDITR,XPDFIL,XPDFILNM,XPDFL,XPDNEW,XREF,Y,%
 ;DIOVRD is used to override write protection on a file
 ;XGCEDITR is check in file 8995, at 'SCR' node of DD
 S ORD=0,XPDCP="KRN",(DIOVRD,XGCEDITR)=1
 F  S ORD=$O(^XTMP("XPDI",XPDA,"ORD",ORD)) Q:'ORD  S XPDFIL=+$O(^(ORD,0)),XREF=$G(^(XPDFIL)),XPDFILNM=$G(^(XPDFIL,0)) D:XPDFIL
 .;sets up EPOS,EPRE,FDEL,FPOS,FPRE variables
 .F DA=1:1:5 S @$P("FPRE^EPRE^FPOS^EPOS^FDEL",U,DA)=$P(XREF,";",DA+5)
 .K DIC,^TMP($J,"XPDEL")
 .S DIC=$G(^DIC(XPDFIL,0,"GL")),XREF=+$P(XREF,";",3)
 .;check if file, XPDFIL, exist at this site
 .I $P($G(^DIC(XPDFIL,0)),U)'=XPDFILNM D BMES^XPDUTL(" File "_XPDFIL_" is not "_XPDFILNM_", nothing installed.") Q
 .;check if XPDFIL has already been installed
 .I $P(^XPD(9.7,XPDA,"KRN",XPDFIL,0),U,2) D BMES^XPDUTL(" "_XPDFILNM_" already installed.") Q
 .D BMES^XPDUTL(" Installing "_XPDFILNM),SETTOT^XPDID(XPDFIL)
 .;do File Pre-install action, continue if ok
 .;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
 .;loops thru the entries for this file
 .I '$$ACT(FPRE) S OLDA=0 F  S OLDA=$O(^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)) Q:'OLDA  S XPDFL=+$G(^(OLDA,-1)),OLDA(0)=^(0) D
 ..;if we are doing VT graphic display, set counter
 ..I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
 ..;quit if disable or attach (4 or 5).  Attach will be processed under the parent menu.
 ..Q:XPDFL>3
 ..;if FM file, need to set screening logic
 ..I XPDFIL<.44 S %=$S(XPDFIL'=.403:4,1:8),DIC("S")="I $P(^(0),U,"_%_")="_$P(OLDA(0),U,%)
 ..;if deleting at site and a template, reset the lookup value and DIC("S")
 ..I XPDFL=1,XPDFIL<.44 S %=$P(OLDA(0),U),$P(OLDA(0),U)=$P(%,"    FILE #"),DIC("S")="I $P(^(0),U,"_$S(XPDFIL'=.403:4,1:8)_")="_+$P(%,"    FILE #",2)
 ..;XPDNEW=1 if entry is new, laygo
 ..S X=$P(OLDA(0),U),Y=$$DIC(XPDFIL,X,$G(DIC("S")),XPDFL) Q:'Y  S DA=+Y,XPDNEW=$P(Y,U,3)
 ..;if deleting then save and process after FPOS
 ..I XPDFL=1 S ^TMP($J,"XPDEL",DA)="" Q
 ..;do Entries Pre-install action
 ..Q:$$ACT(EPRE)
 ..;merges the data, if you want the data deleted before the merge, you must
 ..;do it in the Entry Pre-install node, EPRE.
 ..M @(DIC_DA_")")=^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)
 ..;kill the flag node from the live data node
 ..K @(DIC_DA_",-1)") Q:$$ACT(EPOS)
 ..;XREF is flag to x-ref file after each entry, it is set in file 9.6
 ..I XREF N DIK S DIK=DIC D IX1^DIK
 .;do File Post Install Action
 .S %=$$ACT(FPOS)
 .;process the deleting of entries, FDEL should allow the passing of all entries
 .;to delete in array ^TMP($J,"XPDEL",DA)=""
 .I $L(FDEL),$D(^TMP($J,"XPDEL")) S %="^TMP($J,""XPDEL"")" D @FDEL
 .;complete check point
 .S %=$$XPCOM(XPDFIL)
 .K ^TMP($J,"XPDEL")
 .I $D(XPDIDVT) D UPDATE^XPDID(XPDIDCNT)
 Q
FIA ;
 ;XPFIL2=file is new^DD screen failed^data already exists^change file name^don't add data; 1=yes, 0=no
 N XPGR,XPFIL,XPFILO,XPFIL2,Z
 S XPFIL=0,XPGR=$NA(^XTMP("XPDI",XPDA))
 F  S XPFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPFIL)) Q:'XPFIL  S XPFILO=^(XPFIL,0,1),XPFIL2=^(2) D
 .;if we are doing VT graphic display, set counter
 .I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
 .;file is new, alway install DD
 .S:XPFIL2 $P(XPFILO,U)="y"
 .;DD failed screen or update DD question = no & file is not new
 .I $P(XPFIL2,U,2)!($P(XPFILO,U)'="y"&'XPFIL2) D  Q
 ..N XPD
 ..S XPD(1)=" ",XPD(2)="Data Dictionary for File #"_XPFIL_" not installed"_$S($P(XPFIL2,U,2):", failed DD screen.",1:".")
 ..D MES^XPDUTL(.XPD) S %=$$XPCOM(XPFIL)
 .;check if XPFIL has already been installed
 .Q:$P(^XPD(9.7,XPDA,4,XPFIL,0),U,2)
 .;update file name
 .I $P(XPFIL2,U,4) D
 ..N DIE,DR,DA
 ..S DR=".01////"_^XTMP("XPDI",XPDA,"FIA",XPFIL),DA=XPFIL,DIE=1
 ..D ^DIE
 .;move DD and check for errors
 .D DDIN^DIFROMS(XPFIL,"","",XPGR),DIERR("** ERROR IN DATA DICTIONARY FOR FILE # "_XPFIL_" **"):$D(DIERR)
 .S %=$$XPCOM(XPFIL)
 I $D(XPDIDVT) D UPDATE^XPDID(XPDIDTOT)
 Q
DAT ;
 N XPGR,XPFIL,XPFILO,XPFIL2,Z
 S XPFIL=0,XPGR=$NA(^XTMP("XPDI",XPDA))
 ;DO if they are sending data
 F  S XPFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPFIL)) Q:'XPFIL  S XPFILO=^(XPFIL,0,1),XPFIL2=^(2) D:$P(XPFILO,U,7)="y"
 .;DD failed screen or answer no to adding data or 'Add if new' & data already exists or file doesn't exist
 .I $P(XPFIL2,U,2)!$P(XPFIL2,U,5)!($P(XPFILO,U,8)="a"&$P(XPFIL2,U,3))!'$D(^DIC(XPFIL,0)) S %=$$XPCOM(XPFIL,1) Q
 .;check if XPFIL has already been installed or no data to input
 .Q:$P(^XPD(9.7,XPDA,4,XPFIL,0),U,3)!('$D(^XTMP("XPDI",XPDA,"DATA",XPFIL)))
 .;bring in Data and check for error
 .D DATAIN^DIFROMS(XPFIL,"","",XPGR),DIERR("** ERROR IN DATA FOR FILE # "_XPFIL_" **"):$D(DIERR)
 .S %=$$XPCOM(XPFIL,1)
 D RP^DIFROMSR("","",XPGR),DIERR("** ERROR IN POINTER RESOLUTION OF DATA **"):$D(DIERR)
 Q
 ;record error
DIERR(XPDI) N XPD
 D MSG^DIALOG("AE",.XPD) Q:'$D(XPD)
 D BMES^XPDUTL(XPDI),MES^XPDUTL(.XPD)
 Q
 ;
 ;XPDF=file #,X=input,XPDS=screen logic, XPDACT=action
DIC(XPDF,XPDX,XPDS,XPDACT) ;
 N DIC,DIERR,XPD,XPDN
 S DIC=$G(^DIC(XPDF,0,"GL"))
 D FIND^DIC(XPDF,"","","XQf",XPDX,5,"",$G(XPDS),"","XPD")
 ;one or more matches, just return first one
 I $G(XPD(0)) D:XPD(0)>1  Q XPD(1)
 .N %
 .S %(1)=$P($G(^DIC(XPDF,0)),U)_"  "_XPDX_"  is Duplicated,",%(2)=" only ien #"_XPD(1)_" was updated."
 .D MES^XPDUTL(.%)
 ;no match and action=(delete,link, or attach), don't write message if deleting
 I $G(XPDACT),XPDACT'=3 D:XPDACT'=1 BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" Lookup failed, NO Action Taken.") Q 0
 ;add a new entry
 N DLAYGO,X,Y
 S X=XPDX,DIC(0)="LX",DLAYGO=XPDF D ^DIC
 I Y<0 D BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
 Q Y
 ;code can't be used until UPDATE^DIE allows the creation of a record
 ;without required identifiers
 ;K XPD,DIERR
 ;S XPD(XPDF,"+1,",.01)=XPDX
 ;D UPDATE^DIE("","XPD","XPDN")
 ;couldn't add as new
 ;I $D(DIERR) D DIERR(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
 ;I '$G(XPDN(1)) D BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
 ;Q XPDN(1)
 ;
ACT(%) ;execute action, returns 0 to continue, 1 to quit
 ;user can count on DIC,DA,XPDFIL,OLDA,XPDNM,XPDFL,X,Y being around
 ;XPDNEW is set only for Entry Pre-install action
 Q:%="" 0
 N %1,%2,%3 S %1=$G(DIC),%2=$G(DA),%3=$G(OLDA)
 N DA,DIC,DIOVRD,OLDA,EPOS,EPRE,FPOS,FPRE,ORD,XREF,XPDQUIT
 S DIC=%1,DA=%2,OLDA=%3
 S:%'["^" %="^"_%
 ;XPDQUIT=quit this level of processing
 D @% Q $D(XPDQUIT)
 Q
 ;
XPCOM(XPDF,XPDJ) ;complete checkpoint for file XPDF
 ;XPDJ=1 only for data of fm files, it set the field to edit = 2
 N XPD,%,Z
 S %=$$NOW^XLFDT,Z=$S(XPDCP="KRN":9.715,1:9.714),XPD(Z,XPDF_","_XPDA_",",$G(XPDJ)+1)=%
 ;if Build Components, save the ORDer number
 S:Z=9.715 XPD(Z,XPDF_","_XPDA_",",2)=ORD
 D FILE^DIE("","XPD")
 Q 1
 ;
XPCK(XPDI) ;setup check points for file type XPDI
 ;XPDI="KRN"-components, ="FIA"-files
 N %,XPD,XPDF,XPDJ,XPDK
 ;XPDK=sub DD
 S XPDK=$S(XPDI="KRN":9.715,1:9.714),XPDF=0
 F %=1:1 S XPDF=$O(^XTMP("XPDI",XPDA,XPDI,XPDF)) Q:'XPDF  S (XPDJ(%),XPD(XPDK,"+"_%_","_XPDA_",",.01))=XPDF
 D:$D(XPD)>9 UPDATE^DIE("","XPD","XPDJ")
 Q

XPDIL
XPDIL ;SFISC/RSD - load Distribution Global ;12/05/97  12:26
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,44,58,68**;Jul 10, 1995
EN1 N POP,XPDA,XPDST,XPDIT,XPDT,XPDGP,XPDQUIT,XPDREQAB,XPDSKPE
 S:'$D(DT) DT=$$DT^XLFDT S:'$D(U) U="^"
 S XPDST=0
 D ST I $G(XPDQUIT) D ABRTALL^XPDI(1) G NONE
 ;XPDST= starting Build
 ;XPDT("DA",ien)=seq # to install
 ;XPDT("NM",build name)=seq #
 ;XPDT(seq #)=ien^Build name
 ;XPDT("GP",global)= 1-replace, 0-overwrite^ien
 ;XPDGP=globals from a Global Package
 ;XPDSKPE=1 don't run Environment Check^has question been asked
 S XPDIT=0,XPDSKPE="0^0"
 F  S XPDIT=$O(XPDT(XPDIT)) Q:'XPDIT  S XPDA=+XPDT(XPDIT) D  I '$D(XPDT) Q
 .;check if this Build has an Envir. Check
 .I $G(^XTMP("XPDI",XPDA,"PRE"))]"" D  I $G(XPDQUIT) D ABRTALL^XPDI(1) Q
 ..;quit if we already asked this question
 ..Q:$P(XPDSKPE,U,2)
 ..S $P(XPDSKPE,U,2)=1
 ..N DIR,DIRUT
 ..S DIR(0)="Y",DIR("A")="Want to RUN the Environment Check Routine",DIR("B")="YES"
 ..D ^DIR I $D(DIRUT) S XPDQUIT=1 Q
 ..S:'Y XPDSKPE="1^1"
 .D PKG^XPDIL1(XPDA)
 ;Global Package
 G:$D(XPDGP) ^XPDIGP
 I $D(XPDT),$D(^XPD(9.7,+XPDST,0)) W !,"Use INSTALL NAME: ",$P(^(0),U)," to install this Distribution.",!
 Q
ST ;global input
 N DIR,DIRUT,GR,IOP,X,Y,Z,%ZIS
 G:'$D(^DD(3.5,0)) OPEN
 I '$D(^%ZIS(1,"B","HFS")) W !!,"You must have a device called 'HFS' in order to load a distribution!",*7 S XPDQUIT=1 Q
 D HOME^%ZIS
 S DIR(0)="F^3:45",DIR("A")="Enter a Host File",DIR("?")="Enter a filename and/or path to input Distribution."
 D ^DIR I $D(DIRUT) S XPDQUIT=1 Q
 S %ZIS="",%ZIS("HFSNAME")=Y,%ZIS("HFSMODE")="R",IOP="HFS"
 D ^%ZIS I POP W !,"Couldn't open file or HFS device!!",*7 S XPDQUIT=1 Q
 ;don't close device if we have a global package, we need to bring in the globals now
 D GI,^%ZISC:'$D(XPDGP)!$G(XPDQUIT)
 Q
 ;
 ;if no device file, Virgin Install
OPEN ;use open command
 N IO,IOPAR,DIR,DIRUT
 S DIR(0)="F^1:79",DIR("A")="Device Name"
 S DIR("?",1)="Device Name is either the name of the HFS file or the name of the HFS Device.",DIR("?",2)="i.e.  for MSM enter  51",DIR("?")="      for DSM enter  DISK$USER::[ANONYMOUS]:KRN8.KID"
 D ^DIR I $D(DIRUT) S POP=1 Q
 S IO=Y,DIR(0)="FO^1:79",DIR("A")="Device Parameters"
 S DIR("?",1)="Device Parameter is the Open parameter this M operating system needs to",DIR("?",2)="open the Device Name.",DIR("?",3)="i.e. for MSM enter  (""B:\KRN8.KID"":""R"")",DIR("?")="     for DSM enter  READONLY"
 D ^DIR I $D(DTOUT)!$D(DUOUT) S POP=1 Q
 S IOPAR=Y
 X "O IO:"_IOPAR_":10" E  U $P W !,"Couldn't open ",IO S POP=1 Q
 S IO(0)=$P
 D GI C IO
 S IO=IO(0)
 Q
 ;
GI N X,XPDSEQ,Y,Z
 U IO R X:1,Y:1
 U IO(0) W !!,X,!,"Comment: ",Y
 S XPDST("H")=Y,XPDST("H1")=Y_"  ;Created on "_$P(X,"KIDS Distribution saved on ",2)
 ;Z is the string of Builds in this file
 U IO F X=1:1 R Z:1 S Z=$P(Z,"**KIDS**",2,99) Q:Z=""  S X(X)=Z
 U IO(0) I $G(X(1))="" W !!,"This is not a Distribution HFS File!" S XPDQUIT=1 Q
 ;global package, set XPDGP=flag;global^flag;global^...  flag=1 replace
 I $P(X(1),":")="GLOBALS" S XPDGP=$P(X(1),U,2,99),X(1)=$P(X(1),U)
 S XPDIT=0,X(1)=$P(X(1),":",2,99)
 W !!,"This Distribution contains Transport Globals for the following Package(s):"
 F X=1:1:X-1 F Z=1:1 S Y=$P(X(X),U,Z) Q:Y=""  D  Q:$G(XPDQUIT)
 .;can't install if global exist, that means Build never finish install
 .W !?5,Y S XPDIT=XPDIT+1 I '$$INST^XPDIL1(Y) S XPDQUIT=1 Q
 Q:$G(XPDQUIT)
 W !
 D:$D(XPDGP) DISP^XPDIGP
 S DIR(0)="Y",DIR("A")="Want to Continue with Load",DIR("B")="YES"
 D ^DIR I $D(DIRUT)!'Y S XPDQUIT=1 Q
 W !,"Loading Distribution...",!
 ;reset expiration date to T+7 on transport global
 S ^XTMP("XPDI",0)=$$FMADD^XLFDT(DT,7)_U_DT
 ;start reading the HFS again
 U IO R X:0,Y:0
 ;the next read must be the INSTALL NAME
 I X'="**INSTALL NAME**"!'$D(XPDT("NM",Y)) U IO(0) W !!,"ERROR in HFS file format!" S XPDQUIT=1 Q
 ;XPDSEQ is the disk sequence number
 S %=XPDT("NM",Y),GR="^XTMP(""XPDI"","_+XPDT(%)_",",XPDSEQ=1
 ;X=global ref, Y=global value. DIRUT is when user is prompted for next disk in NEXTD and they abort
 F  R X:0,Y:0 Q:X="**END**"  D  I $D(DIRUT) S XPDQUIT=1 Q
 .I X="**INSTALL NAME**" D  Q
 ..S %=+$G(XPDT("NM",Y)) I '% S DIRUT=1 Q
 ..S GR="^XTMP(""XPDI"","_+XPDT(%)_","
 .I X="**CONTINUE**" D NEXTD Q
 .S @(GR_X)=Y
 U IO(0)
 Q
 ;
NEXTD I ^%ZOSF("OS")'["MSM" U IO(0) W !!,"Error in disk, ABORTING load!!" S XPDQUIT=1 Q
 N DIR
 ;close current device
 C IO U IO(0)
 S XPDSEQ=XPDSEQ+1,DIR(0)="E",DIR("A")="Insert the next diskette, #"_XPDSEQ_", and Press the return key",DIR("?")="This distribution is continued on another diskette"
 D ^DIR Q:$D(DIRUT)
 W "  OK",!
 ;MSM specific code to open HFS
 O @(""""_IO_""":"_IOPAR) U IO
 R X:0,Y:0
 ;quit if comments are not the same on each diskette
 G:Y'=XPDST("H") NEXTQ
 ;quit if not the expected sequence, Z is for the blank line
 R Y:0,Z:0 G:Y'=("**SEQ**:"_XPDSEQ) NEXTQ
 Q
NEXTQ U IO(0) W !!,"This is NOT the correct diskette!!  The comment on this diskette is:",!,X,!!
 S XPDSEQ=XPDSEQ-1
 G NEXTD
 ;
NONE W !!,"**NOTHING LOADED**",!
 Q

XPDIL1
XPDIL1 ;SFISC/RSD - cont. of load Distribution Global ;06/09/98  14:01
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,17,39,41,44,66,68,76,85**;Jul 10, 1995
 ;
PKG(XPDA) ;check Package file
 N XPD,XPDCP,XPDNM,XPDNOQUE,XPDPKG,X,Y,%
 S XPDNM=$P(XPDT(XPDIT),U,2) W !?3,XPDNM
 ;check KIDS version against sites version, skip if package is Kernel
 I $$PKG^XPDUTL(XPDNM)'["KERNEL" D  I $D(XPDQUIT) D ABORT^XPDI(XPDA,1) Q
 .;this is part of a Kernel multi package
 .Q:$O(XPDT("NM","KERNEL"))["KERNEL"
 .S Y=$G(^XTMP("XPDI",XPDA,"VER"))
 .I $$VERSION^XPDUTL("XU")<Y W !!,"But I need Version ",+Y," of KERNEL!"  S XPDQUIT=1
 .I $$VERSION^XPDUTL("VA FILEMAN")<$P(Y,U,2) W !,"But I Need Version ",+$P(Y,U,2)," of VA FILEMAN!" S XPDQUIT=1
 ;get national package name
 S %=$O(^XTMP("XPDI",XPDA,"PKG",0)),XPDPKG(0)=$G(^(+%,0)),XPDPKG=%
 ;XPDPKG=new ien^old ien
 I XPDPKG D  S XPDPKG=+Y_U_XPDPKG
 .N D,DIC
 .S DIC="^DIC(9.4,",DIC(0)="X",X=$P(XPDPKG(0),U)
 .D ^DIC Q:Y>0
 .;if lookup fails try Prefix, C x-ref
 .S X=$P(XPDPKG(0),U,2),D="C" D IX^DIC
 ;add package to Install file
 I XPDPKG>0 S XPD(9.7,XPDA_",",1)=+XPDPKG D FILE^DIE("","XPD")
 ;XPDSKPE= does site want to run Environ. Check
 I '$G(XPDSKPE) Q:$$ENV(0)=1
 ;global package can't have pre or post inits
 Q:$D(XPDGP)
 ;create pre-init checkpoint
 S XPDCP="INI" I '$$NEWCP^XPDUTL("XPD PREINSTALL COMPLETED") D ABORT^XPDI(XPDA,1) Q
 S %=$$INRTN("INI")
 ;check for routine, use as call back
 I $L(%),'$$NEWCP^XPDUTL("XPD PREINSTALL STARTED",%) D ABORT^XPDI(XPDA,1) Q
 ;create post-init checkpoint
 S XPDCP="INIT" I '$$NEWCP^XPDUTL("XPD POSTINSTALL COMPLETED") D ABORT^XPDI(XPDA,1) Q
 S %=$$INRTN("INIT")
 I $L(%),'$$NEWCP^XPDUTL("XPD POSTINSTALL STARTED",%) D ABORT^XPDI(XPDA,1) Q
 ;create fileman and components check points and file rest of data
 D XPCK^XPDIK("FIA"),XPCK^XPDIK("KRN")
 Q
INST(XPDNM) ;add to Install file
 N DIC,DIR,DIRUT,DLAYGO,X,XPD,XPDA,XPDIE,XPDDIQ,Y
 ;check if Build was already installed
 ;XPD=0 abort install, else XPD=ien in Install file
 I $D(^XPD(9.7,"B",XPDNM)) S Y=0 D  Q:$D(XPD) XPD
 .W !,"The following Entries already exist in the INSTALL file: ",!
 .F  S Y=$O(^XPD(9.7,"B",XPDNM,Y)) Q:'Y  D
 ..Q:'$D(^XPD(9.7,Y,0))  S %=^(0)
 ..W !,$P(%,U),"   "
 ..I $P(%,U,9)<3,$D(^XTMP("XPDI",Y)) W "**Transport Global already exists**",*7 S XPD=0 Q
 ..W $$EXTERNAL^DILFD(9.7,.02,"",$P(%,U,9)),!,"was loaded on ",$$FMTE^XLFDT($P($G(^XPD(9.7,Y,1)),U))
 .;quit if transport global exist
 .Q:$D(XPD)
 .S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="NO"
 .D ^DIR I $D(DIRUT)!'Y S XPD=0 Q
 S DIC="^XPD(9.7,",DIC(0)="XL",DLAYGO=9.7,X=""""_XPDNM_""""
 ;add to Install file, must be new
 D ^DIC
 I Y<0 W !,"Can't add Build ",XPDNM," to Install File" Q 0
 ;set starting package to Y, if it is not already defined
 S:'XPDST XPDST=+Y
 ;XPDT array keeps track of all packages in this distribution
 S XPDA=+Y,XPDT(XPDIT)=XPDA_U_XPDNM,(XPDT("DA",XPDA),XPDT("NM",XPDNM))=XPDIT
 S %="XPDIE(9.7,"""_XPDA_","")",@%@(.02)=0,@%@(2)=$$NOW^XLFDT,@%@(3)=XPDST,@%@(4)=XPDIT,@%@(5)="",@%@(6)=XPDST("H1")
 D FILE^DIE("","XPDIE")
 Q XPDA
 ;
 ;XPDQUIT quit current package install, 1=kill global, 2=leave global
 ;XPDQUIT(package) quit package install, 1=kill, 2=leave
 ;XPDABORT quit the entire distribution, 1=kill, 2=leave
 ;XPDENV 0=loading distribution, 1=installing
ENV(XPDENV) ;enviroment check & version check
 ;returns 0=ok, 1=rejected kill global, 2=rejected leave global
 N %,DIR,XPDI,XPDQUIT,XPDABORT,XPDGREF
 S XPDGREF="^XTMP(""XPDI"","_XPDA_",""TEMP"")"
 ;check version number
 I XPDPKG>0 D  I $G(XPDQUIT) D ABORT^XPDI(XPDA,1) Q 1
 .N DIR,DIRUT,X,Y
 .S %=+$$VER^XPDUTL(XPDNM),Y=+$G(^DIC(9.4,+XPDPKG,"VERSION")),X=XPDNM["*"
 .;if patch, version must be the same
 .I X,%'=Y W !,"This Patch is for Version ",%,", you are running Version ",Y,! S XPDQUIT=1
 .;if package, version must be greater or equal
 .I 'X,%<Y W !,"You have a Version greater than mine!",! S XPDQUIT=1
 .Q:'$G(XPDQUIT)
 .S DIR(0)="Y",DIR("A")="Want to continue with Install",DIR("B")="NO"
 .D ^DIR I Y K XPDQUIT
 .Q
 S %=$$REQB I % S (XPDABORT,XPDREQAB)=% G ABORT
 S %=$G(^XTMP("XPDI",XPDA,"PRE")) D:%]""
 .W !,"Will first run the Environment Check Routine, ",%,!
 .D SAVE^XPDIJ(%),@("^"_%)
ABORT I $G(XPDABORT) D  Q XPDABORT
 .;if during load & leave global quit
 .I 'XPDENV,XPDABORT=2 Q
 .D ABRTALL^XPDI(XPDABORT)
 Q:'$D(XPDQUIT) 0
 I $G(XPDQUIT) D ABORT^XPDI(XPDA,XPDQUIT)
 S XPDI=""
 ;don't do if loading & leave global, need to keep XPDT(array)
 F  S XPDI=$O(XPDQUIT(XPDI)) Q:XPDI=""  D:'(XPDQUIT(XPDI)=2&'XPDENV)
 .S %=$G(XPDT("NM",XPDI)) D:% ABORT^XPDI(+XPDT(%),XPDQUIT(XPDI))
 S XPDQUIT=$S($G(XPDQUIT):XPDQUIT,'$O(XPDT(0))!'$D(^XTMP("XPDI",XPDA)):1,1:0)
 Q XPDQUIT
 ;
REQB() ;check for Required Builds
 ;returns 0=ok, 1=failed kill global, 2=failed leave global
 N XPDACT,XPDBLD,XPDI,XPDQ,XPDQUIT,XPDX,XPDX0,X,Y
 S XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDQUIT=0,XPDI=0
 Q:'$D(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"REQB")) 0
 F  S XPDI=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,"REQB",XPDI)) Q:'XPDI  S XPDX0=^(XPDI,0) D
 .S XPDQ=0,XPDX=$P(XPDX0,U),XPDACT=$P(XPDX0,U,2),X=$$PKG^XPDUTL(XPDX),Y=$$VER^XPDUTL(XPDX),Z=$$VERSION^XPDUTL(X)
 .;quit if current version is greater than what we are checking for
 .Q:Z>Y
 .I XPDX'["*" S:Z<Y XPDQ=2
 .E  S:'$$PATCH^XPDUTL(XPDX) XPDQ=1
 .;quit if patch is already on system
 .Q:'XPDQ
 .;quit if patch is sequenced prior within this build 
 .I $D(XPDT("NM",XPDX)),(XPDT("NM",XPDX)<XPDT("NM",XPDNM)) S XPDQ=0 Q
 .S XPDQUIT=$S(XPDACT>XPDQUIT:XPDACT,1:XPDQUIT)
 .;XPDACT=0 warning, =1 abort & kill global, =2 abort
 .W !!,$S(XPDACT:"**INSTALL ABORTED**",1:"**WARNING**")_$S(XPDQ=1:" Patch ",1:" Package ")_XPDX_" is Required "_$S(XPDACT:"to install",1:"for")_" this package!!",!
 Q:'XPDQUIT 0
 ;don't do if leave global and loading
 D:'(XPDQUIT=2&'XPDENV) ABORT^XPDI(XPDA,XPDQUIT)
 Q XPDQUIT
 ;
 ;return a routine that can be run
INRTN(X) N Y
 S Y=$G(^XTMP("XPDI",XPDA,X)) Q:Y="" ""
 S Y=$S(Y["^":Y,1:"^"_Y)
 Q Y

XPDIP
XPDIP ;SFISC/RSD - Install Package & Routine file ;07/20/98  13:03
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,21,28,30,41,44,51,58,83,92**;Jul 10, 1995
 Q
PKG ;
 N %,OLDA,DA,DIK,XPD,XPDFIL,XPDPKG,XPDBLDA,Y
 ;update variable for graphic display
 I $D(XPDIDVT) S XPDIDTOT=10,XPDIDMOD=1,XPDIDCNT=0 D:XPDIDVT UPDATE^XPDID(0)
 ;XPDPKG=ien of Package file, OLDA=old Package ien
 S Y=$$PKGADD,XPDPKG=$P(Y,U),OLDA=$P(Y,U,2)
 ;Package file entry not sent, XPDPKG=0
 G:'XPDPKG PKGEND
 ;update version multiple
 S DA=XPDPKG D PKGV
PKGH I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+2 D UPDATE^XPDID(XPDIDCNT)
 S %=$P(^DIC(9.4,XPDPKG,0),U,4)
 ;repoint Help Frame (0;4)
 I $L(%),'% S $P(^DIC(9.4,XPDPKG,0),U,4)=$$LK^XPDIA("^DIC(9.2)",%),DIK="^DIC(9.4," D IX1^DIK
 ;update node 20 for Patient Merge
 N REC,IEN
 S REC=0
 F  S REC=$O(^XTMP("XPDI",XPDA,"PKG",OLDA,20,REC)) Q:'REC  D
 .S IEN(9.402,"?+1,"_XPDPKG_",",.01)=$P($G(^XTMP("XPDI",XPDA,"PKG",OLDA,20,REC,0)),U,1)
 .S IEN(9.402,"?+1,"_XPDPKG_",",3)=$P($G(^XTMP("XPDI",XPDA,"PKG",OLDA,20,REC,0)),U,3)
 .S IEN(9.402,"?+1,"_XPDPKG_",",4)=$G(^XTMP("XPDI",XPDA,"PKG",OLDA,20,REC,1))
 .D UPDATE^DIE("","IEN")
 .Q
 ;
PKGEND S XPDBLDA=$$BLD(XPDBLD) Q:'XPDBLDA
 ;move Alpha/Beta testing info to Kernel site para file
 I XPDPKG S %=$G(^XPD(9.6,XPDBLDA,"ABPKG")) D
 .;Install message and they have an address, set flag in XPDIST
 .I $P(%,U)="y",$P(%,U,2)="y",$L($P(%,U,3)) S $P(XPDIST,U,2)=$P(%,U,3)
 .D EN^XQABLOAD(XPDBLDA)
 Q
PKGADD() ;check Package file, add if not there
 ;return new Package file ien^old ien
 N DA,DIK,XPD,XPDFIL,XPDO,X,Y
 S DA=+$P(^XPD(9.7,XPDA,0),U,2),XPDO=+$O(^XTMP("XPDI",XPDA,"PKG",0)),X=$P($G(^(XPDO,0)),U)
 I DA,$D(^DIC(9.4,DA,0)) Q DA_U_XPDO
 ;quit if there was no package entry sent
 Q:'XPDO "0^0"
 S XPDFIL=9.4,Y=$$DIC^XPDIK(9.4,X) Q:'Y "0^0"
 S DA=+Y
 ;if new entry in package file, bring in everything
 I $P(Y,U,3) D
 .M ^DIC(9.4,DA)=^XTMP("XPDI",XPDA,"PKG",XPDO)
 .;kill the -1 flag node first
 .K ^DIC(9.4,DA,-1)
 .;re-cross ref after adding a new package
 .S DIK="^DIC(9.4," D IX1^DIK
 ;add package to file 9.7
 S XPD(9.7,XPDA_",",1)=DA D FILE^DIE("","XPD")
 Q DA_U_XPDO
 ;
BLD(XPDBLD) ;add Build entry, XPDBLD=Build ien in ^XTMP("XPDI",XPDA,"BLD",
 N %,DA,DIK,XPDFIL,Y
 I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+4 D UPDATE^XPDID(XPDIDCNT)
 ;XPDBLD=Build ien in ^XTMP, set in XPDIJ
 S XPDFIL=9.6,Y=$$DIC^XPDIK(9.6,XPDNM) Q:'Y ""
 S DA=+Y
 ;Build entry not new, remove old data
 I '$P(Y,U,3) S %=$P(^XPD(9.6,DA,0),U,2) K ^XPD(9.6,DA) K:% ^XPD(9.6,"C",%,DA)
 M ^XPD(9.6,DA)=^XTMP("XPDI",XPDA,"BLD",XPDBLD)
 ;reset Package File Link (0;2)
 ;XPDIST = national site tracking^A/B install message address
 S $P(^XPD(9.6,DA,0),U,2)=$S(XPDPKG:XPDPKG,1:"") S:$P(^(0),U,5)="y" XPDIST=1
 ;re-index cross-ref. on fields .01 and 1
 S DIK="^XPD(9.6," F Y=.01,1 S DIK(1)=Y D EN1^DIK
 I $D(XPDIDVT) D UPDATE^XPDID(XPDIDTOT)
 Q DA
 ;
 ;update the version multiple in the package file
PKGV N %
 I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+2 D UPDATE^XPDID(XPDIDCNT)
 ;%=ien in the Version multiple_U_ien in Patch multiple in ^XTMP
 S %=$G(^XTMP("XPDI",XPDA,"PKG",OLDA,-1))
 I XPDNM'["*" D  Q
 .S %=+% Q:'$D(^XTMP("XPDI",XPDA,"PKG",OLDA,22,%,0))  S %=^(0) S:$D(^(1)) %(1)=$NA(^(1))
 .S $P(%,U,3,4)=DT_U_DUZ,%=$$PKGVER(DA,.%)
 ;update patch history multiple
 Q:'$D(^XTMP("XPDI",XPDA,"PKG",OLDA,22,+%,"PAH",+$P(%,U,2),0))  S %=$P(^(0),U) S:$D(^(1)) %(1)=$NA(^(1))
 ;check File Comment, %=patch number
 S:$P(^XPD(9.7,XPDA,2),%,2)?1" SEQ #"1.3N %=%_$P(^(2),%,2)
 S $P(%,U,2,3)=DT_U_DUZ,%=$$PKGPAT(DA,$$VER^XPDUTL(XPDNM),.%)
 Q
 ;
PKGVER(XPDPDA,XPDI) ;update version in package file, XPDPDA=Package file ien, return ien
 ;XPDI=version^date distr.^date installed^install by
 ;XPDI(1)=root of description field
 N I,X,XPD,XPDIEN,XPDJ,XPDV
 S XPDIEN=","_XPDPDA_",",XPDV=$$MDIC(9.49,XPDIEN,$P(XPDI,U)) Q:'XPDV 0
 S XPD(9.4,XPDPDA_",",13)=$P(XPDI,U),X="XPD(9.49,"""_XPDV_XPDIEN_""")"
 F I=1:1:3 S:$P(XPDI,U,I+1)]"" @X@(I)=$P(XPDI,U,I+1)
 S:$D(XPDI(1)) @X@(41)=XPDI(1)
 D FILE^DIE("","XPD")
 Q XPDV
 ;
PKGPAT(XPDPDA,XPDV,XPDI) ;update patch history
 ;INPUT: XPDPDA=Package file ien, XPDV=version
 ;XPDI=patch^date installed^install by,   returns version ien^patch ien
 N I,X,XPD,XPDP,XPDIEN
 ;quit if we can't find the version multiple, resets XPDV=ien of version
 S XPDIEN=","_XPDPDA_",",XPDV=$$MDIC(9.49,XPDIEN,XPDV) Q:'XPDV 0
 S XPDIEN=","_XPDV_XPDIEN,XPDP=$$MDIC(9.4901,XPDIEN,$P(XPDI,U)) Q:'XPDP 0
 S X="XPD(9.4901,"""_XPDP_XPDIEN_""")"
 F I=.02,.03 S:$P(XPDI,U,I*100)]"" @X@(I)=$P(XPDI,U,I*100)
 S:$D(XPDI(1)) @X@(1)=XPDI(1)
 D FILE^DIE("","XPD")
 Q XPDV_U_XPDP
 ;
 ;XPDF=subfile #,XPDIEN=ien string, X=input
MDIC(XPDF,XPDIEN,XPDX) ;
 N DIERR,XPD,XPDN
 D FIND^DIC(XPDF,XPDIEN,"","XQf",XPDX,5,"","","","XPD")
 ;one or more matches, just return first one
 I $G(XPD(0)) D:XPD(0)>1  Q XPD(1)
 .N %
 .S %(1)=$P(^DD(XPDF,.01,0),U)_"  "_XPDX_"  is Duplicated,",%(2)=" only ien #"_XPD(1)_" was updated."
 .D MES^XPDUTL(.%)
 ;add a new entry
 S XPDN(XPDF,"+1"_XPDIEN,.01)=XPDX K XPD
 D UPDATE^DIE("","XPDN","XPD")
 I '$G(XPD(1)) D BMES^XPDUTL(" "_$P(^DD(XPDF,.01,0),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
 Q XPD(1)
 ;
RTN ;move rtns to install file
 N XPD,XPDC,XPDCR,XPDI,XPDJ,XPDK,XPDL,XPDM,XPDR,XPDRH,X
 K ^XPD(9.7,XPDA,"RTN"),^TMP($J)
 S (XPDC,XPDCR,XPDRH)=0,XPDJ=""
 ;get all routines that were loaded, XPDM=action
 ;actions are 0=load, 1=delete, 2=skip
 F  S XPDJ=$O(^XTMP("XPDI",XPDA,"RTN",XPDJ)) Q:XPDJ=""  S XPDM=^(XPDJ) D:'XPDM
 .;XPD, build array to update ROUTINE multiple in INSTALL file
 .S XPDC=XPDC+1,^TMP($J,"XPDL",XPDC)=XPDC,^TMP($J,"XPD",9.704,"+"_XPDC_","_XPDA_",",.01)=XPDJ
 .;XPDR, build array to update ROUTINE file
 .S:'$D(^DIC(9.8,"B",XPDJ)) XPDCR=XPDCR+1,^TMP($J,"XPDR",9.8,"?+"_XPDCR_",",.01)=XPDJ,^(1)="R"
 ;if we are doing VT graphic display, update only 40%
 I $D(XPDIDVT) S XPDIDCNT=XPDIDTOT*.4 D UPDATE^XPDID(XPDIDCNT)
 F XPDK="DIKZ","DIEZ","DIPZ" D
 .S XPDI=0
 .;loop thru list of compile template routines
 .;XTMP("XPDI",XPDA,"DIKZ",ien,routine name)
 .F  S XPDI=$O(^XTMP("XPDI",XPDA,XPDK,XPDI)),XPDJ="" Q:'XPDI  D
 ..I 'XPDRH D BMES^XPDUTL(" The following Routines were created during this install:") S XPDRH=1
 ..F  S XPDJ=$O(^XTMP("XPDI",XPDA,XPDK,XPDI,XPDJ)) Q:XPDJ=""  D:'$D(^XTMP("XPDI",XPDA,"RTN",XPDJ))
 ...S XPDC=XPDC+1,^TMP($J,"XPDL",XPDC)=XPDC,^TMP($J,"XPD",9.704,"+"_XPDC_","_XPDA_",",.01)=XPDJ
 ...D MES^XPDUTL("     "_XPDJ)
 ;update routine multiple in Install file with routines and
 ;compile template routines
 I $D(^TMP($J,"XPD"))>9 D
 .D UPDATE^DIE("","^TMP($J,""XPD"")","^TMP($J,""XPDL"")")
 .;if we are doing VT graphic display, update only 40%
 .I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+(XPDIDTOT*.40) D UPDATE^XPDID(XPDIDCNT)
 ;update Routine file
 D:$D(^TMP($J,"XPDR"))>9 UPDATE^DIE("","^TMP($J,""XPDR"")")
 ;if we are doing VT graphic display, update 100%
 I $D(XPDIDVT) D UPDATE^XPDID(XPDIDTOT)
 Q

XPDIPM
XPDIPM ;SFISC/RSD - Load a Packman Message ;12/05/97  12:27
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21,28,68**;Jul 05, 1995
 Q:'$D(^XMB(3.9,+$G(XMZ),0))
 N X,XPD,Y S XPD=0
 F  S XPD=$O(^XMB(3.9,XMZ,2,XPD)) Q:+XPD'=XPD  S X=^(XPD,0) I $E(X,1,11)="$TXT $KIDS " Q
 S Y=$P(X,"$KIDS ",2)
EN I 'XPD!'$L(Y) W !!,"Couldn't find a KIDS package!!",*7 Q
 N DIR,DIRUT,GR,XPDA,XPDST,XPDIT,XPDT,XPDNM,XPDQUIT,XPDREQAB
 S XPDST("H1")=$P(^XMB(3.9,XMZ,0),U),XPDST=0,XPDIT=1
 W !?5,Y S XPDA=$$INST^XPDIL1(Y) G:'XPDA NONE^XPDIL
 W !
 S DIR(0)="Y",DIR("A")="Want to Continue with Load",DIR("B")="YES"
 D ^DIR I 'Y!$D(DIRUT) D ABRTALL^XPDI(1) G NONE^XPDIL
 W !,"Loading Distribution...",!
 S ^XTMP("XPDI",0)=$$FMADD^XLFDT(DT,7)_U_DT
 D GI I $G(XPDQUIT) D ABRTALL^XPDI(1) G NONE^XPDIL
 D PKG^XPDIL1(XPDA)
 Q
GI D NXT Q:$G(XPDQUIT)
 I X'="**INSTALL NAME**"!'$D(XPDT("NM",Y)) S XPDQUIT=1 Q
 S GR="^XTMP(""XPDI"","_XPDA_","
 F  D NXT Q:X=""!$D(XPDQUIT)  D
 .S @(GR_X)=Y
 Q
NXT S (X,Y)="",XPD=$O(^XMB(3.9,XMZ,2,XPD)) G:+XPD'=XPD ERR S X=^(XPD,0)
 I $E(X,1,5)="$END " S X="" Q
 S XPD=$O(^XMB(3.9,XMZ,2,XPD)) G:+XPD'=XPD ERR
 S Y=^XMB(3.9,XMZ,2,XPD,0)
 Q
XMP2 ;called from XMP2
 N X,XPD,Y
 S XPD=XCN,X=$G(^XMB(3.9,XMZ,2,XPD,0)),Y=$P(X,"$KID ",2)
 D EN
 S XMOUT=1
 Q
ERR W !!,"Error in Packman Message, ABORTING load!!"
 S (X,Y)="",XPDQUIT=1
 Q

XPDIQ
XPDIQ ;SFISC/RSD - Install Questions ;08/17/98  13:33
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21,28,58,61,95**;Jul 10, 1995
 Q
DIR(XPFR,XPFP) ;XPFR=prefix, XPFP=file no._# or Mail Group ien
 ;XPFP is for XPF  or XPM questions
 N DIR,DR,XPDI,XPDJ,X,Y,Z
 S XPFP=$G(XPFP),XPDI=$S(XPFP:XPFR_XPFP,1:XPFR)
 D QUES(XPDI)
 ;ask questions
 S X=XPFR
 F  S X=$O(^XTMP("XPDI",XPDA,"QUES",X)),Z="" Q:X=""!($P(X,XPFR)]"")  D  I $D(DIRUT) S XPDQUIT=1 Q
 .S XPDJ=$S('XPFP:X,1:XPDI_$P(X,XPFR,2))
 .F  S Z=$O(^XTMP("XPDI",XPDA,"QUES",X,Z)) Q:Z=""  M DIR(Z)=^(Z)
 .;if there was a previous answer, reset DIR("B") to external or internal answer
 .S:$L($G(XPDQUES(XPDJ))) DIR("B")=$G(XPDQUES(XPDJ,"B"),XPDQUES(XPDJ)) D  Q:'$D(Y)
 ..N FLAG,X,Z K Y
 ..;this is the M CODE node that was set to DIR("M") in prev for loop
 ..;FLAG is used by KIDS questions
 ..I $D(DIR("M")) S %=DIR("M"),FLAG="" K DIR("M") X %
 ..Q:'$D(DIR)
 ..;'|' is used to mark variable in prompt, reset prompt with value of variable
 ..S:$G(DIR("A"))["|" DIR("A")=$P(DIR("A"),"|")_@$P(DIR("A"),"|",2)_$P(DIR("A"),"|",3)
 ..K:$G(DIR("B"))="" DIR("B")
 ..D ^DIR
 .S %=$P(DIR(0),U)
 .;read was optional and didn't timeout and user didn't enter anything
 .I %["O",'$D(DTOUT),$S(%["P":Y=-1,1:Y="") K DIRUT Q
 .;quit if the user up-arrowed out
 .Q:$D(DIRUT)
 .;if pointer, reset Y & Y(0)
 .I %["P" S Y(0)=$S(%["Z":$P(Y(0),U),1:$P(Y,U,2)),Y=+Y
 .;if Y(0) is not defined, but Y is
 .S:$D(Y)#2&'($D(Y(0))#2) Y(0)=Y
 .S XPDQUES(XPDJ)=Y,XPDQUES(XPDJ,"A")=$G(DIR("A")),XPDQUES(XPDJ,"B")=$G(Y(0))
 .K DIR
 K XPDJ S XPDI=XPFR
 ;code to save XPDQUES to INSTALL ANSWERS in file 9.7, loop thru the answers starting with the from value, XPFR
 F Y=1:1 S XPDI=$O(XPDQUES(XPDI)) Q:XPDI=""!($P(XPDI,XPFR)]"")  D
 .S X="XPDJ(9.701,""?+"_Y_","_XPDA_","")",@X@(.01)=XPDI,@X@(1)=$G(XPDQUES(XPDI,"A")),@X@(2)=$G(XPDQUES(XPDI,"B")),@X@(3)=XPDQUES(XPDI)
 K XPDI D:$D(XPDJ)>9 UPDATE^DIE("","XPDJ","XPDI")
 Q
 ;
QUES(X) ;build XPDQUES array, X="INI","INIT","XPF","XPM"
 ;move INSTALL ANSWERS from file 9.7 to XPDQUES
 ;XPDQUES(X)=internal answer, XPDQUES(X,"A")=prompt, XPDQUES(X,"B")=external answer.
 N Y,Z K XPDQUES S Z=X
 F  S Z=$O(^XPD(9.7,XPDA,"QUES","B",Z)) Q:Z=""!($P(Z,X)]"")  S Y=$O(^(Z,0)) D
 .Q:'$D(^XPD(9.7,XPDA,"QUES",Y,0))
 .S XPDQUES(Z)=$G(^(1)),XPDQUES(Z,"A")=$G(^("A")),XPDQUES(Z,"B")=$G(^("B")) ; ^(1) refer to prev line ^XPD(9.7,XPDA,"QUES","B",Z)
 Q
 ;codes for install process questions
 ;XPDFIL=file #, XPDFILN=file name^global ref^partial DD
 ;XPDFILO=update DD^security codes^^^resolve pt^list template^data with file^add,merge,overwrite,replace^user override data update
 ;XPDSCR=screen to determine DD update
 ;XPDANS is define in QUES^XPDI
XPF1 ;write over existing file
 N XPDI
 W !!?3,XPDFIL,?13,$P(XPDFILN,U),$P("  (Partial Definition)",U,$P(XPDFILN,U,3)),$P("  (including data)",U,$P(XPDFILO,U,7)="y")
 ;file doesn't exists
 I XPDANS K DIR Q
 I $L($G(XPDSCR)) S XPDI=1 D  Q:'XPDI
 .X XPDSCR S XPDI=$T Q:XPDI
 .W !,"Data Dictionary FAILED the screening logic, file will NOT be installed!"
 .S $P(XPDANS,U,2)="1" K DIR
 S FLAG=$P($G(^DIC(XPDFIL,0)),U)
 ;file exist and has the same name
 I $P(FLAG,$P(XPDFILN,U))="" W !,"Note:  You already have the '",$P(XPDFILN,U),"' File." K DIR Q
 W *7,!,"*BUT YOU ALREADY HAVE '",FLAG,"' AS FILE #",XPDFIL,"!"
 S $P(XPDANS,U,4)=1
 Q
XPF2 ;data
 ;if they don't want to overwrite a file with a different name then set the DIRUT flag and ABORT, this will stop the rest of the questions and abort the install
 I $G(XPDQUES("XPF"_XPFP_1))=0 S DIRUT=1 K DIR Q
 ;if Data doesn't exists or DD failed screen or data wasn't sent, don't ask question
 I '$P(XPDANS,U,3)!$P(XPDANS,U,2)!($P(XPDFILO,U,7)'="y") K DIR Q
 S %=$F("amor",$P(XPDFILO,U,8))-1
 ;if this is add and file is not new
 I %=1 W !,"Data will NOT be added." K DIR Q
 ;check if dev. doesn't want to ask user
 I $P(XPDFILO,U,9)'="y" W !,"I will ",$P("^MERGE^OVERWRITE^REPLACE",U,%)," your data with mine." K DIR Q
 S FLAG=$P("^merged with^to overwrite^to replace",U,%)
 Q
XPM1 ;mail groups
 S FLAG=XPDANS
 Q:'$D(XPDDIQ("XPM1"))
 I $D(XPDDIQ("XPM1"))#2 S XPDQUES("XPM1")=XPDDIQ("XPM1") K DIR Q
 S:$D(XPDDIQ("XPM1","A")) DIR("A")=XPDDIQ("XPM1","A")
 S:$D(XPDDIQ("XPM1","B")) DIR("B")=XPDDIQ("XPM1","B")
 Q
 ;XPDDIQ(name)=internal value, (name,"A")=prompt, (name,"B")=external
XPO1 ;rebuild menu trees
 Q:'$D(XPDDIQ("XPO1"))
 I $D(XPDDIQ("XPO1"))#2 S XPDQUES("XPO1")=XPDDIQ("XPO1") K DIR Q
 S:$D(XPDDIQ("XPO1","A")) DIR("A")=XPDDIQ("XPO1","A")
 S:$D(XPDDIQ("XPO1","B")) DIR("B")=XPDDIQ("XPO1","B")
 Q
XPZ1 ;disable options
 Q:'$D(XPDDIQ("XPZ1"))
 I $D(XPDDIQ("XPZ1"))#2 S XPDQUES("XPZ1")=XPDDIQ("XPZ1") K DIR Q
 S:$D(XPDDIQ("XPZ1","A")) DIR("A")=XPDDIQ("XPZ1","A")
 S:$D(XPDDIQ("XPZ1","B")) DIR("B")=XPDDIQ("XPZ1","B")
 Q
XPZ2 ;move routines
 N Y
 ;if they are not in production UCI don't ask
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") K DIR Q
 ;if they are not running MSM don't ask
 I ^%ZOSF("OS")'["MSM" K DIR Q
 Q:'$D(XPDDIQ("XPZ2"))
 I $D(XPDDIQ("XPZ2"))#2 S XPDQUES("XPZ2")=XPDDIQ("XPZ2") K DIR Q
 S:$D(XPDDIQ("XPZ2","A")) DIR("A")=XPDDIQ("XPZ2","A")
 S:$D(XPDDIQ("XPZ2","B")) DIR("B")=XPDDIQ("XPZ2","B")
 Q

XPDIR
XPDIR ;SFISC/RSD - Install Restart; 3 May 96 15:22 ;01/29/97  10:43
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**30,58**;Jul 10, 1995
EN ;restart install
 N DIR,DIRUT,POP,XPD,XPDA,XPDD,XPDIJ,XPDDIQ,XPDNM,XPDNOQUE,XPDPKG,XPDST,XPDSET,XPDT,XPDQUIT,XPDQUES,Y,ZTSK,%
 S %="I $P(^(0),U,9)#3,$D(^XPD(9.7,""ASP"",Y,1,Y)),$D(^XTMP(""XPDI"",Y))",XPDST=$$LOOK^XPDI1(%)
 Q:'XPDST!$D(XPDQUIT)
 S ZTSK=$P(^XPD(9.7,XPDST,0),U,6) D:ZTSK
 .;check if task exist or is queued
 .D ISQED^%ZTLOAD
 .;task is queued to run
 .Q:ZTSK(0)
 .;task doesn't exist, k ZTSK so it can be re-scheduled
 .I ZTSK(0)="" K ZTSK Q
 .D STAT^%ZTLOAD
 .;task is not define
 .I 'ZTSK(1) K ZTSK Q
 .;task is queued to run
 .Q:ZTSK(1)=1
 .;task is running, set quit flag
 .I ZTSK(1)=2 S XPDQUIT=1 W !,"Install is currently running, cannot re-install!" Q
 .;task finished or was interrupted, kill it so it can be rescheduled
 .D KILL^%ZTLOAD K ZTSK Q
 ;abort if there is nothing to install or they '^'
 G:'$O(XPDT(0))!$D(XPDQUIT) ABORT
 ;clean out old task, so they can reinstall
 I '$D(ZTSK) D
 .N XPD
 .S XPD(9.7,XPDST_",",5)=""  D FILE^DIE("","XPD")
 I $G(ZTSK) W !!,"This install is already queued as task #",ZTSK,!,"Please use the Taskman Menu if you want to reschedule." G ABORT
 ;kill XPDT array so that while in XPDI and ABORT is called, nothing is deleted
 S XPDIJ=0,XPDA=XPDST K XPDT
 ;restore environment check variables
 I $D(^XTMP("XPDI",XPDA,"ENVVAR")) D
 .S:$D(^XTMP("XPDI",XPDA,"ENVVAR","XPDNOQUE")) XPDNOQUE=^("XPDNOQUE")
 .I $D(^XTMP("XPDI",XPDA,"ENVVAR","XPDDIQ")) M XPDDIQ=^("XPDDIQ")
 G DEV^XPDI
 ;
ABORT W !!,"**RESTART ABORTED**",!
 L -XPD(9.7,XPDST)
 Q

XPDIST
XPDIST ;SFISC/RSD - site tracking; 6 Mar 95 12:34 ;06/11/97  14:39
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**66**;Jul 10, 1995
 ;Returns ""=failed, XMZ=sent
 ;D0=ien in file 9.7, Y=address(optional)
EN(D0,Y) ;send message
 N %,DIFROM,XPD,XPD0,XPD1,XPDV,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,X,Z
 ;send to Server on FORUM
 Q:$G(Y)="" ""
 S:Y XMY("S.A5CSTS@FORUM.VA.GOV")=""
 S:$L($P(Y,U,2)) XMY($P(Y,U,2))=""
 I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q ""
 S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1))
 I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q ""
 S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U))
 I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q ""
 K ^TMP($J)
 ;Quit if not VA production primary domain
 I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q ""
 X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
 S:%'["," Y=$P(Y,",")
 I Y'=% D BMES^XPDUTL(" Not a production UCI") Q ""
 ;Z=start, Y=completion date/time, X=run time
 S Z=$P(XPD1,U),Y=$P(XPD1,U,3),X=$$FMDIFF^XLFDT(Y,Z,3),Z=$$FMTE^XLFDT(Z),Y=$$FMTE^XLFDT(Y)
 ;Message for server
 S ^TMP($J,1,0)="PACKAGE INSTALL"
 S ^TMP($J,2,0)="SITE: "_$G(^XMB("NETNAME"))
 S ^TMP($J,3,0)="PACKAGE: "_XPD
 S ^TMP($J,4,0)="VERSION: "_XPDV
 S ^TMP($J,5,0)="Start time: "_Z
 S ^TMP($J,6,0)="Completion time: "_Y
 S ^TMP($J,7,0)="Run time: "_X
 S ^TMP($J,8,0)="DATE: "_DT
 S ^TMP($J,9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
 S ^TMP($J,10,0)="Install Name: "_$P(XPD0,U)
 S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="^TMP($J,",XMSUB=$P(XPD0,U)_" INSTALLATION"
 D ^XMD
 K ^TMP($J)
 Q "#"_$G(XMZ)

XPDIU
XPDIU ;SFISC/RSD - UNload/Convert/Rollup Distribution Global ;10/16/98  14:17
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,41,44,51,58,101**;Jul 10, 1995
EN1 ;unload
 N %,DA,DIK,DIR,DIRUT,X,XPD,XPDST,XPDT,XPDQ,XPDQUIT,Y
 ;remove dangling transport globals
 S DA=0 F  S DA=$O(^XTMP("XPDI",DA)) Q:'DA  I '$D(^XPD(9.7,DA)) K ^XTMP("XPDI",DA)
 ;must be Loaded or Queued and be the starting package
 S (DA,XPDST)=$$LOOK^XPDI1("I $P(^(0),U,9)<2,$D(^XPD(9.7,""ASP"",Y,1,Y))") Q:'DA
 S XPDQ=^XPD(9.7,DA,0),DIR(0)="Y",DIR("A")="Want to continue with the Unload of this Distribution",DIR("B")="NO"
 S DIR("?")="YES will delete the Transport Global and the entry in the Install file for these Packages."
 I $P(XPDQ,U,9)=1,$P(XPDQ,U,6) W !,"This Distribution is Queued for Install with task number ",$P(XPDQ,U,6),!,"Don't forget to delete Taskman Task."
 D ^DIR I 'Y!$D(DIRUT) D QUIT^XPDI1(XPDST) Q
 S XPD=0,DIK="^XPD(9.7,"
 ;need to kill the XTMP("XPDI") and the entry in the install file
 F  S XPD=$O(XPDT(XPD)) Q:'XPD  S DA=+XPDT(XPD) D ^DIK K ^XTMP("XPDI",DA)
 ;check if Out-Of-Order setname is defined, kill it
 I $D(^XTMP("XQOO",$P(XPDQ,U))) K ^($P(XPDQ,U))
 D QUIT^XPDI1(XPDST)
 Q
EN2 ;convert
 N %,DA,DIK,DIR,DIRUT,X,XPD,XPDBLD,XPDI,XPDNM,XPDPKG,XPDPMT,XPDST,XPDT,XPDQUIT,Y
 S XPDI=$$LOOK^XPDI1("I '$P(^(0),U,9),$D(^XPD(9.7,""ASP"",Y,1,Y))") Q:'XPDI
 K XPDT("DA"),XPDT("NM")
 ;make sure transport globals exist
 S XPDT=0 F  S XPDT=$O(XPDT(XPDT)) Q:'XPDT  D
 .S Y=+XPDT(XPDT) Q:$D(^XTMP("XPDI",Y))
 .W !,$P(XPDT(XPDT),U,2),"   ** Transport Global doesn't exist **",$C(7)
 .K XPDT(XPDT) S XPDQUIT=1
 I $D(XPDT)'>9!$D(XPDQUIT) D QUIT^XPDI1(XPDI) Q
 S DIR(0)="Y",DIR("A")="Want to make the Transport Globals Permanet",DIR("B")="NO"
 S DIR("?",1)="YES will leave the Transport Global so you can transport this TG in mulitple Distributions."
 S DIR("?")="NO will remove the Transport Global after you transport this TG in the next Distribution."
 D ^DIR I $D(DIRUT) D QUIT^XPDI1(XPDI) Q
 S XPDPMT=Y,DIR("A")="Want to continue with the Conversion of the Package(s)",DIR("B")="NO"
 S DIR("?",1)="YES will convert the Packages to globals that can be transported.",DIR("?")="An entry will be added to the Build file and the entry in the Install file will be deleted."
 D ^DIR I 'Y!$D(DIRUT) Q
 S XPDT=0,DIK="^XPD(9.7,"
 F  S XPDT=$O(XPDT(XPDT)) Q:'XPDT  D  Q:$D(XPDQUIT)
 .;kill Install file entry
 .S XPDA=+XPDT(XPDT),XPDNM=$P(XPDT(XPDT),U,2),XPDBLD=$O(^XTMP("XPDI",XPDA,"BLD",0)),XPDPKG=+$O(^XTMP("XPDI",XPDA,"PKG",0))
 .;resolve the Package file link
 .D:XPDPKG
 ..N DIC,X,Y
 ..S DIC="^DIC(9.4,",DIC(0)="X",X=$P(^XTMP("XPDI",XPDA,"PKG",XPDPKG,0),U)
 ..D ^DIC I Y<0 S XPDPKG=0 Q
 ..S XPDPKG=+Y
 .S DA=$$BLD^XPDIP(XPDBLD) D:DA
 ..K ^XTMP("XPDT",DA)
 ..S ^XTMP("XPDT",DA)=XPDPMT M ^XTMP("XPDT",DA)=^XTMP("XPDI",XPDA)
 .I 'DA W !,XPDNM,"   ** Couldn't add to Build file **" S XPDQUIT=1 Q
 .;kill Install file entry
 .S DA=XPDA D ^DIK
 .K ^XTMP("XPDI",XPDA)
 ;set expiration date to 1 year if global should be permanent, else 30
 S ^XTMP("XPDT",0)=$$FMADD^XLFDT(DT,$S(XPDPMT:365,1:30))_U_DT
 D QUIT^XPDI1(XPDI)
 W !,"  ** DONE **",!
 Q

XPDKEY
XPDKEY ;SFISC/RWF,RSD - Tools to work on KEYS ;9/21/95  13:47
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**5**;Jul 10, 1995
 Q
 ;XPDOLD=current Key name,  XPDNEW=new Key name
 ;return 1 for success, 0 for failure
RENAME(XPDOLD,XPDNEW) ;EF. Rename a Security Key
 Q:$D(XPDOLD)+$D(XPDNEW)'=2 0
 N DA,DIERR,DIK,XPD,XPDKEY,XPDI
 S XPDKEY=$O(^DIC(19.1,"B",XPDOLD,0)) Q:XPDKEY'>0 0
 S XPD(19.1,XPDKEY_",",.01)=XPDNEW D UPDATE^DIE("","XPD")
 I $D(DIERR) Q 0
 S XPDI=0,DA=XPDKEY,DIK="^VA(200,XPDI,51,",DIK(1)=.01
 F  S XPDI=$O(^VA(200,"AB",XPDKEY,XPDI)) Q:'XPDI  S DA(1)=XPDI D EN1^DIK
 D LOCKS(XPDOLD,XPDNEW)
 Q 1
 ;
LOCKS(XPDOLD,XPDNEW) ;check file 19 for LOCKS and REVERSE/LOCK fields
 N XPD,XPDI,X,Y
 Q:$D(XPDOLD)+$D(XPDNEW)'=2
 S XPDI=0
 F  S XPDI=$O(^DIC(19,XPDI)) Q:'XPDI  S X=$G(^(XPDI,0)),Y=$G(^(3)) D:$L(X)
 .K XPD
 .S:$P(X,"^",6)=XPDOLD XPD(19,XPDI_",",3)=XPDNEW
 .S:$P(Y,"^")=XPDOLD XPD(19,XPDI_",",3.01)=XPDNEW
 .D:$D(XPD) UPDATE^DIE("","XPD")
 Q
 ;
DEL(XPDA) ; Delete a key.
 N DA,DIK,XPD,XPDKEY,XPDI
 Q:'$D(^DIC(19.1,+$G(XPDA),0))  S XPDKEY=$P(^(0),"^")
 S XPDI=0,DA=XPDA
 F  S XPDI=$O(^VA(200,"AB",XPDA,XPDI)) Q:'XPDI  D
 . S DA(1)=XPDI,DIK="^VA(200,XPDI,51," D ^DIK
 . S DIK="^VA(200,XPDI,52," D ^DIK
 K DA S DA=XPDA,DIK="^DIC(19.1,"
 D ^DIK,LOCKS(XPDKEY,"@")
 Q
 ;
LKUP(X) ;Lookup a in the KEY file.
 Q:'$L(X) ""
 I X?1N.NP Q $P($G(^DIC(19.1,X,0)),"^")
 Q $O(^DIC(19.1,"B",X,0))

XPDKRN
XPDKRN ;SFISC/RSD - Kernel Install program; 7 Apr 95 10:29 [ 01/11/96  2:27 PM ]
V ;;8.0;KERNEL;**1005**;FEB 09, 1999
V ;;8.0;KERNEL;;Jul 10, 1995
EN N X,Y
 W !!,"KIDS "_$P($T(V),";",3),!
 D DT^DICRW:'$D(DT),INIT:($O(^DOPT("XPD","B"),-1)'=5)
 ;I '$G(DUZ) W !,"DUZ must be defined as an active user!!" Q
 I '$G(DUZ) S DUZ=1,DUZ(2)="@"
 D  Q:Y<0  G @X
 .N DIC
 .S DIC="^DOPT(""XPD"",",DIC(0)="AEQZ"
 .D ^DIC Q:Y<0
 .S X=$P(Y(0),U,2,99)
 Q
 ;
INIT N DIK,I,X
 K ^DOPT("XPD")
 S ^DOPT("XPD",0)="KIDS OPTION^1N^",DIK="^DOPT(""XPD"","
 F I=1:1 S X=$E($T(OPT+I),4,99) Q:X=""  S ^DOPT("XPD",I,0)=X
 D IXALL^DIK
 Q
OPT ;
 ;;LOAD A DISTRIBUTION^EN1^XPDIL
 ;;INSTALL PACKAGE(S)^EN^XPDI
 ;;RESTART INSTALL OF PACKAGE(S)^EN^XPDIR
 ;;UNLOAD A DISTRIBUTION^EN1^XPDIU
 ;;VERIFY CHECKSUMS IN TRANSPORT GLOBAL^EN1^XPDDCS

XPDMENU
XPDMENU ;SFISC/RWF,RSD - Manage Menu items ;02/22/96  08:46
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21**;Jul 10, 1995
 Q
 ;
 ;MENU=option to add to,  OPT=option to add to MENU, SYN=synonym
 ;ORD=display order
ADD(MENU,OPT,SYN,ORD) ;EF. Add options to a menu
 Q:$G(MENU)']"" 0 Q:$G(OPT)']"" 0
 N X,XPD1,XPD2,XPD3,DIC,DA,D0,DR,DLAYGO
 S XPD1=$$LKOPT(MENU) Q:XPD1'>0 0
 ;quit if type is not menu
 I $$TYPE(XPD1)'["M" Q 0
 S XPD2=$$LKOPT(OPT) Q:XPD2'>0 0
 ;if OPTion is not in menu, add it
 I '$D(^DIC(19,XPD1,10,"B",XPD2)) D
 .S X=XPD2,(D0,DA(1))=XPD1,DIC(0)="MLF",DIC("P")=$P(^DD(19,10,0),"^",2),DLAYGO=19,DIC="^DIC(19,"_XPD1_",10,"
 .D FILE^DICN
 S XPD3=$O(^DIC(19,XPD1,10,"B",XPD2,0))
 I XPD3>0 S DR="" S:$G(SYN)]"" DR="2///"_SYN_";" S:$G(ORD)]"" DR=DR_"3///"_ORD I DR]"" S DIE="^DIC(19,"_XPD1_",10,",DA=XPD3,DA(1)=XPD1 D ^DIE
 Q XPD3>0
 ;
LKOPT(X) ;EF.  To lookup on "B"
 Q $O(^DIC(19,"B",X,0))
 ;
TYPE(X) ;EF. Return option type, Pass IFN.
 Q:X'>0 "" Q $P($G(^DIC(19,X,0)),"^",4)
 ;
 ;MENU=option to delete from,  OPT=option to delete
DELETE(MENU,OPT) ;EF. Delete item from menu.
 Q:$G(MENU)']"" 0 Q:$G(OPT)']"" 0
 N XPD1,XPD2,DIK,DA,X
 S XPD1=$$LKOPT(MENU) Q:XPD1'>0 0 I $$TYPE(XPD1)'="M" Q 0
 S XPD2=$$LKOPT(OPT) Q:XPD2'>0 0
 S DA=$O(^DIC(19,XPD1,10,"B",XPD2,0)) Q:DA'>0 0
 S DA(1)=XPD1,DIK="^DIC(19,XPD1,10," D ^DIK
 Q 1
 ;
 ;OPT=option to set out of order,  TXT=message
OUT(OPT,TXT) ;Set option out of order
 Q:$G(OPT)']""
 N XPD,XPD1
 S XPD1=$$LKOPT(OPT) Q:XPD1'>0
 S XPD(19,XPD1_",",2)=$G(TXT) D FILE^DIE("","XPD")
 Q
 ;
 ;OLD=old name, NEW=new name
RENAME(OLD,NEW) ;Rename option
 Q:$G(OLD)']""  Q:$G(NEW)']""
 N XPD,XPD1
 S XPD1=$$LKOPT(OLD) Q:XPD1'>0
 S XPD(19,XPD1_",",.01)=NEW D FILE^DIE("","XPD")
 Q

XPDNTEG
XPDNTEG ;ISC/XTSUMBLD KERNEL - Package checksum checker ;JUL 10, 1995@09:24:52
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;;JUL 10, 1995
 ;;7.2;JUL 10, 1995@09:24:52
 S XT4="I 1",X=$T(+3) W !!,"Checksum routine created on ",$P(X,";",4)," by KERNEL V",$P(X,";",3),!
CONT F XT1=1:1 S XT2=$T(ROU+XT1) Q:XT2=""  S X=$P(XT2," ",1),XT3=$P(XT2,";",3) X XT4 I $T W !,X X ^%ZOSF("TEST") S:'$T XT3=0 X:XT3 ^%ZOSF("RSUM") W ?10,$S('XT3:"Routine not in UCI",XT3'=Y:"Calculated "_$C(7)_Y_", off by "_(Y-XT3),1:"ok")
 ;
 K %1,%2,%3,X,Y,XT1,XT2,XT3,XT4 Q
ONE S XT4="I $D(^UTILITY($J,X))",X=$T(+3) W !!,"Checksum routine created on ",$P(X,";",4)," by KERNEL V",$P(X,";",3),!
 W !,"Check a subset of routines:" K ^UTILITY($J) X ^%ZOSF("RSEL")
 W ! G CONT
ROU ;;
XLFDT ;;2542000
XLFDT1 ;;1537932
XPDCOM ;;2213245
XPDCOMG ;;8382178
XPDCPU ;;6564663
XPDDCS ;;3052685
XPDDI ;;7059710
XPDDP ;;11284516
XPDE ;;12998234
XPDET ;;3688528
XPDGCDEL ;;2818026
XPDH ;;2594827
XPDI ;;13967703
XPDIA ;;6914717
XPDIA1 ;;4945908
XPDID ;;2414499
XPDIGP ;;6457099
XPDIJ ;;14331384
XPDIK ;;10629573
XPDIL ;;10081002
XPDIL1 ;;6175748
XPDIN001 ;;8911225
XPDIN002 ;;12264533
XPDIN003 ;;8357402
XPDIN004 ;;8061968
XPDIN005 ;;10022912
XPDIN006 ;;9558156
XPDIN007 ;;8115613
XPDIN008 ;;9140117
XPDIN009 ;;3471847
XPDIN00A ;;9058285
XPDIN00B ;;7976280
XPDIN00C ;;6944309
XPDIN00D ;;6861764
XPDIN00E ;;3155079
XPDIN00F ;;921211
XPDIN00G ;;6183213
XPDIN00H ;;5691661
XPDIN00I ;;6023617
XPDIN00J ;;5774284
XPDIN00K ;;5839595
XPDIN00L ;;8152412
XPDIN00M ;;7714345
XPDIN00N ;;6424156
XPDIN00O ;;5629359
XPDIN00P ;;6001373
XPDIN00Q ;;5487755
XPDIN00R ;;5781258
XPDIN00S ;;5743958
XPDIN00T ;;3809597
XPDINIT ;;10210170
XPDINIT1 ;;4893932
XPDINIT2 ;;5232647
XPDINIT3 ;;16808120
XPDINIT4 ;;3357819
XPDINIT5 ;;460403
XPDIP ;;7105579
XPDIPM ;;1889333
XPDIQ ;;6649770
XPDIR ;;2209857
XPDIST ;;2343711
XPDIU ;;5987197
XPDKEY ;;1267561
XPDKRN ;;818184
XPDMENU ;;1676349
XPDPINIT ;;223513
XPDR ;;12193352
XPDRSUM ;;1331254
XPDT ;;13681675
XPDTA ;;5532717
XPDTA1 ;;4346384
XPDTC ;;8576205
XPDTP ;;2581228
XPDUTL ;;2317236
XPDV ;;6960037
XQDATE ;;1632193
XQH ;;8451889
XQOO ;;19407312
XQOO1 ;;11594948
XQOO2 ;;6850745
XQOO3 ;;8090117

XPDPINIT
XPDPINIT ;SFISC/RSD - Load a Packman Message using KIDS ; 6 Feb 95 14:48
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**5**;Jul 10, 1995
 I '$D(^XMB(3.9,+$G(XMZ),0)) W !!,"NO message to install!!" Q
 I $T(^XPDIPM)="" W !!,"KIDS doesn't exist!!" Q
 G ^XPDIPM

XPDR
XPDR ;SFISC/RSD - Routine File Edit ;09/17/96  10:05
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**1,2,44**;Jul 10, 1995
 Q
UPDT ;update routine file
 N DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,X,X1,Y,Y1,% W !
 W ! S DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X",DIR("A")="Routine Namespace",DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace"
 ;XPDN(0=excluded names or 1=include names, namespace)=""
 F  D ^DIR Q:$D(DIRUT)  S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))=""
 Q:'$D(XPDN)!$D(DTOUT)!$D(DUOUT)
 W !!,"NAMESPACE  INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
 S (X,Y)="",(X1,Y1)=1
 F  D  W !?11,X,?35,Y Q:'X1&'Y1
 .S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
 K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
 Q:'Y!$D(DIRUT)  W !
 S DIR(0)="Y",DIR("A")="Want me to clean up the Routine File before updating",DIR("?")="YES means you want to go throught the Routine file and delete any routine name that no longer exists on the system."
 D ^DIR
 Q:$D(DIRUT)  D WAIT^DICD,DELRTN:Y
 ;loop thru include list XPDN(1,XPDI)
 S XPDI="" F  S XPDI=$O(XPDN(1,XPDI)) Q:XPDI=""  D
 .S XPDJ=XPDI D:$D(^$R(XPDJ))  F  S XPDJ=$O(^$R(XPDJ)) Q:XPDJ=""!($P(XPDJ,XPDI)]"")  D
 ..;if name XPDJ is in the exclude list, XPDN(0,XPDJ) or in Routine file, quit
 ..Q:$D(XPDN(0,XPDJ))!$O(^DIC(9.8,"B",XPDJ,0))
 ..;check if XPDJ is refered in the namespace by checking the subscript
 ..;before XPDJ, if sub exist and $P(XPDJ,sub)="" then it is part of the
 ..;namespace, quit
 ..S %=$O(XPDN(0,XPDJ),-1) I $L(%),$P(XPDJ,%)="" Q
 ..N XPD S XPD(9.8,"+1,",.01)=XPDJ,XPD(9.8,"+1,",1)="R"
 ..D ADD^DICA("","XPD")
 W "    ...Done.",!
 Q
VER ;verify Routine file
 N DIR,DIRUT,X,Y
 W !,"I will delete all entries in the Routine File in which",!,"the Routine no longer exist on this system!",!
 S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
 Q:'Y!$D(DIRUT)  D DELRTN
 W "    ...Done.",!
 Q
DELRTN ;delete routine file entries
 N DA,DIK,Y
 S DIK="^DIC(9.8,",DA=0
 F  S DA=$O(^DIC(9.8,DA)) Q:'DA  S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK
 Q
PURGE ;purge file
 N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
 S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)"
 D ^DIR Q:$D(DIRUT)
 S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7
 K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1
 D ^DIR Q:$D(DIRUT)  S XPDN=Y
 K DIR
 S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL"
 F  D ^DIR Q:$D(DIRUT)  S XPD(X)="" Q:X="ALL"  K DIR("B") S DIR("A")="Another Package Name"
 Q:'$D(XPD)
 ;if they want all, make sure all is the only one
 I $D(XPD("ALL")) K XPD S XPD("ALL")=""
 ;XPDF(1) is defined if doing both files, do purge twice
 K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1))
 I '$D(^TMP($J)) W !!,"No match found" Q
 K XPD,DIR
 S DIR(0)="E",$P(XPDUL,"-",IOM)=""
 ;if ALL, reset XPDF to next file and Do, then reset back to 9.6
 D  I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D  S XPDF=9.6
 .S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1
 .W @IOF D HDR
 .;loop thru ^TMP($J,file,package) & show list, quit if user "^"
 .F  S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS)  D  Q:'Y
 ..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):"  (duplicates)",1:""),! Q:$Y<(IOSL-4)
 ..D ^DIR Q:'Y
 ..S XPDPG=XPDPG+1 W @IOF D HDR
 S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO"
 W !! D ^DIR
 I $D(DIRUT)!'Y W !!,"Nothing Purged" Q
 ;loop thru and delete
 D  I $D(XPDF(1)) S XPDF=XPDF(1) D
 .S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS)
 .F  S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS)  D
 ..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA  D ^DIK
 Q
 ;
PURGE1(XPDF) ;XPDF=file #
 N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
 W "."
 ;if All, loop thru B x-ref
 I $D(XPD("ALL")) D
 .S XPDI=""
 .F  S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI=""  D
 ..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X)
 ..W "."
 E  S XPDI="" F  S XPDI=$O(XPD(XPDI)) Q:XPDI=""  D
 .D PURGE2(XPDI)
 .W "."
 ;loop thru each package, XPDP=package name
 S XPDP="" F  S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP=""  D
 .S XPDV="",XPDL=XPDN
 .;the last is the most recent, XPDN = number to retain, XPDV=version
 .;XPDS=type (T/V/Z)
 .F  S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL  F  S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL  D
 ..S Y="" F  S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL  D
 ...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q
 ...S Z="" F  S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL  K ^(Z) S XPDL=XPDL-1
 Q
 ;
PURGE2(XPDX) ;XPDX=package name
 ;XPDFL=1 this is not a patch, quit when we find a patch during loop
 S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*"
 ;loop and find matches
 D  F  S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0))  D
 .S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y
 .Q:'$D(^XPD(XPDF,Y,0))  S Z=^(0),Y=XPDS_"^"_Y
 .;can't delete Installs that status isn't 'Install Completed'
 .I XPDF=9.7 Q:$P(Z,U,9)<3
 .S XPDV=$$VER^XPDUTL(XPDS)
 .;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
 .I XPDS["*" D  Q
 ..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 ..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 ..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 ..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2))
 .;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
 .I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 .;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
 .I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 .I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
 Q
PURGEH ;executable help from DIR call at PURGE+8
 W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or"
 W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0  will purge version 8.0Tx and 8.0Vx",!,"      XU*8.0 will purge all patches for 8.0",!
 N DIR,X,Y
 S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y"
 D ^DIR Q:'Y!$D(DIRUT)
 D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1))
 Q
 ;
DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
 ;returns Y=DA^dup DA^dup DA...
 N Y S Y=""
 F  S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1  S Y=Y_"^"_Z1
 Q Y
 ;
PURGEH1(DIC) ;
 W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
 S DIC(0)="QE",X="??" D ^DIC
 Q
 ;
HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
 I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions")
 E  W "Don't retain any versions"
 W ?70,"PAGE ",XPDPG,!,XPDUL,!
 Q

XPDRSUM
XPDRSUM ;SFISC/RWF - Routine checksum utilities ; 13 Oct 95 11:21
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**10**;Jul 10, 1995
 Q
SUMA(GLO) ;This tag builds the old RSUM value
 ;Call with a reference to a global that has the routine
 N Y,%,%1,%2,%3 S Y=0
 F %=1,3:1 S %1=$G(@GLO@(%,0)),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
 Q Y
SUMB(GLO) ;This tag builds the new RSUM value
 ;Call with a reference to a global that has the routine
 N Y,%,%1,%2,%3 S Y=0
 F %=1,3:1 S %1=$G(@GLO@(%,0)),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*(%2+%)+Y
 Q Y
SUMC(GLO) ;This tag builds the new checksum for global
 ;Call with a reference to a global
 N Y,%,%1,%2,%3,%4,%5
 S Y=0,%=$NA(@GLO),%1=$E(%,1,$L(%)-1),%2=$L(%1)
 F %5=1:1 S GLO=$Q(@GLO) Q:GLO=""!($E(GLO,1,%2)'=%1)  S %3=@GLO F %4=1:1:$L(%3) S Y=$A(%3,%4)*(%4+%5)+Y
 Q Y

XPDT
XPDT ;SFISC/RSD - Transport a package; 15 Apr 96 10:15 ;06/09/98  09:27
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**2,10,28,41,44,51,58,66,68,85**;Jul 10, 1995
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,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
 .F  S X=$O(^XPD(9.6,XPDA,10,X)) Q:'X  S Z=$P($G(^(X,0)),U) 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)
 .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
 S DIR(0)="SAO^HF:Host File;PM:PackMan",DIR("A")="Transport through (HF)Host File or (PM)PackMan: ",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
 I $G(XPDTP),XPDT>1 W !!,"You cannot send multiple Builds through PackMan." G 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:"")
 .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:45",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
 ;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)
 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),!
 ;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
 ;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 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
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) ;XPDA=Build ien, XPDNM=Build name
 N Y
 S XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDNM,XPDT("DA",XPDA)=XPDT
 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
 ;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
 .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
 .O @(""""_IO_""":"_IOPAR) U IO
 .W $$SUM("Continuation #"_XPDSEQ_" of "_XPDHD),!,$$SUM(XPDH),!,$$SUM("**SEQ**:"_XPDSEQ),!!
 .S XPDSIZA=XPDSIZA+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

XPDTA
XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;01/28/97  08:48
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**15,44,58**;Jul 10, 1995
 Q
 ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
OPT ;options
 ;if link, kill everything and just process the menu items
 I XPDFL=2 D  G OPTT
 .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'%  K:%'=10 ^(%)
 ;resolve Package (0;12), remove Creator (0;5)
 S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
 ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
 S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200)
 ;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
 ;resolve RPC (RPC;0), must be type Broker
 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D
 .;kill  "B"=name x-ref, it will be re-indexed when installed
 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
 .;loop thru RPCs and resolve (RPC;1)
 .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'%  S %1=$G(^(%,0)) D
 ..S %2=$$PT("^XWB(8994)",+%1)
 ..;if can't resolve then delete
 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q
 ..;save the RPC name
 ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
 .Q
OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu,
 ;extended action, limited, window suite
 I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q
 ;kill  "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
 K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
 ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
 S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
 .S %2=$$PT("^DIC(19)",+%1)
 .;items must be sent by themselves, check "B" x-ref
 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q
 .;if I couldn't resolve this option, then kill it
 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
 Q
PRO ;protocols
 ;if link, kill everything and just process the menu items
 I XPDFL=2 D  G PROT
 ;resolve Package (0;12), remove Creator (0;5)
 S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
 ;kill under Menus (10), "B"=name, "C"=synonyms
 S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% I $D(^(10,0)) K ^("B"),^("C")
 ;resolve File Link (5;1), its a variable pointer
 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2)
 I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1
 ;resolve HL7 fields, node 770
 S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D  S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
 .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2))
 .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11))
 .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7))
 .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9))
 .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10))
PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
 S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
 .;%2=.01 of Menu(protocol)
 .S %2=$$PT("^ORD(101)",+%1)
 .;Menu must also be sent by itself, check "B" x-ref
 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q
 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
 ;quit if no Access multiple
 Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0))  K ^("B")
 ;loop thru Access and resolve (3;1), kill if it doesn't resolve
 S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'%  S %1=$G(^(%,0)) D
 .;%2=.01 of Menu(protocol)
 .S %2=$$PT("^DIC(19.1)",+%1)
 .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q
 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
 Q
RTNE ;routine entry build action
 N %,X,XPD
 ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
 ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
 ;Build file
 S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1)
 Q:X=""  S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=%
 K ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
 Q
RTNF ;routine file build action
 N X,Y,% S Y=0
 ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
 ;deleted at site, move name field to RTN node
 F  S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y  S %=^(Y,-1),X=^(0) D
 .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
 ;kill everything
 K ^XTMP("XPDT",XPDA,"KRN",9.8)
 Q
PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value
 Q:'DA ""
 I $D(@GR@(+DA,0))#2 Q $P(^(0),U)
 Q ""
 ;
LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file
 ;XPD = 0-load, 1-delete, 2-skip, returns checksum
 ;quit if routine is already saved
 Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3)
 N DIF,XCNP,%N
 S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0
 X ^%ZOSF("LOAD")
 ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
 S %N=$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))),^XTMP("XPDT",XPDA,"RTN",X)=XPD_U_"B"_%N
 ;update count node
 S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
 Q "B"_%N

XPDTA1
XPDTA1 ;SFISC/RSD - Build Actions for Kernel Files Cont. ;06/09/98  09:22
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**44,68,85**;Jul 10, 1995
 Q
 ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root
 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
 Q
HELP ;help frames #9.2
 ;remove Author (0;4), kill Editor (4;0) and under Object (10) kill "B" x-ref
 S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,0),U,4)="",%=0 K ^(4),^(10,"B")
 ;loop thru Objects (10) and resolve (10;1), kill if it doesn't resolve
 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)) Q:'%  S %1=$G(^(%,0)) D
 .S %2=$$PT^XPDTA("^MAG",+%1)
 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%,0),U)=%2 Q
 .K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)
 ;kill under Related Frame (2) "B" x-ref
 K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,"B") S %=0
 ;loop thru Related Frame (2) and resolve Related Frame (2;2)
 ;kill if it doesn't resolve
 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)) Q:'%  S %1=$P($G(^(%,0)),U,2) D
 .S %2=$$PT^XPDTA("^DIC(9.2)",%1)
 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%,0),U,2)=%2 Q
 .K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)
 Q
BUL ;bulletines #3.6
KEY ;security keys entry action #19
 ;kill Mailgroups (2)
 K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,2)
 Q
MAILG ;MAIL GROUP #3.8
 ;remove REFERENCE COUNT (0;4), LAST REFERENCE (0;5), COORDINATOR (0;7)
 S %=^XTMP("XPDT",XPDA,"KRN",3.8,DA,0),$P(%,U,4,5)="^",$P(%,U,7)="",^(0)=%
 ;remove ORGANIZER (3;1)
 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",3.8,DA,3)),U) S:% $P(^(3),U)=""
 ;kill MEMBER (1;0), AUTHORIZE SENDER (4;0), DISTRIBUTION LIST (7;0)
 K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,1),^(4),^(7)
 ;kill MEMBER GROUP "B" x-ref 
 K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,"B") S %=0
 ;loop thru MEMBER GROUP and resolve (5;0)
 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)) Q:'%  S %1=$P($G(^(%,0)),U) D
 .S %2=$$PT^XPDTA("^XMB(3.8)",%1)
 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%,0),U)=%2 Q
 .K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)
 Q
HLAP ;HL7 application parameter #771
 S %=^XTMP("XPDT",XPDA,"KRN",771,DA,0)
 ;resolve MAIL GROUP (0;4)
 S:$P(%,U,4) $P(%,U,4)=$$PT^XPDTA("^XMB(3.8)",$P(%,U,4))
 ;resolve COUNTRY CODE (0;7)
 S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^HL(779.004)",$P(%,U,7))
 S ^XTMP("XPDT",XPDA,"KRN",771,DA,0)=%
 ;resolve HL7 SEGMENT (SEG;0)
 ;kill "B"=name x-ref, it will be re-indexed when installed
 I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG")) K ^("SEG","B") D
 .;loop thru SEGs and resolve (SEG;1)
 .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%)) Q:'%  S %1=$G(^(%,0)) D
 ..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
 ..;if can't resolve then delete
 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%) Q
 ..;save the SEG name
 ..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%,0),U)=%2
 .Q
 ;resolve HL7 MESSAGE (MSG;0)
 I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG")) K ^("MSG","B") D
 .;loop thru MSGs and resolve (MSG;1)
 .S %=0 F  S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%)) Q:'%  S %1=$G(^(%,0)) D
 ..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
 ..;if can't resolve then delete
 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%) Q
 ..;save the MSG name
 ..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%,0),U)=%2
 .Q
 Q
HLLLP ;HL7 lower level protocol #869.2
 S %=$P(^XTMP("XPDT",XPDA,"KRN",869.2,DA,0),U,2)
 ;resolve LLP TYPE (0;2)
 S:% %=$$PT^XPDTA("^HLCS(869.1)",%),$P(^XTMP("XPDT",XPDA,"KRN",869.2,DA,0),U,2)=%
 ;resolve MAIL GROUP (100;1)
 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",869.2,DA,100)),U)
 S:% %=$$PT^XPDTA("^XMB(3.8)",%),$P(^XTMP("XPDT",XPDA,"KRN",869.2,DA,100),U)=%
 ;remove HLLP DEVICE (200;1)
 I $D(^XTMP("XPDT",XPDA,"KRN",869.2,DA,200)) S $P(^(200),U)=""
 ;remove X3.28 DEVICE (300;1)
 I $D(^XTMP("XPDT",XPDA,"KRN",869.2,DA,300)) S $P(^(300),U)=""
 ;remove Startup Node (400;6)
 I $D(^XTMP("XPDT",XPDA,"KRN",869.2,DA,400)) S $P(^(400),U,6)=""
 Q
HLLL ;HL7 logical link #870
 S %=^XTMP("XPDT",XPDA,"KRN",870,DA,0)
 ;resolve INSTITUTION (0;2)
 S:$P(%,U,2) $P(%,U,2)=$$PT^XPDTA("^DIC(4)",$P(%,U,2))
 ;resolve LLP PARAMETERS (0;3)
 S:$P(%,U,3) $P(%,U,3)=$$PT^XPDTA("^HLCS(869.2)",$P(%,U,3))
 ;resolve DOMAIN (0;7)
 S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^DIC(4.2)",$P(%,U,7))
 ;remove all data except (0;1-3,7,21)
 S %=$P(%,U,1,3)_"^^^^"_$P(%,U,7)_"^^^^^^^^^^^^^^"_$P(%,U,21)
 S ^XTMP("XPDT",XPDA,"KRN",870,DA,0)=%
 K ^XTMP("XPDT",XPDA,"KRN",870,DA,1),^(2),^("IN QUEUE BACK POINTER"),^("IN QUEUE FRONT POINTER")
 K ^XTMP("XPDT",XPDA,"KRN",870,DA,"OUT QUEUE BACK POINTER"),^("OUT QUEUE FRONT POINTER")
 Q

XPDTC
XPDTC ;SFISC/RSD - Transport calls ;08/17/98  13:34
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**10,15,21,39,41,44,58,83,92,95**;Jul 10, 1995
 Q
 ;^XTMP("XPDT",XPDA,data type,file #,
 ;XPDA=ien of File 9.6, XPDNM=.01 field
DD ;build DD
 N FILE,FGR,FNAM,Z2,Z3,Z4
 S FILE=0,FGR="^XTMP(""XPDT"",XPDA)",FNAM=$NA(^XPD(9.6,XPDA,4,"APDD"))
 F  S FILE=$O(^XPD(9.6,XPDA,4,FILE)) Q:'FILE  D
 .S Z2=$G(^XPD(9.6,XPDA,4,FILE,222)),Z3=$G(^(223)),Z4=$G(^(224))
 .Q:'$$DATA^XPDV(FILE,Z2)
 .D FIA^DIFROMSU(FILE,"",FNAM,FGR,Z2,Z3,Z4,XPDVER),DIERR:$D(DIERR)
 Q:'$D(^XTMP("XPDT",XPDA,"FIA"))
 ;send DD and Data
 D DDOUT^DIFROMS("","","",FGR),DIERR:$D(DIERR),DATAOUT^DIFROMS("","","",FGR),DIERR:$D(DIERR)
 Q
 ;XPDERR is checked in XPDT and will abort transport
DIERR ;record error
 D MSG^DIALOG("EW",.XPD) S XPDERR=1
 Q
KRN ;build Kernel Files
 ;XPDFILE=file #, XPDOLDA=ien in Build file
 N %,%1,%2,DA,EACT,FACT,FGR,XPDFILE,XPDFL,XPDOLDA,XPDI
 F XPDFILE=1:1 S Y0=$P($T(FILES+XPDFILE^XPDE),";;",2,99) Q:Y0=""  S XPDI(+Y0)=Y0
 ;XPDI(XPDFILE)=file;order;x-ref;fact;eact;fpre;epre;fpos;epos;fdel
 S XPDFILE=0
 F  S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)) Q:'XPDFILE  S XPDI=$G(XPDI(XPDFILE)),FACT=$P(XPDI,";",4),EACT=$P(XPDI,";",5) D  Q:$D(XPDERR)  D:FACT]"" ACT(FACT)
 .;need to add code to check if File and data is already being sent in the File
 .;mult. If it is, don't bother sending it again.  DTL(XPDFILE)
 .S XPDOLDA=0,FGR=$$FILE^XPDV(XPDFILE) I FGR="" S XPDERR=1 Q
 .K ^TMP($J,"XPD")
 .F  S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA  S Y0=$G(^(XPDOLDA,0)) D
 ..;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
 ..S XPDFL=$P(Y0,U,3)
 ..;If deleting at site get an unused DA
 ..I XPDFL=1 S DA=$O(@FGR@(" "),-1)+1 F DA=DA:1 Q:'$D(^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA))
 ..;$P(Y0,U,2) is file # for this template, reset Y0 before getting DA
 ..E  S:$P(Y0,U,2) $P(Y0,U)=$P(Y0,"    FILE #") S DA=$$ENTRY^XPDV(Y0)
 ..I 'DA S XPDERR=1 Q
 ..;(-1)=action ^ ien in Build file
 ..S ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,-1)=+XPDFL_"^"_XPDOLDA
 ..;action 2 - verify children, 4 - verify parent
 ..I XPDFL=2!(XPDFL=4),'$$MENU^XPDV(XPDFILE,DA,XPDFL) S XPDERR=1 Q
 ..;if action is 1,4 or 5 then only send .01 field and set checksum to ""
 ..I XPDFL=1!(XPDFL>3) S ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,0)=$P(Y0,U),$P(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA),U,4)="" Q
 ..M ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA)=@FGR@(DA)
 ..;execute entry build action
 ..D:EACT]"" ACT(EACT)
 .;quit if no entries were saved
 .Q:'$O(^XTMP("XPDT",XPDA,"KRN",XPDFILE,0))
 .;XPDI=XPDI(XPDFILE), build x-ref of order to install
 .S %=$P(^DIC(XPDFILE,0),U),^XTMP("XPDT",XPDA,"ORD",+$P(XPDI,";",2),XPDFILE)=XPDI,^(XPDFILE,0)=%
 .Q
 Q
QUES ;build from Install Questions multiple
 N I,J,X,%
 S X=""
 ;the "B" x-ref will give me the order of the questions
 F  S X=$O(^XPD(9.6,XPDA,"QUES","B",X)) Q:X=""  S I=$$QUES^XPDV(X) S:'I XPDERR=1 D:I
 .S J=0 F  S J=$O(^XPD(9.6,XPDA,"QUES",I,J)) Q:J=""  D
 ..;tranform J to DIR subscripts
 ..I $L(J)=1!(J="QQ") S ^XTMP("XPDT",XPDA,"QUES",X,$TR(J,"1ABQ","0AB?"))=^(J) Q  ;^(J) ref to ^XPD(9.6,XPDA,"QUES",I,J)
 ..;set the word processing fields into DIR("?",#) structure
 ..F %=1:1 Q:'$D(^XPD(9.6,XPDA,"QUES",I,J,%,0))  S ^XTMP("XPDT",XPDA,"QUES",X,$TR(J,"AQ10","A?"),%)=^(0)
 ;send the File questions
 F I=1:2 S X=$P($T(QUESTION+I),";;",2,99) Q:X=""  S Y=$P($T(QUESTION+I+1),";;",2) D
 .S ^XTMP("XPDT",XPDA,"QUES",$P(X,";"),0)=$P(X,";",2),^("A")=$P(X,";",3),^("B")=$P(X,";",4),^("??")=$P(X,";",5) S:Y]"" ^("M")=Y
 Q
INT ;build pre,post, & enviroment init routines
 N %,I,X
 F I="PRE","INI","INIT" I $G(^XPD(9.6,XPDA,I))]"" S X=^(I) D
 .S ^XTMP("XPDT",XPDA,I)=X,X=$P(X,U,$L(X,U)) Q:$D(^("RTN",X))
 .I '$$RTN^XPDV(X) W !,"Routine ",X," **NOT FOUND**" S XPDERR=1 Q
 .S %=$$LOAD^XPDTA(X,"0^")
 Q
BLD ;build Build file, Package file and Order Parameter file
 N %,DIC,X,XPD,XPDI,XPDV,Y
 ;save version of kernel and fm
 S ^XTMP("XPDT",XPDA,"VER")=$$VERSION^XPDUTL("XU")_U_$$VERSION^XPDUTL("VA FILEMAN")
 M ^XTMP("XPDT",XPDA,"BLD",XPDA)=^XPD(9.6,XPDA)
 ;check national package file pointer
 S XPDI=$P(^XPD(9.6,XPDA,0),U,2)
 I XPDI="" W !,"No Package File Link" Q
 S $P(^XTMP("XPDT",XPDA,"BLD",XPDA,0),U,2)=$$PT^XPDTA("^DIC(9.4)",XPDI)
 ;quit if no pointer to package file
 I '$D(^DIC(9.4,XPDI)) W !,"Package File Link is corrupted" S XPDERR=1 Q
 ;update version multiple in package file,XPD=version^date distributed
 S XPD=$$VER^XPDUTL(XPDNM)_U_$P(^XTMP("XPDT",XPDA,"BLD",XPDA,0),U,4)
 ;XPD(1)=root of description field
 S:$D(^XTMP("XPDT",XPDA,"BLD",XPDA,1)) XPD(1)=$NA(^(1))
 S ^XTMP("XPDT",XPDA,"PKG",XPDI,0)=^DIC(9.4,XPDI,0),^XTMP("XPDT",XPDA,"PKG",XPDI,22,0)="^"_$P(^DD(9.4,22,0),U,2)_"^1^1"
 ;add node 20 to XTMP for Patient Merge
 M ^XTMP("XPDT",XPDA,"PKG",XPDI,20)=^DIC(9.4,XPDI,20)
 ;XPDNM'["*" is a version release
 I XPDNM'["*" D
 .S XPDV=$$PKGVER^XPDIP(XPDI,.XPD)
 .;Merge is used to set single nodes and merge multiples
 .F %=1,5,7,20,"DEV","VERSION" M ^XTMP("XPDT",XPDA,"PKG",XPDI,%)=^DIC(9.4,XPDI,%)
 .;XPDV=ien of Version Multiple
 .I $D(^DIC(9.4,XPDI,22,XPDV))'>9 W !!,"**Version multiple in Package file wasn't updated**",!! S XPDERR=1 Q
 .M ^XTMP("XPDT",XPDA,"PKG",XPDI,22,1)=^DIC(9.4,XPDI,22,XPDV)
 ;this is a patch, %=version number, $P(XPD,U)=patch number
 E  D
 .S %=$P(XPD,U),$P(XPD,U)=$P(XPDNM,"*",3),XPDV=$$PKGPAT^XPDIP(XPDI,%,.XPD)
 .S ^XTMP("XPDT",XPDA,"PKG",XPDI,22,1,0)=^DIC(9.4,XPDI,22,+XPDV,0)
 .I $D(^DIC(9.4,XPDI,22,+XPDV,"PAH",+$P(XPDV,U,2)))'>9 W !!,"**Patch multiple in Package file wasn't updated**",!! S XPDERR=1 Q
 .M ^XTMP("XPDT",XPDA,"PKG",XPDI,22,1,"PAH",1)=^DIC(9.4,XPDI,22,+XPDV,"PAH",+$P(XPDV,U,2))
 ;M ^XTMP("XPDT",XPDA,"PKG",XPDI)=^DIC(9.4,XPDI)
 ;save the version ien^patch ien on -1 node
 S ^XTMP("XPDT",XPDA,"PKG",XPDI,-1)="1^1"
 ;resolve Primary Help Frame (0;4)
 S %=+$P(^DIC(9.4,XPDI,0),U,4) S:% $P(^XTMP("XPDT",XPDA,"PKG",XPDI,0),U,4)=$$PT^XPDTA("^DIC(9.2)",%)
 Q
 ;
ACT(%) ;execute action
 ;user can count on DA,XPDFILE,XPDFL,XPDNM,XPDOLDA being around
 ;DA=ien in ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA)
 ;XPDOLDA=ien in ^XPD(9.6,XPDA,"KRN",XPDIFLE,"NM",XPDOLDA)
 N EACT,FACT,FGR,K0,Y0
 S:%'["^" %="^"_%
 D @% Q
 ;
 ;the following are the default questions for the INSTALL QUESTIONS
 ;in file 9.6, the format is:
 ;;field .01;field 1;field 2;field 4;field 7
 ;;field 10
QUESTION ;package install questions
 ;;XPF1;Y;Shall I write over your |FLAG| File;YES;^D REP^XPDH
 ;;D XPF1^XPDIQ
 ;;XPF2;Y;Want my data |FLAG| yours;YES;^D DTA^XPDH
 ;;D XPF2^XPDIQ
 ;;XPM1;PO^VA(200,:EM;Enter the Coordinator for Mail Group '|FLAG|';;^D MG^XPDH
 ;;D XPM1^XPDIQ
 ;;XPO1;Y;Want KIDS to Rebuild Menu Trees Upon Completion of Install;YES;^D MENU^XPDH
 ;;D XPO1^XPDIQ
 ;;XPZ1;Y;Want to DISABLE Scheduled Options, Menu Options, and Protocols;YES;^D OPT^XPDH
 ;;D XPZ1^XPDIQ
 ;;XPZ2;Y;Want to MOVE routines to other CPUs;NO;^D RTN^XPDH
 ;;D XPZ2^XPDIQ

XPDTP
XPDTP ;SFISC/RSD - Transport using a Packman Message ;08/23/96  11:01
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21,40**;Jul 05, 1995
 N DIFROM,DIR,DIRUT,DWPK,DWLW,DIC,I,J,XCN,XCNP,XMDISPI,XMDUN,XMDUZ,XMKEY,XMSCR,XMSUB,XMY,XMZ,X,Y,%
 S DIFROM=1,DIR(0)="F^3:65",DIR("A")="Subject",DIR("?")="Enter the subject for this Packman Message"
 D ^DIR Q:$D(DIRUT)
 S XMSUB=Y,XMDUZ=+DUZ
 K ^TMP("XMP",$J)
 W !,"Please enter description of Packman Message",!
 S DWPK=1,DWLW=75,DIC="^TMP(""XMP"",$J," D EN^DIWE
 D KIDS^XMP
 S XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)="$KID "_XPDNM,XCNP=XCNP+1
 ;for multiple packages, this would be a for loop
 D GS K ^XTMP("XPDT",XPDA)
 S $P(^XMB(3.9,XMZ,2,0),U,3,4)=XCNP_U_XCNP
 ;secure message & then send
 D ^XMASEC Q:$D(DTOUT)!$D(DUOUT)  D EN3^XMD
 K ^TMP("XMP",$J)
 Q
GS 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
 S ^XMB(3.9,XMZ,2,XCNP,0)="**INSTALL NAME**",XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)=XPDNM,XCNP=XCNP+1
 F  S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK)  S ^XMB(3.9,XMZ,2,XCNP,0)=$P(GR,GCK,2),XCNP=XCNP+1,^XMB(3.9,XMZ,2,XCNP,0)=@GR,XCNP=XCNP+1
 S ^XMB(3.9,XMZ,2,XCNP,0)="$END KID "_XPDNM
 Q

XPDUTL
XPDUTL ;SFISC/RSD - KIDS utilities ;06/23/98  10:21
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**21,28,39,81**;Jul 10, 1995
 Q
VERSION(X) ;Get current version from Package file, X=package name or
 ;package namespace
 N I
 S I=$O(^DIC(9.4,"C",X,0)) S:I'>0 I=$O(^DIC(9.4,"B",X,0))
 Q $P($G(^DIC(9.4,+I,"VERSION")),"^")
 ;
VER(X) ;returns version number from Build file, X=build name
 Q:X["*" $P(X,"*",2)
 Q $P(X," ",$L(X," "))
 ;
PKG(X) ;returns package name from Build file, X=build name
 Q $S(X["*":$P(X,"*"),1:$P(X," ",1,$L(X," ")-1))
 ;
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnn
 Q:X'?1.4U1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.3N 0
 N %,I,J
 S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0
 S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
 ;check if patch is just a number
 Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
 S %=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
 Q (X=+%)
 ;
NEWCP(XPD,XPDC,XPDP) ;create new check point, returns 0=error or ien
 ;XPD=name, XPDC=call back, XPDP=parameters
 Q:$G(XPD)="" 0
 N %,XPDI,XPDJ,XPDF,XPDY
 ;XPDCP="INI"=Pre-init, "INIT"=Post-init
 S XPDI=$S(XPDCP="INIT":9.716,1:9.713)
 S %=$$FIND1^DIC(XPDI,","_XPDA_",","X",XPD) Q:% %
 S XPDF="+1,"_XPDA_",",XPDJ(XPDI,XPDF,.01)=XPD
 S:$D(XPDC) XPDJ(XPDI,XPDF,2)=XPDC
 S:$D(XPDP) XPDJ(XPDI,XPDF,3)=XPDP
 D UPDATE^DIE("","XPDJ","XPDY")
 Q $G(XPDY(1))
 ;
UPCP(XPD,XPDP) ;update check point, returns 0=error or ien
 ;XPD=name, XPDP=parameters
 N XPDI,XPDJ,XPDF,XPDY
 ;XPDCP="INI"=Pre-init, "INIT"=Post-init
 S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
 Q:'XPDY 0
 S XPDF=XPDY_","_XPDA_","
 S:$D(XPDP) XPDJ(XPDI,XPDF,3)=XPDP
 D FILE^DIE("","XPDJ")
 Q XPDY
 ;
COMCP(XPD) ;complete check point, returns 0=error or date/time
 ;XPD=name
 N XPDD,XPDI,XPDJ,XPDY
 S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
 Q:'XPDY 0
 S XPDD=$$NOW^XLFDT,XPDJ(XPDI,XPDY_","_XPDA_",",1)=XPDD
 D FILE^DIE("","XPDJ")
 Q XPDD
 ;
VERCP(XPD) ;verify check point, returns 1=completed, 0=not
 ;-1=doesn't exist
 ;XPD=name
 N XPDI,XPDY
 S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
 Q:'XPDY -1
 Q ''$$GET1^DIQ(XPDI,XPDY_","_XPDA_",",1,"I")
 ;
PARCP(XPD,XPDF) ;returns parameters of check point
 ;XPD=name, XPDF="PRE"
 N XPDI,XPDY
 I $G(XPDF)="PRE" N XPDCP S XPDCP="INI"
 S XPDI=$S(XPDCP="INIT":9.716,1:9.713),XPDY=$$DICCP($G(XPD))
 Q:'XPDY 0
 Q $$GET1^DIQ(XPDI,XPDY_","_XPDA_",",3,"I")
 ;
CURCP(XPDF) ;returns current check point
 ;XPDF flag - 0=externel, 1=internal
 Q $S($G(XPDF):XPDCHECK,1:XPDCHECK(0))
 ;
WP(X) ;X=global ref
 N %
 Q:'$D(@X)
 F %=1:1 Q:'$D(@X@(%))  W !,@X@(%)
 Q:'$G(XPDA)  D WP^DIE(9.7,XPDA_",",20,"A",X)
 Q
MES(X) ;record message, X=message or an array passed by reference
 N %
 I $D(X)#2 S %=X K X S X(1)=%
 ;write message
 F %=1:1 Q:'$D(X(%))  W !,X(%)
 Q:'$G(XPDA)  D WP^DIE(9.7,XPDA_",",20,"A","X")
 Q
BMES(X) ;add blank line before message
 N %
 I $D(X)#2 S %=X K X S X(1)=" ",X(2)=%
 D MES(.X)
 Q
RTNUP(X,Y) ;update routine action, X=routine, Y=action
 ;actions:  1=delete, 2=skip
 N %
 ;set action to Y
 Q:'$G(Y)!'$D(^XTMP("XPDI",$G(XPDA),"RTN",X)) 0 S $P(^(X),U)=+Y
 Q 1
 ;get Build ien
 S Y=$O(^XTMP("XPDI",XPDA,"BLD",0))
 ;remove checksum when updating action, since action can only be
 ;delete or skip, not sure if we want to do this
 S:$P(%,U,2) $P(^XTMP("XPDI",XPDA,"BLD",Y,"KRN",9.8,"NM",$P(%,U,2),0),U,4)=""
 Q 1
DICCP(X) ;lookup check point, returns ien or 0
 Q:$G(X)="" 0
 ;if they pass ien, fail if can't find
 I X=+X S Y=X Q:'$D(^XPD(9.7,XPDA,XPDCP,Y,0)) 0
 E  S Y=$$FIND1^DIC(XPDI,","_XPDA_",","X",X)
 Q Y
 ;
PRODE(XPDN,XPD) ;enable/disable protocols, return 1 for success
 ;XPDN=protocol name, XPD=1-enable, 0-disable
 Q:$G(XPDN)="" 0
 S XPD=+$G(XPD)
 D KIDS^XQOO1($P(XPDSET,U,2),101,XPDN,.XPD)
 Q $S(XPD<0:0,1:1)
 ;
OPTDE(XPDN,XPD) ;enable/disable options, return 1 for success
 ;XPDN=protocol name, XPD=1-enable, 0-disable
 Q:$G(XPDN)="" 0
 S XPD=+$G(XPD)
 D KIDS^XQOO1($P(XPDSET,U,2),19,XPDN,.XPD)
 Q $S(XPD<0:0,1:1)

XPDV
XPDV ;SFISC/RSD - Verify Build ;03/11/97  15:26 [ 04/20/98  10:01 AM ]
 ;;8.0;KERNEL;**1005**;FEB 09, 1999
 ;;8.0;KERNEL;**30,44,58**;Jul 10, 1995
 ;checks that everything is ready to do a build
 ;XPDA=build ien, loop thru all nodes in ^XPD(9.6,XPDA and verify data
EN ;check a build
 N DA,FGR,TYPE,XPDFILE,XPDOLDA,Y0,Y2 K ^TMP($J)
 S Y0=$G(^XPD(9.6,XPDA,0)),TYPE=$P(Y0,U,3)
 I $P(Y0,U,2)="" W !,"No Package File Link"
 I '$P(Y0,U,2) W !,$P(Y0,U,2)," in Package File Link field is freetext, not a pointer"
 I $P(Y0,U,2),'$D(^DIC(9.4,$P(Y0,U,2),0)) W !,$P(Y0,U,2)," in PACKAGE File  ** NOT FOUND **",*7
 ;type is global package goto CONT
 G CONT:TYPE=2
 I TYPE=1 S Y0=$$MULT(XPDA) G DONE
 S XPDFILE=0
 ;check DD being sent
 F  S XPDFILE=$O(^XPD(9.6,XPDA,4,XPDFILE)) Q:'XPDFILE  D
 .Q:$$FILE(XPDFILE)=""
 .S Y0=0,Y2=$G(^XPD(9.6,XPDA,4,XPDFILE,222))
 .Q:'$$DATA(XPDFILE,Y2)
 .F  S Y0=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0)) Q:'Y0  D
 ..I '$D(^DD(Y0)) W !," SubDD #",Y0," in File #",XPDFILE,"  ** NOT FOUND **" Q
 ..S XPDOLDA=0
 ..;check fields being sent for partial DD
 ..F  S XPDOLDA=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0,1,XPDOLDA)) Q:'XPDOLDA  D
 ...I '$D(^DD(Y0,XPDOLDA)) W !,"Field #",XPDOLDA," in SubDD #",Y0," in File #",XPDFILE,"  ** NOT FOUND **" Q
 ;
 ;build components files
 S XPDFILE=0
 F  S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)) Q:'XPDFILE  D
 .;if file doesn't exist, save in ^TMP and deleted at end
 .S FGR=$$FILE(XPDFILE),XPDOLDA=0 I FGR="" S ^TMP($J,XPDFILE)="" Q
 .F  S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA  S Y0=$G(^(XPDOLDA,0)) D
 ..;check action, quit if deleting at site
 ..Q:$P(Y0,U,3)=1
 ..;check that entry exist
 ..S:$P(Y0,U,2) $P(Y0,U)=$P(Y0,"    FILE #") S DA=$$ENTRY(Y0)
 ..Q:'$P(Y0,U,3)!($P(Y0,U,3)#2)
 ..;if attach check that parent is sent, if link check that child is sent
 ..Q:'$$MENU(XPDFILE,DA,$P(Y0,U,3))
 ;check Install Questions
 S XPDOLDA=0
 F  S XPDOLDA=$O(^XPD(9.6,XPDA,"QUES",XPDOLDA)) Q:'XPDOLDA  S Y0=$G(^(XPDOLDA,0)),Y2=$G(^(1)) D
 .I $P(Y0,U)="" W !,"Zero node doesn't exist for INSTALL QUESTION #",XPDOLDA Q
 .I Y2="" W !,"DIR(0) field is not defined for INSTALL QUESTION ",$P(Y0,U)
 I $O(^XPD(9.6,XPDA,"GLO",0)) W !,"Package cannot contain Globals, Files, & Components."
 ;check for PRE & POST routines
 F DA="INI","INIT" S Y0=$G(^XPD(9.6,XPDA,DA)) I Y0]"",'$$RTN(Y0) W !,"Routine ",Y0," ** NOT FOUND **"
CONT ;
 ;check Environment Check routine
 S Y0=$G(^XPD(9.6,XPDA,"PRE")) I Y0]"",'$$RTN(Y0) W !,"Routine ",Y0," ** NOT FOUND **"
 I TYPE=2 S Y0=$$GLOPKG(XPDA)
DONE I $O(^TMP($J,0)) D
 .N DA,DIK,DIR,DIRUT,Y
 .S DIR(0)="Y",DIR("A")="Do you want to remove the missing Files",DIR("B")="NO"
 .S DIR("?")="Yes means that the missing Files will be removed and you can transport this Build"
 .D ^DIR Q:'Y!$D(DIRUT)
 .S DIK="^XPD(9.6,"_XPDA_",""KRN"",",DA(1)=XPDA,DA=0 F  S DA=$O(^TMP($J,DA)) Q:'DA  D ^DIK
 W !!,"  ** DONE **"
 Q
GLOPKG(X) ;GLOBAL PACKAGE
 ;returns 1 if ok, 0 if failed
 N I,J,Y,Z S Z=1
 I $O(^XPD(9.6,X,4,0)) W !,"GLOBAL PACKAGE cannot contain Files" S Z=0
 S I=0 F  S I=$O(^XPD(9.6,X,"KRN",I)) Q:'I  D:$O(^(I,"NM",0))
 .W !,"GLOBAL PACKAGE cannot contain ",$P(^DIC(I,0),U) S Z=0
 I $O(^XPD(9.6,X,"QUES",0)) W !,"GLOBAL PACKAGE cannot contain Install Questions" S Z=0
 I $G(^XPD(9.6,X,"INI"))]"" W !,"GLOBAL PACKAGE cannot have a Pre-Install Routine" S Z=0
 ;I $G(^XPD(9.6,X,"INIT"))]"" W !,"GLOBAL PACKAGE cannot have a Post-Install Routine" S Z=0
 S I=0 F J=0:1 S I=$O(^XPD(9.6,X,"GLO",I)) Q:'I  S Y=$G(^(I,0)) D
 .I $P(Y,U)]"",'$D(@("^"_$P(Y,U))) W !,"Global ",Y," doesn't exist." S Z=0
 I 'J W !,"No Globals to transport" S Z=0
 Q Z
 ;
QUES(X) ;X=.01 of INSTALL QUESTION multiple
 ;returns ien or 0 if failed
 N Y
 S Y=+$O(^XPD(9.6,XPDA,"QUES","B",X,0))
 I '$D(^XPD(9.6,XPDA,"QUES",Y,0)) W !,"Zero node doesn't exist for INSTALL QUESTION ",X Q 0
 I '$D(^XPD(9.6,XPDA,"QUES",Y,1)) W !,"DIR(0) field is not defined for INSTALL QUESTION ",X Q 0
 Q Y
 ;
FILE(X) ;check file # X
 ;returns global ref or "" if failed
 N %,Y
 S Y=$G(^DIC(X,0,"GL"))
 I Y="" W !," File #",X,"  ** NOT FOUND **" Q ""
 S %=$E(Y,$L(Y)),X=$E(Y,1,$L(Y)-1)_$S(%="(":"",1:")")
 Q X
 ;
 ;Z only contains the file # for Fileman templates and forms
 ;XPDFILE=file #,FGR=file global ref
ENTRY(Z) ;check entry, Z=name^file
 ;returns ien or 0 if failed
 N F,X,Y
 ;check for X, name, in "B" x-ref of file.
 S X=$P(Z,U),Y=0 F  S Y=$O(@FGR@("B",X,Y)) D  Q:X=""
 .I 'Y W !?3,X,"  in ",$P(^DIC(XPDFILE,0),U)," File   ** NOT FOUND **",*7 S X="" Q
 .;if Y is in x-ref but node doesn't exist, quit and try another
 .;if this is a fileman template, the file associated with it is piece 2 of Z
 .;if Form file check piece 8 else 4
 .Q:'$D(@FGR@(Y,0))  I $P(Z,U,2) S F=^(0) S:$P(Z,U,2)=$P(F,U,(4+(4*(FGR["DIST")))) X="" Q
 .;if it is routine file,9.8, check that routine exist
 .I XPDFILE=9.8 Q:'$$RTN(X)
 .;if this is not a fileman template or routine we found Y
 .S X="" Q
 Q +Y
 ;
DATA(F,Y) ;
 ;return 1 if ok or 0 if failed
 I $P(Y,U,3)="p",$P(Y,U,7)="y" W !,"You can only send Data with a Full Data Dictionary,",!,"** File #",F," cannot be Sent **" Q 0
 Q 1
 ;
RTN(X) ;verify tag^routine exist, 1=yes, 0=no
 N T,R
 I X["^" S T=$P(X,"^"),R=$P(X,"^",2)
 E  S T="",R=X
 Q:(R'?1A.E) 0
 I T="" Q $T(^@R)]""
 Q $T(@T^@R)]""
 ;
MULT(X) ;multi-package
 ;returns 1 if ok or 0 if failed
 N I,J,X,Y,Z
 S I=0,Z=1
 F J=0:1 S I=$O(^XPD(9.6,X,10,I)) Q:'I  S X=$P($G(^(I,0)),U),Y=0 D
 .S:X]"" Y=$O(^XPD(9.6,"B",X,0))
 .I Y,$D(^XPD(9.6,Y,0)) Q
 .W !,"Package ",X," doesn't exist." S Z=0
 I 'J W !,"No Packages to transport" S Z=0
 Q Z
MENU(F,X,Y) ;check for Parent or Children, F=file (19 or 101), X=ien,
 ;Y=action (2=link or 4=attach)
 ;returns 1 if ok or 0 if failed
 Q:'X 0
 N I,J,GR,Z
 S GR=$S(F=19:"^DIC(19)",1:"^ORD(101)"),(I,Z)=0
 ;link, check that at least 1 menu item was sent
 I Y=2 F  S I=$O(@GR@(X,10,"B",I)) Q:'I  S J=$P($G(@GR@(I,0)),U) I J]"",$D(^XPD(9.6,XPDA,"KRN",F,"NM","B",J)) S Z=1 Q
 ;attach, check that the parent was sent
 I Y=4 F  S I=$O(@GR@("AD",X,I)) Q:'I  S J=$P($G(@GR@(I,0)),U) I J]"",$D(^XPD(9.6,XPDA,"KRN",F,"NM","B",J)) S Z=1 Q
 D:'Z
 .W !,$S(F=19:"Option ",1:"Protocol "),$P($G(@GR@(X,0)),U)," has an Action of "
 .W:Y=2 "'USE AS LINK FOR MENU ITEMS' and no 'Menu Items' were sent."
 .W:Y=4 "'ATTACH TO MENU' and a 'Parent Menu' wasn't sent."
 Q Z