XPDDP1 ;SFISC/RSD - Continue Display a package ;
;;8.0;KERNEL;**525**;Jul 10, 1995;Build 16
; Per VHA Directive 2004-038, this routine should not be modified.
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,XPDTXT
Q:$G(XPDGR)="" S XPDGR="^"_XPDGR
Q:'$D(@XPDGR@(0)) S XPD0=^(0)
D ID ; Package Identification
D DESCR Q:$D(DIRUT) ; Description
I XPDTYPE=1 D MULT Q ; Multi-Package
D PREPOST Q:$D(DIRUT) ; Environment check & Pre/Post Routines
I XPDTYPE=2 D GLOBAL Q ; Global Package
D FILES Q:$D(DIRUT) ; Files/DDs
D COMP Q:$D(DIRUT) ; Build Components
Q:XPDFL=2 ; Packman message, called from XMP2 - Summarize
D QUESTS Q:$D(DIRUT) ; Install Questions
D ALFABETA Q:$D(DIRUT) ; Alpha/Beta Testing
D NAMESP Q:$D(DIRUT) ; Include/Exclude Namespaces
D REQDBLD Q:$D(DIRUT) ; Required Builds
Q
ID ; Identify the package
S 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 ?51,"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 ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO")
Q
DESCR ; Show patch description
W !!,"DESCRIPTION:"
S XPDI=0
F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:$D(DIRUT)
. I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
. F D Q:$L(XPDTXT)<IOM!$D(DIRUT)!(IOM<2) S XPDTXT=$E(XPDTXT,IOM,999)
. . Q:$$CHK(2)
. . W !,$S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT)
Q
PREPOST ; Environment check and pre/post routines
Q:$$CHK(3)
W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE"))
W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
I 'XPDTYPE D Q:$D(DIRUT)
. Q:$$CHK(2)
. W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI"))
. W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
Q:$$CHK(2)
W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT"))
W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
I 'XPDTYPE Q:$$CHK(2) W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET"))
Q
FILES ; Show files/DDs
Q:'$O(@XPDGR@(4,0)) ; Quit if no files
S I=$$CHK(8,1) Q:I I '$P(I,"^",2) D HDR1 W !,XPDUL
S XPDI=0
F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(3,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)))
. ; update DD, send security code, data comes with file
. W ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
. ; override site data, resolve pointers, user override
. W ?63,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9))
. I $P(XPD,U,3)="p" D Q:$D(DIRUT)
. . ; Print partial DD information
. . N XPDSUB,XPDFLD
. . Q:$$CHK(2,1)
. . W !,"Partial DD:"
. . S (J,XPDSUB)=0
. . F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J D Q:$D(DIRUT)
. . . I XPDSUB Q:$$CHK(2,1) W !
. . . W ?12,"subDD: ",J
. . . S XPDSUB=1,(I,XPDFLD)=0
. . . F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I D Q:$D(DIRUT)
. . . . I XPDFLD Q:$$CHK(2,1) W !
. . . . W ?30,"fld: ",I S XPDFLD=1
. I " "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1) W !,?2,"DD SCREEN : ",^(223)
. I " "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1) W !,?2,"DATA SCREEN: ",^(224)
Q
COMP ; Print Build components
S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
F S I=$O(@XPDGR@("KRN",I)) Q:'I D Q:$D(DIRUT)
. Q:'$D(@XPDGR@("KRN",I,"NM","B"))
. Q:$$CHK(4)
. W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:"
. S J=""
. F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) D Q:$D(DIRUT)
. . Q:'X
. . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
. . Q:$$CHK(2)
. . ;write the entry name and write the action
. . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2)
Q
QUESTS ; Show Install Questions
I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q
Q:$$CHK(6)
W !!,"INSTALL QUESTIONS: "
S I=0
F S I=$O(@XPDGR@("QUES",I)) Q:'I S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) D Q:$D(DIRUT)
. Q:$$CHK(4)
. W !!?5,"SUBSCRIPT: ",X
. W !,"DIR(0)=",J
. S J=0
. F S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""A"",",J,")=",^(J,0)
. I K]"" Q:$$CHK(2) W !,"DIR(""A"")=",K
. I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2) W !,"DIR(""B"")=",^("B")
. S J=0
. F S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""?"",",J,")=",^(J,0)
. I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2) W !,"DIR(""?"")=",^("Q")
. I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2) W !,"DIR(""??"")=",^("QQ")
. I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2) W !,"M CODE: ",^("M")
Q:$D(DIRUT)
;Show new Defaults for KIDS questions. p463
S X=$G(@XPDGR@("QDEF")) Q:X=""
I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q
Q:$$CHK(3) W !
I $L($P(X,U,9)) Q:$$CHK(2) W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9)
I $L($P(X,U,5)) Q:$$CHK(2) W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5)
I $L($P(X,U,11)) Q:$$CHK(2) W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
Q
ALFABETA ; Alpha/Beta Testing
S XPD=$G(@XPDGR@("ABPKG")) Q:XPD=""
Q:$P(XPD,U)'="y"
Q:$$CHK(4)
W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
W !,"ADDRESS: ",$P(XPD,U,3)
Q
NAMESP ; Namespaces
Q:'$O(@XPDGR@("ABNS",0))
Q:$$CHK(4)
W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:"
S I=0
F S I=$O(@XPDGR@("ABNS",I)) Q:'I Q:$$CHK(2) W !?3,^(I,0) D Q:$D(DIRUT)
. N XPDNMSP,XPDLF
. S (J,XPDLF)=0
. F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J S XPDNMSP=^(J,0) D Q:$D(DIRUT)
. . I XPDLF Q:$$CHK(2) W !
. . W ?50,XPDNMSP
. . S XPDLF=1
Q
REQDBLD ; Required Builds
Q:'$O(@XPDGR@("REQB",0))
Q:$$CHK(4)
W !!,"REQUIRED BUILDS:",?47,"ACTION:"
S XPDI=0
F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
. W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
Q
GLOBAL ; Global Package
Q:$$CHK(4)
W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:"
S XPDI=0
F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
. W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
Q
MULT ; Multi-Package
Q:$$CHK(4)
W !!,"SEQUENCE OF BUILDS:"
S XPDI=0
F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
. W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
Q
CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
;return 0 if header was not written, else "0^1"
Q:$Y<(IOSL-Y) 0
Q:'$$CONT 1
S XPD=$G(XPD),XPDPG=XPDPG+1
W @IOF D HDR,HDR1:XPD
W !,XPDUL
Q "0^1"
;
CONT() ; Press Return to continue; ^ to exit.
Q:$D(DIRUT) 0
Q:$E(IOST,1,2)'="C-" 1
N DIR,I,J,K,X,Y
S DIR(0)="E" D ^DIR
Q Y
;
HDR ;
W "PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
Q
HDR1 ;
W !!,?43,"UP SEND DATA USER"
W !,?43,"DATE SEC. COMES SITE RSLV OVER"
W !,"FILE #",?12,"FILE NAME",?43,"DD CODE W/FILE DATA PTRS RIDE"
Q
XPDDP1 ;SFISC/RSD - Continue Display a package ;
+1 ;;8.0;KERNEL;**525**;Jul 10, 1995;Build 16
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
PNT(XPDGR) ; Print a package, XPDGR=global root
+1 ;XPDFL=0 - Build - ^XPD(9.7 global root
+2 ; 1 - Install - ^XTMP global root
+3 ; 2 - Packman - ^TMP($J, global root
+4 NEW I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT
+5 IF $GET(XPDGR)=""
QUIT
SET XPDGR="^"_XPDGR
+6 IF '$DATA(@XPDGR@(0))
QUIT
SET XPD0=^(0)
+7 ; Package Identification
DO ID
+8 ; Description
DO DESCR
IF $DATA(DIRUT)
QUIT
+9 ; Multi-Package
IF XPDTYPE=1
DO MULT
QUIT
+10 ; Environment check & Pre/Post Routines
DO PREPOST
IF $DATA(DIRUT)
QUIT
+11 ; Global Package
IF XPDTYPE=2
DO GLOBAL
QUIT
+12 ; Files/DDs
DO FILES
IF $DATA(DIRUT)
QUIT
+13 ; Build Components
DO COMP
IF $DATA(DIRUT)
QUIT
+14 ; Packman message, called from XMP2 - Summarize
IF XPDFL=2
QUIT
+15 ; Install Questions
DO QUESTS
IF $DATA(DIRUT)
QUIT
+16 ; Alpha/Beta Testing
DO ALFABETA
IF $DATA(DIRUT)
QUIT
+17 ; Include/Exclude Namespaces
DO NAMESP
IF $DATA(DIRUT)
QUIT
+18 ; Required Builds
DO REQDBLD
IF $DATA(DIRUT)
QUIT
+19 QUIT
ID ; Identify the package
+1 SET XPDPG=1
SET XPDFL=$SELECT($EXTRACT(XPDGR,1,5)="^TMP(":2,1:$EXTRACT(XPDGR,1,5)="^XTMP")
SET $PIECE(XPDUL,"-",IOM)=""
SET XPDDT=$$HTE^XLFDT($HOROLOG,"1PM")
SET XPDTYPE=+$PIECE(XPD0,U,3)
SET XPDTRACK=$PIECE(XPD0,U,5)
+2 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO HDR
WRITE !,XPDUL
+3 WRITE !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
+4 WRITE ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
+5 WRITE !,"NATIONAL PACKAGE: ",$PIECE($GET(^DIC(9.4,+$PIECE(XPD0,U,2),0),$PIECE(XPD0,U,2)),U)
+6 WRITE ?49,"ALPHA/BETA TESTING: ",$SELECT($PIECE($GET(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO")
+7 QUIT
DESCR ; Show patch description
+1 WRITE !!,"DESCRIPTION:"
+2 SET XPDI=0
+3 FOR
SET XPDI=$ORDER(@XPDGR@(1,XPDI))
IF 'XPDI
QUIT
SET XPDTXT=$GET(^(XPDI,0))
Begin DoDot:1
+4 IF $LENGTH(XPDTXT)'<IOM
IF $EXTRACT(XPDTXT,$LENGTH(XPDTXT))=" "
FOR
SET XPDTXT=$EXTRACT(XPDTXT,1,$LENGTH(XPDTXT)-1)
IF $EXTRACT(XPDTXT,$LENGTH(XPDTXT))'=" "
QUIT
+5 FOR
Begin DoDot:2
+6 IF $$CHK(2)
QUIT
+7 WRITE !,$SELECT(IOM>1:$EXTRACT(XPDTXT,1,IOM-1),1:XPDTXT)
End DoDot:2
IF $LENGTH(XPDTXT)<IOM!$DATA(DIRUT)!(IOM<2)
QUIT
SET XPDTXT=$EXTRACT(XPDTXT,IOM,999)
End DoDot:1
IF $DATA(DIRUT)
QUIT
+8 QUIT
PREPOST ; Environment check and pre/post routines
+1 IF $$CHK(3)
QUIT
+2 WRITE !!,"ENVIRONMENT CHECK: ",$GET(@XPDGR@("PRE"))
+3 WRITE ?49,"DELETE ENV ROUTINE: "
IF $GET(@XPDGR@("PRE"))]""
WRITE $SELECT($PIECE($GET(@XPDGR@("INID")),U)="y":"Yes",1:"No")
+4 IF 'XPDTYPE
Begin DoDot:1
+5 IF $$CHK(2)
QUIT
+6 WRITE !," PRE-INIT ROUTINE: ",$GET(@XPDGR@("INI"))
+7 WRITE ?44,"DELETE PRE-INIT ROUTINE: "
IF $GET(@XPDGR@("INI"))]""
WRITE $SELECT($PIECE($GET(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
End DoDot:1
IF $DATA(DIRUT)
QUIT
+8 IF $$CHK(2)
QUIT
+9 WRITE !,"POST-INIT ROUTINE: ",$GET(@XPDGR@("INIT"))
+10 WRITE ?43,"DELETE POST-INIT ROUTINE: "
IF $GET(@XPDGR@("INIT"))]""
WRITE $SELECT($PIECE($GET(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
+11 IF 'XPDTYPE
IF $$CHK(2)
QUIT
WRITE !,"PRE-TRANSPORT RTN: ",$GET(@XPDGR@("PRET"))
+12 QUIT
FILES ; Show files/DDs
+1 ; Quit if no files
IF '$ORDER(@XPDGR@(4,0))
QUIT
+2 SET I=$$CHK(8,1)
IF I
QUIT
IF '$PIECE(I,"^",2)
DO HDR1
WRITE !,XPDUL
+3 SET XPDI=0
+4 FOR
SET XPDI=$ORDER(@XPDGR@(4,XPDI))
IF 'XPDI
QUIT
SET XPD=$GET(^(XPDI,222))
IF $$CHK(3,1)
QUIT
Begin DoDot:1
+5 ;file number, file name, partial DD
+6 WRITE !!,XPDI,?12,$SELECT('XPDFL:$PIECE($GET(^DIC(XPDI,0),"**unknown**"),U),1:$GET(^XTMP("XPDI",XPDA,"FIA",XPDI)))
+7 ; update DD, send security code, data comes with file
+8 WRITE ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$PIECE(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$PIECE(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$PIECE(XPD,U,7))
+9 ; override site data, resolve pointers, user override
+10 WRITE ?63,$EXTRACT($$EXTERNAL^DILFD(9.64,222.8,"",$PIECE(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$PIECE(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$PIECE(XPD,U,9))
+11 IF $PIECE(XPD,U,3)="p"
Begin DoDot:2
+12 ; Print partial DD information
+13 NEW XPDSUB,XPDFLD
+14 IF $$CHK(2,1)
QUIT
+15 WRITE !,"Partial DD:"
+16 SET (J,XPDSUB)=0
+17 FOR
SET J=$ORDER(@XPDGR@(4,"APDD",XPDI,J))
IF 'J
QUIT
Begin DoDot:3
+18 IF XPDSUB
IF $$CHK(2,1)
QUIT
WRITE !
+19 WRITE ?12,"subDD: ",J
+20 SET XPDSUB=1
SET (I,XPDFLD)=0
+21 FOR
SET I=$ORDER(@XPDGR@(4,"APDD",XPDI,J,I))
IF 'I
QUIT
Begin DoDot:4
+22 IF XPDFLD
IF $$CHK(2,1)
QUIT
WRITE !
+23 WRITE ?30,"fld: ",I
SET XPDFLD=1
End DoDot:4
IF $DATA(DIRUT)
QUIT
End DoDot:3
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
+24 IF " "'[$GET(@XPDGR@(4,XPDI,223))
IF $$CHK(2,1)
QUIT
WRITE !,?2,"DD SCREEN : ",^(223)
+25 IF " "'[$GET(@XPDGR@(4,XPDI,224))
IF $$CHK(2,1)
QUIT
WRITE !,?2,"DATA SCREEN: ",^(224)
End DoDot:1
+26 QUIT
COMP ; Print Build components
+1 SET I=0
SET XPD=$PIECE(^DD(9.68,.03,0),U,3)
+2 FOR
SET I=$ORDER(@XPDGR@("KRN",I))
IF 'I
QUIT
Begin DoDot:1
+3 IF '$DATA(@XPDGR@("KRN",I,"NM","B"))
QUIT
+4 IF $$CHK(4)
QUIT
+5 WRITE !!,$SELECT($DATA(^DIC(I,0)):$PIECE(^(0),U),XPDFL:$GET(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:"
+6 SET J=""
+7 FOR
SET J=$ORDER(@XPDGR@("KRN",I,"NM","B",J))
IF J=""
QUIT
SET X=$ORDER(^(J,0))
Begin DoDot:2
+8 IF 'X
QUIT
+9 SET X=$GET(@XPDGR@("KRN",I,"NM",X,0))
IF X=""
QUIT
+10 IF $$CHK(2)
QUIT
+11 ;write the entry name and write the action
+12 WRITE !,?3,$PIECE(X,U),?50,$PIECE($PIECE(XPD,";",$PIECE(X,U,3)+1),":",2)
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+13 QUIT
QUESTS ; Show Install Questions
+1 IF '$ORDER(@XPDGR@("QUES",0))
IF '($DATA(@XPDGR@("QDEF"))#2)
QUIT
+2 IF $$CHK(6)
QUIT
+3 WRITE !!,"INSTALL QUESTIONS: "
+4 SET I=0
+5 FOR
SET I=$ORDER(@XPDGR@("QUES",I))
IF 'I
QUIT
SET X=$PIECE(^(I,0),U)
SET J=$GET(^(1))
SET K=$GET(^("A"))
Begin DoDot:1
+6 IF $$CHK(4)
QUIT
+7 WRITE !!?5,"SUBSCRIPT: ",X
+8 WRITE !,"DIR(0)=",J
+9 SET J=0
+10 FOR
SET J=$ORDER(@XPDGR@("QUES",I,"A1",J))
IF 'J
QUIT
IF $$CHK(2)
QUIT
WRITE !,"DIR(""A"",",J,")=",^(J,0)
+11 IF K]""
IF $$CHK(2)
QUIT
WRITE !,"DIR(""A"")=",K
+12 IF $GET(@XPDGR@("QUES",I,"B"))]""
IF $$CHK(2)
QUIT
WRITE !,"DIR(""B"")=",^("B")
+13 SET J=0
+14 FOR
SET J=$ORDER(@XPDGR@("QUES",I,"Q1",J))
IF 'J
QUIT
IF $$CHK(2)
QUIT
WRITE !,"DIR(""?"",",J,")=",^(J,0)
+15 IF $GET(@XPDGR@("QUES",I,"Q"))]""
IF $$CHK(2)
QUIT
WRITE !,"DIR(""?"")=",^("Q")
+16 IF $GET(@XPDGR@("QUES",I,"QQ"))]""
IF $$CHK(2)
QUIT
WRITE !,"DIR(""??"")=",^("QQ")
+17 IF $GET(@XPDGR@("QUES",I,"M"))]""
IF $$CHK(2)
QUIT
WRITE !,"M CODE: ",^("M")
End DoDot:1
IF $DATA(DIRUT)
QUIT
+18 IF $DATA(DIRUT)
QUIT
+19 ;Show new Defaults for KIDS questions. p463
+20 SET X=$GET(@XPDGR@("QDEF"))
IF X=""
QUIT
+21 IF '$LENGTH($PIECE(X,U,9))
IF '$LENGTH($PIECE(X,U,5))
IF '$LENGTH($PIECE(X,U,11))
QUIT
+22 IF $$CHK(3)
QUIT
WRITE !
+23 IF $LENGTH($PIECE(X,U,9))
IF $$CHK(2)
QUIT
WRITE !," Default Rebuild Menu Trees Upon Completion of Install: ",$PIECE(X,U,9)
+24 IF $LENGTH($PIECE(X,U,5))
IF $$CHK(2)
QUIT
WRITE !," Default INHIBIT LOGONs during the install: ",$PIECE(X,U,5)
+25 IF $LENGTH($PIECE(X,U,11))
IF $$CHK(2)
QUIT
WRITE !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$PIECE(X,U,11)
+26 QUIT
ALFABETA ; Alpha/Beta Testing
+1 SET XPD=$GET(@XPDGR@("ABPKG"))
IF XPD=""
QUIT
+2 IF $PIECE(XPD,U)'="y"
QUIT
+3 IF $$CHK(4)
QUIT
+4 WRITE !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$PIECE(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$PIECE(XPD,U,2))
+5 WRITE !,"ADDRESS: ",$PIECE(XPD,U,3)
+6 QUIT
NAMESP ; Namespaces
+1 IF '$ORDER(@XPDGR@("ABNS",0))
QUIT
+2 IF $$CHK(4)
QUIT
+3 WRITE !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:"
+4 SET I=0
+5 FOR
SET I=$ORDER(@XPDGR@("ABNS",I))
IF 'I
QUIT
IF $$CHK(2)
QUIT
WRITE !?3,^(I,0)
Begin DoDot:1
+6 NEW XPDNMSP,XPDLF
+7 SET (J,XPDLF)=0
+8 FOR
SET J=$ORDER(@XPDGR@("ABNS",I,1,J))
IF 'J
QUIT
SET XPDNMSP=^(J,0)
Begin DoDot:2
+9 IF XPDLF
IF $$CHK(2)
QUIT
WRITE !
+10 WRITE ?50,XPDNMSP
+11 SET XPDLF=1
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+12 QUIT
REQDBLD ; Required Builds
+1 IF '$ORDER(@XPDGR@("REQB",0))
QUIT
+2 IF $$CHK(4)
QUIT
+3 WRITE !!,"REQUIRED BUILDS:",?47,"ACTION:"
+4 SET XPDI=0
+5 FOR
SET XPDI=$ORDER(@XPDGR@("REQB",XPDI))
IF 'XPDI
QUIT
SET XPD=$GET(^(XPDI,0))
IF $$CHK(2)
QUIT
Begin DoDot:1
+6 WRITE !?3,$PIECE(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$PIECE(XPD,U,2))
End DoDot:1
+7 QUIT
GLOBAL ; Global Package
+1 IF $$CHK(4)
QUIT
+2 WRITE !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:"
+3 SET XPDI=0
+4 FOR
SET XPDI=$ORDER(@XPDGR@("GLO",XPDI))
IF 'XPDI
QUIT
SET XPD=$GET(^(XPDI,0))
IF $$CHK(2)
QUIT
Begin DoDot:1
+5 WRITE !?3,$PIECE(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$PIECE(XPD,U,2))
End DoDot:1
+6 QUIT
MULT ; Multi-Package
+1 IF $$CHK(4)
QUIT
+2 WRITE !!,"SEQUENCE OF BUILDS:"
+3 SET XPDI=0
+4 FOR
SET XPDI=$ORDER(@XPDGR@(10,XPDI))
IF 'XPDI
QUIT
SET XPD=$GET(^(XPDI,0))
IF $$CHK(2)
QUIT
Begin DoDot:1
+5 WRITE !?2,XPDI,?8,$EXTRACT($PIECE(XPD,U),1,44),?54,$SELECT($PIECE(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
End DoDot:1
+6 QUIT
CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
+1 ;return 0 if header was not written, else "0^1"
+2 IF $Y<(IOSL-Y)
QUIT 0
+3 IF '$$CONT
QUIT 1
+4 SET XPD=$GET(XPD)
SET XPDPG=XPDPG+1
+5 WRITE @IOF
DO HDR
IF XPD
DO HDR1
+6 WRITE !,XPDUL
+7 QUIT "0^1"
+8 ;
CONT() ; Press Return to continue; ^ to exit.
+1 IF $DATA(DIRUT)
QUIT 0
+2 IF $EXTRACT(IOST,1,2)'="C-"
QUIT 1
+3 NEW DIR,I,J,K,X,Y
+4 SET DIR(0)="E"
DO ^DIR
+5 QUIT Y
+6 ;
HDR ;
+1 WRITE "PACKAGE: ",$PIECE(XPD0,U)," ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
+2 QUIT
HDR1 ;
+1 WRITE !!,?43,"UP SEND DATA USER"
+2 WRITE !,?43,"DATE SEC. COMES SITE RSLV OVER"
+3 WRITE !,"FILE #",?12,"FILE NAME",?43,"DD CODE W/FILE DATA PTRS RIDE"
+4 QUIT
