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

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1XPDV ;SFISC/RSD - Verify Build ;04/02/99 09:23
2 ;;8.0;KERNEL;**30,44,58,108**;Jul 10, 1995
3 ;checks that everything is ready to do a build
4 ;XPDA=build ien, loop thru all nodes in ^XPD(9.6,XPDA and verify data
5EN ;check a build
6 N DA,FGR,TYPE,XPDFILE,XPDOLDA,Y0,Y2 K ^TMP($J)
7 S Y0=$G(^XPD(9.6,XPDA,0)),TYPE=$P(Y0,U,3)
8 I $P(Y0,U,2)="" W !,"No Package File Link"
9 I '$P(Y0,U,2) W !,$P(Y0,U,2)," in Package File Link field is freetext, not a pointer"
10 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
11 ;type is global package goto CONT
12 G CONT:TYPE=2
13 I TYPE=1 S Y0=$$MULT(XPDA) G DONE
14 S XPDFILE=0
15 ;check DD being sent
16 F S XPDFILE=$O(^XPD(9.6,XPDA,4,XPDFILE)) Q:'XPDFILE D
17 .Q:$$FILE(XPDFILE)=""
18 .S Y0=0,Y2=$G(^XPD(9.6,XPDA,4,XPDFILE,222))
19 .Q:'$$DATA(XPDFILE,Y2)
20 .F S Y0=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0)) Q:'Y0 D
21 ..I '$D(^DD(Y0)) W !," SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q
22 ..S XPDOLDA=0
23 ..;check fields being sent for partial DD
24 ..F S XPDOLDA=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0,1,XPDOLDA)) Q:'XPDOLDA D
25 ...I '$D(^DD(Y0,XPDOLDA)) W !,"Field #",XPDOLDA," in SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q
26 ;
27 ;build components files
28 S XPDFILE=0
29 F S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)) Q:'XPDFILE D
30 .;if file doesn't exist, save in ^TMP and deleted at end
31 .S FGR=$$FILE(XPDFILE),XPDOLDA=0 I FGR="" S ^TMP($J,XPDFILE)="" Q
32 .F S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)) D
33 ..;check action, quit if deleting at site
34 ..Q:$P(Y0,U,3)=1
35 ..;check that entry exist
36 ..S:$P(Y0,U,2) $P(Y0,U)=$P(Y0," FILE #") S DA=$$ENTRY(Y0)
37 ..Q:'$P(Y0,U,3)!($P(Y0,U,3)#2)
38 ..;if attach check that parent is sent, if link check that child is sent
39 ..Q:'$$MENU(XPDFILE,DA,$P(Y0,U,3))
40 ;check Install Questions
41 S XPDOLDA=0
42 F S XPDOLDA=$O(^XPD(9.6,XPDA,"QUES",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)),Y2=$G(^(1)) D
43 .I $P(Y0,U)="" W !,"Zero node doesn't exist for INSTALL QUESTION #",XPDOLDA Q
44 .I Y2="" W !,"DIR(0) field is not defined for INSTALL QUESTION ",$P(Y0,U)
45 I $O(^XPD(9.6,XPDA,"GLO",0)) W !,"Package cannot contain Globals, Files, & Components."
46 ;check for PRE & POST routines
47 F DA="INI","INIT" S Y0=$G(^XPD(9.6,XPDA,DA)) I Y0]"",'$$RTN(Y0) W !,"Routine ",Y0," ** NOT FOUND **"
48CONT ;
49 ;check Environment Check routine
50 S Y0=$G(^XPD(9.6,XPDA,"PRE")) I Y0]"",'$$RTN(Y0) W !,"Routine ",Y0," ** NOT FOUND **"
51 I TYPE=2 S Y0=$$GLOPKG(XPDA)
52DONE I $O(^TMP($J,0)) D
53 .N DA,DIK,DIR,DIRUT,Y
54 .S DIR(0)="Y",DIR("A")="Do you want to remove the missing Files",DIR("B")="NO"
55 .S DIR("?")="Yes means that the missing Files will be removed and you can transport this Build"
56 .D ^DIR Q:'Y!$D(DIRUT)
57 .S DIK="^XPD(9.6,"_XPDA_",""KRN"",",DA(1)=XPDA,DA=0 F S DA=$O(^TMP($J,DA)) Q:'DA D ^DIK
58 W !!," ** DONE **"
59 Q
60GLOPKG(X) ;GLOBAL PACKAGE
61 ;returns 1 if ok, 0 if failed
62 N I,J,Y,Z S Z=1
63 I $O(^XPD(9.6,X,4,0)) W !,"GLOBAL PACKAGE cannot contain Files" S Z=0
64 S I=0 F S I=$O(^XPD(9.6,X,"KRN",I)) Q:'I D:$O(^(I,"NM",0))
65 .W !,"GLOBAL PACKAGE cannot contain ",$P(^DIC(I,0),U) S Z=0
66 I $O(^XPD(9.6,X,"QUES",0)) W !,"GLOBAL PACKAGE cannot contain Install Questions" S Z=0
67 I $G(^XPD(9.6,X,"INI"))]"" W !,"GLOBAL PACKAGE cannot have a Pre-Install Routine" S Z=0
68 ;I $G(^XPD(9.6,X,"INIT"))]"" W !,"GLOBAL PACKAGE cannot have a Post-Install Routine" S Z=0
69 S I=0 F J=0:1 S I=$O(^XPD(9.6,X,"GLO",I)) Q:'I S Y=$G(^(I,0)) D
70 .I $P(Y,U)]"",'$D(@("^"_$P(Y,U))) W !,"Global ",Y," doesn't exist." S Z=0
71 I 'J W !,"No Globals to transport" S Z=0
72 Q Z
73 ;
74QUES(X) ;X=.01 of INSTALL QUESTION multiple
75 ;returns ien or 0 if failed
76 N Y
77 S Y=+$O(^XPD(9.6,XPDA,"QUES","B",X,0))
78 I '$D(^XPD(9.6,XPDA,"QUES",Y,0)) W !,"Zero node doesn't exist for INSTALL QUESTION ",X Q 0
79 I '$D(^XPD(9.6,XPDA,"QUES",Y,1)) W !,"DIR(0) field is not defined for INSTALL QUESTION ",X Q 0
80 Q Y
81 ;
82FILE(X) ;check file # X
83 ;returns global ref or "" if failed
84 N %,Y
85 S Y=$G(^DIC(X,0,"GL"))
86 I Y="" W !," File #",X," ** NOT FOUND **" Q ""
87 S %=$E(Y,$L(Y)),X=$E(Y,1,$L(Y)-1)_$S(%="(":"",1:")")
88 Q X
89 ;
90 ;Z only contains the file # for Fileman templates and forms
91 ;XPDFILE=file #,FGR=file global ref
92ENTRY(Z) ;check entry, Z=name^file
93 ;returns ien or 0 if failed
94 N F,X,Y
95 ;check for X, name, in "B" x-ref of file.
96 S X=$P(Z,U),Y=0 F S Y=$O(@FGR@("B",X,Y)) D Q:X=""
97 .I 'Y W !?3,X," in ",$P(^DIC(XPDFILE,0),U)," File ** NOT FOUND **",*7 S X="" Q
98 .;if Y is in x-ref but node doesn't exist, quit and try another
99 .;if this is a fileman template, the file associated with it is piece 2 of Z
100 .;if Form file check piece 8 else 4
101 .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
102 .;if it is routine file,9.8, check that routine exist
103 .I XPDFILE=9.8 Q:'$$RTN(X)
104 .;if this is not a fileman template or routine we found Y
105 .S X="" Q
106 Q +Y
107 ;
108DATA(F,Y) ;
109 ;return 1 if ok or 0 if failed
110 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
111 Q 1
112 ;
113RTN(X) ;verify tag^routine exist, 1=yes, 0=no
114 N T,R
115 I X["^" S T=$P(X,"^"),R=$P(X,"^",2)
116 E S T="",R=X
117 Q:(R'?1A.E) 0
118 I T="" Q $T(^@R)]""
119 Q $T(@T^@R)]""
120 ;
121MULT(DA) ;multi-package
122 ;returns 1 if ok or 0 if failed
123 N I,J,X,Y,Z
124 S I=0,Z=1
125 F J=0:1 S I=$O(^XPD(9.6,DA,10,I)) Q:'I S X=$P($G(^(I,0)),U),Y=0 D
126 .S:X]"" Y=$O(^XPD(9.6,"B",X,0))
127 .I Y,$D(^XPD(9.6,Y,0)) Q
128 .W !,"Package ",X," doesn't exist." S Z=0
129 I 'J W !,"No Packages to transport" S Z=0
130 Q Z
131MENU(F,X,Y) ;check for Parent or Children, F=file (19 or 101), X=ien,
132 ;Y=action (2=link or 4=attach)
133 ;returns 1 if ok or 0 if failed
134 Q:'X 0
135 N I,J,GR,Z
136 S GR=$S(F=19:"^DIC(19)",1:"^ORD(101)"),(I,Z)=0
137 ;link, check that at least 1 menu item was sent
138 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
139 ;attach, check that the parent was sent
140 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
141 D:'Z
142 .W !,$S(F=19:"Option ",1:"Protocol "),$P($G(@GR@(X,0)),U)," has an Action of "
143 .W:Y=2 "'USE AS LINK FOR MENU ITEMS' and no 'Menu Items' were sent."
144 .W:Y=4 "'ATTACH TO MENU' and a 'Parent Menu' wasn't sent."
145 Q Z
Note: See TracBrowser for help on using the repository browser.