source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m@ 1742

Last change on this file since 1742 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 8.9 KB
Line 
1XPDDP ;SFISC/RSD - Display a package ;03/18/2008
2 ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488**;Jul 10, 1995;Build 6
3 ; Per VHA Directive 2004-038, this routine should not be modified.
4 ; Options: XPD PRINT BUILD calls EN1
5 ; XPD PRINT INSTALL calls EN2
6EN1 ; Print from Build file
7 N DIC,D0,XPD,XPDT,XPDST,Y
8 S XPDST=$$LOOK^XPDB1 Q:XPDST<0
9 S XPD("XPDT(")=""
10 D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
11 Q
12EN2 ; Print from Distribution
13 N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS
14 S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1)
15 S D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0
16 S XPD("XPDT(")=""
17 D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD)
18 Q
19LST1 ; Print from Build file
20 K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
21 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT)
22 . I XPDCNT Q:'$$CONT
23 . S XPDCNT=XPDCNT+1
24 . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)")
25 D WAIT
26 Q
27LST2 ; Print from XPDT array
28 K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
29 F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT)
30 . I XPDCNT Q:'$$CONT
31 . S XPDCNT=XPDCNT+1
32 . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)")
33 D WAIT
34 Q
35WAIT ; Pause on last page or not? It depends on whether there's enough room
36 ; left on the page to display the KIDS menu.
37 Q:$E($G(IOST),1,2)'="C-"
38 Q:$D(DIRUT)
39 ; DUZ("AUTO")=1 means show menu option choices
40 I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL
41 Q
42PNT(XPDGR) ; Print a package, XPDGR=global root
43 ;XPDFL=0 - Build - ^XPD(9.7 global root
44 ; 1 - Install - ^XTMP global root
45 ; 2 - Packman - ^TMP($J, global root
46 N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT
47 Q:$G(XPDGR)="" S XPDGR="^"_XPDGR
48 Q:'$D(@XPDGR@(0))
49 D ID ; Package Identification
50 D DESCR Q:$D(DIRUT) ; Description
51 I XPDTYPE=1 D MULT Q ; Multi-Package
52 D PREPOST Q:$D(DIRUT) ; Environment check & Pre/Post Routines
53 I XPDTYPE=2 D GLOBAL Q ; Global Package
54 D FILES Q:$D(DIRUT) ; Files/DDs
55 D COMP Q:$D(DIRUT) ; Build Components
56 Q:XPDFL=2 ; Packman message, called from XMP2 - Summarize
57 D QUESTS Q:$D(DIRUT) ; Install Questions
58 D ALFABETA Q:$D(DIRUT) ; Alpha/Beta Testing
59 D NAMESP Q:$D(DIRUT) ; Include/Exclude Namespaces
60 D REQDBLD Q:$D(DIRUT) ; Required Builds
61 Q
62ID ; Identify the package
63 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)
64 W:$E(IOST,1,2)="C-" @IOF D HDR W !,XPDUL
65 W !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
66 W ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
67 W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
68 W ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO")
69 Q
70DESCR ; Show patch description
71 W !!,"DESCRIPTION:"
72 S XPDI=0
73 F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:$D(DIRUT)
74 . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
75 . F D Q:$L(XPDTXT)<IOM!$D(DIRUT)!(IOM<2) S XPDTXT=$E(XPDTXT,IOM,999)
76 . . Q:$$CHK(2)
77 . . W !,$S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT)
78 Q
79PREPOST ; Environment check and pre/post routines
80 Q:$$CHK(3)
81 W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE"))
82 W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
83 I 'XPDTYPE D Q:$D(DIRUT)
84 . Q:$$CHK(2)
85 . W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI"))
86 . W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
87 Q:$$CHK(2)
88 W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT"))
89 W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
90 I 'XPDTYPE Q:$$CHK(2) W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET"))
91 Q
92FILES ; Show files/DDs
93 Q:'$O(@XPDGR@(4,0)) ; Quit if no files
94 S I=$$CHK(8,1) Q:I I '$P(I,"^",2) D HDR1 W !,XPDUL
95 S XPDI=0
96 F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(3,1) D
97 . ;file number, file name, partial DD
98 . W !!,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
99 . ; update DD, send security code, data comes with file
100 . 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))
101 . ; override site data, resolve pointers, user override
102 . 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))
103 . I $P(XPD,U,3)="p" D Q:$D(DIRUT)
104 . . ; Print partial DD information
105 . . N XPDSUB,XPDFLD
106 . . Q:$$CHK(2,1)
107 . . W !,"Partial DD:"
108 . . S (J,XPDSUB)=0
109 . . F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J D Q:$D(DIRUT)
110 . . . I XPDSUB Q:$$CHK(2,1) W !
111 . . . W ?12,"subDD: ",J
112 . . . S XPDSUB=1,(I,XPDFLD)=0
113 . . . F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I D Q:$D(DIRUT)
114 . . . . I XPDFLD Q:$$CHK(2,1) W !
115 . . . . W ?30,"fld: ",I S XPDFLD=1
116 . I " "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1) W !,?2,"DD SCREEN : ",^(223)
117 . I " "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1) W !,?2,"DATA SCREEN: ",^(224)
118 Q
119COMP ; Print Build components
120 S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
121 F S I=$O(@XPDGR@("KRN",I)) Q:'I D Q:$D(DIRUT)
122 . Q:'$D(@XPDGR@("KRN",I,"NM","B"))
123 . Q:$$CHK(4)
124 . W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:"
125 . S J=""
126 . F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) D Q:$D(DIRUT)
127 . . Q:'X
128 . . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
129 . . Q:$$CHK(2)
130 . . ;write the entry name and write the action
131 . . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2)
132 Q
133QUESTS ; Show Install Questions
134 I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q
135 Q:$$CHK(6)
136 W !!,"INSTALL QUESTIONS: "
137 S I=0
138 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)
139 . Q:$$CHK(4)
140 . W !!?5,"SUBSCRIPT: ",X
141 . W !,"DIR(0)=",J
142 . S J=0
143 . F S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""A"",",J,")=",^(J,0)
144 . I K]"" Q:$$CHK(2) W !,"DIR(""A"")=",K
145 . I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2) W !,"DIR(""B"")=",^("B")
146 . S J=0
147 . F S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""?"",",J,")=",^(J,0)
148 . I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2) W !,"DIR(""?"")=",^("Q")
149 . I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2) W !,"DIR(""??"")=",^("QQ")
150 . I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2) W !,"M CODE: ",^("M")
151 Q:$D(DIRUT)
152 ;Show new Defaults for KIDS questions. p463
153 S X=$G(@XPDGR@("QDEF")) Q:X=""
154 I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q
155 Q:$$CHK(3) W !
156 I $L($P(X,U,9)) Q:$$CHK(2) W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9)
157 I $L($P(X,U,5)) Q:$$CHK(2) W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5)
158 I $L($P(X,U,11)) Q:$$CHK(2) W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
159 Q
160ALFABETA ; Alpha/Beta Testing
161 S XPD=$G(@XPDGR@("ABPKG")) Q:XPD=""
162 Q:$P(XPD,U)'="y"
163 Q:$$CHK(4)
164 W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
165 W !,"ADDRESS: ",$P(XPD,U,3)
166 Q
167NAMESP ; Namespaces
168 Q:'$O(@XPDGR@("ABNS",0))
169 Q:$$CHK(4)
170 W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:"
171 S I=0
172 F S I=$O(@XPDGR@("ABNS",I)) Q:'I Q:$$CHK(2) W !?3,^(I,0) D Q:$D(DIRUT)
173 . N XPDNMSP,XPDLF
174 . S (J,XPDLF)=0
175 . F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J S XPDNMSP=^(J,0) D Q:$D(DIRUT)
176 . . I XPDLF Q:$$CHK(2) W !
177 . . W ?50,XPDNMSP
178 . . S XPDLF=1
179 Q
180REQDBLD ; Required Builds
181 Q:'$O(@XPDGR@("REQB",0))
182 Q:$$CHK(4)
183 W !!,"REQUIRED BUILDS:",?47,"ACTION:"
184 S XPDI=0
185 F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
186 . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
187 Q
188GLOBAL ; Global Package
189 Q:$$CHK(4)
190 W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:"
191 S XPDI=0
192 F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
193 . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
194 Q
195MULT ; Multi-Package
196 Q:$$CHK(4)
197 W !!,"SEQUENCE OF BUILDS:"
198 S XPDI=0
199 F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D
200 . W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
201 Q
202CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
203 ;return 0 if header was not written, else "0^1"
204 Q:$Y<(IOSL-Y) 0
205 Q:'$$CONT 1
206 S XPD=$G(XPD),XPDPG=XPDPG+1
207 W @IOF D HDR,HDR1:XPD
208 W !,XPDUL
209 Q "0^1"
210CONT() ; Press Return to continue; ^ to exit.
211 Q:$D(DIRUT) 0
212 Q:$E(IOST,1,2)'="C-" 1
213 N DIR,I,J,K,X,Y
214 S DIR(0)="E" D ^DIR
215 Q Y
216XMP2(X,D0) ;called from ^XMP2
217 N XPDA S XPDA=-1
218 D PNT(X)
219 Q
220HDR ;
221 W "PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
222 Q
223HDR1 ;
224 W !!,?43,"UP SEND DATA USER"
225 W !,?43,"DATE SEC. COMES SITE RSLV OVER"
226 W !,"FILE #",?12,"FILE NAME",?43,"DD CODE W/FILE DATA PTRS RIDE"
227 Q
Note: See TracBrowser for help on using the repository browser.