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/XPDIA1.m@ 765

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1XPDIA1 ;SFISC/RSD - Install Pre/Post Actions for Kernel files cont. ;05/05/2003 13:32
2 ;;8.0;KERNEL;**2,44,51,58,68,85,131,146,182,229,302**;Jul 10, 1995
3 Q
4HLPF1 ;help frames file pre
5 K ^TMP($J,"XPD")
6 Q
7HLPE1 ;entry pre
8 S ^TMP($J,"XPD",DA)="" K ^DIC(9.2,DA,1),^(2),^(3),^(10)
9 Q
10HLPF2 ;file post
11 N DA,DIK,I,X,Y,Y0
12 ;need to send error message, need to setup message
13 S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
14 .;repoint Related Frame (2;0)
15 .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
16 .;repoint OBJECT (10;0)
17 .S (I,X)=0 F S I=$O(^DIC(9.2,DA,10,I)) Q:'I S Y0=$G(^(I,0)) D
18 ..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
19 ..K:'Y ^DIC(9.2,DA,10,I)
20 .I X S $P(^DIC(9.2,DA,10,0),U,3,4)=$P(X,U,2)_U_+X
21 .D IX1^DIK
22 K ^TMP($J,"XPD")
23 Q
24HLPDEL ;help frame delete
25 N DA,DIK,XPDI,XPDJ
26 S XPDI=0
27 F S XPDI=$O(^TMP($J,"XPDEL",XPDI)),XPDJ=0 Q:'XPDI D
28 .S DIK="^DIC(9.2,XPDJ,2,"
29 .;check other frames that point to this one
30 .F S XPDJ=$O(^DIC(9.2,"AE",XPDI,XPDJ)) Q:'XPDJ S Z=$O(^(XPDJ,0)) D:Z
31 ..K DA S DA=Z,DA(1)=XPDJ D ^DIK
32 .;delete this frame
33 .K DA S DA=XPDI,DIK="^DIC(9.2," D ^DIK
34 Q
35BULE1 ;bulletin entry pre
36 N X,I S I=0
37 ;save current Mail Groups (2)
38 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))
39 K ^XMB(3.6,DA)
40 ;after killing data, put back Mail Groups before data merge
41 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)
42 Q
43BULDEL ;del bulletins
44 D DELIEN^XPDUTL1(3.6,$G(%))
45 Q
46MAILGF1 ;mail groups file pre
47 K ^TMP($J,"XPD")
48 Q
49MAILGE1 ;mail group entry pre
50 N I,J
51 S ^TMP($J,"XPD",DA)=""
52 ;save MEMBER GROUPS (5;0)
53 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)
54 ;save MEMBER - REMOTE (6;0)
55 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)
56 ;if there is a new Description, kill the old Description
57 K:$O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,2,0)) ^XMB(3.8,DA,2)
58 S I=^XMB(3.8,DA,0),J=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)
59 ;save REFERENCE COUNT (0;4) & LAST REFERENCED (0;5)
60 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)
61 ;check COORDINATOR (0;7), if exist then save, else bring in one that was asked during install question
62 D
63 .I $P(I,U,7) S $P(J,U,7)=$P(I,U,7) Q
64 .S %=$O(^XPD(9.7,XPDA,"QUES","B","XPM"_OLDA_"#1",0)) Q:'%
65 .S:$G(^XPD(9.7,XPDA,"QUES",%,1)) $P(J,U,7)=^(1)
66 S ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)=J,I=$G(^XMB(3.8,DA,3))
67 ;save ORGANIZER (3;1)
68 I $P(I,U) S $P(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,3),U)=$P(I,U)
69 Q
70MAILGF2 ;mail group file post
71 N DA,DIK,XPDMDA,XPDI,Y
72 S XPDMDA=0,DIK="^XMB(3.8,"
73 F S XPDMDA=$O(^TMP($J,"XPD",XPDMDA)) Q:'XPDMDA D
74 .;merge & repoint MEMBER GROUP (5;0)
75 .S XPDI=0
76 .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)
77 .;merge & repoint MEMBER - REMOTE (6;0)
78 .S XPDI=0
79 .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)
80 .S DA=XPDMDA D IX1^DIK
81 K ^TMP($J,"XPD")
82 Q
83MAILGDEL(RT) ;Mail Group delete
84 D DELPTR^XPDUTL1(3.8,RT) ;Delete any pointer entries
85 D DELIEN^XPDUTL1(3.8,RT) ;Delete the entries
86 Q
87HLAPF1 ;HL7 application parameter #771 file pre
88 K ^TMP($J,"XPD")
89 Q
90HLAPE1 ;HL7 application parameter #771 entry pre
91 N I,J
92 S ^TMP($J,"XPD",DA)=""
93 S I=^HL(771,DA,0),J=^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)
94 ;save FACILITY NAME (0;3)
95 S:$P(I,U,3)]"" $P(J,U,3)=$P(I,U,3)
96 ;repoint MAIL GROUP (0;4)
97 S:$P(J,U,4)]"" $P(J,U,4)=$$LK^XPDIA("^XMB(3.8)",$P(J,U,4))
98 ;repoint COUNTRY CODE (0;7)
99 S:$P(J,U,7)]"" $P(J,U,7)=$$LK^XPDIA("^HL(779.004)",$P(J,U,7))
100 S ^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)=J
101 ;remove HL7 SEGMENT (SEG;0), HL7 MESSAGE (MSG;0)
102 K ^HL(771,DA,"SEG"),^("MSG")
103 Q
104HLAPF2 ;HL7 application parameter #771 file post
105 N DA,DIK,XPDI,X,Y
106 S DA=0,DIK="^HL(771,"
107 F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
108 .;repoint HL7 SEGMENT (SEG;0)
109 .S XPDI=0
110 .F S XPDI=$O(^HL(771,DA,"SEG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D
111 ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
112 ..I X]"" S $P(^HL(771,DA,"SEG",XPDI,0),U)=X Q
113 ..K ^HL(771,DA,"SEG",XPDI)
114 .;repoint HL7 MESSAGE (MSG;0)
115 .S XPDI=0
116 .F S XPDI=$O(^HL(771,DA,"MSG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D
117 ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
118 ..I X]"" S $P(^HL(771,DA,"MSG",XPDI,0),U)=X Q
119 ..K ^HL(771,DA,"MSG",XPDI)
120 .D IX1^DIK
121 K ^TMP($J,"XPD")
122 Q
123HLLLPE ;HL7 lower level protocol #869.2 entry pre
124 N I,J,L,TMP,Y
125 S L=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U),I=0
126 ;loop thru logical links and find those pointing to this llp
127 F S I=$O(^XTMP("XPDI",XPDA,"KRN",870,I)) Q:'I S J=$G(^(I,0)) D
128 . Q:$P(J,U,3)'=L
129 . ;save llp into tmp, get the llp type field
130 . M TMP=^XTMP("XPDI",XPDA,"KRN",869.2,OLDA) S Y=$P(TMP(0),U,2)
131 . K TMP(-1),TMP(0)
132 . M ^XTMP("XPDI",XPDA,"KRN",870,I)=TMP S $P(^(I,0),U,3)=Y
133 S I=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)
134 ;repoint LLP TYPE (0;2)
135 S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)=$$LK^XPDIA("^HLCS(869.1)",I)
136 S I=$P($G(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100)),U)
137 ;repoint MAIL GROUP (100;1)
138 S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
139 ;save HLLP DEVICE (200;1)
140 S I=$G(^HLCS(869.2,DA,200))
141 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,200),U)=$P(I,U)
142 ;save X3.28 DEVICE (300;1)
143 S I=$G(^HLCS(869.2,DA,300))
144 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,300),U)=$P(I,U)
145 ;save TCP/IP Start-up Node (400;6)
146 S I=$G(^HLCS(869.2,DA,400))
147 S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,400),U,6)=$P(I,U,6)
148 Q
149HLLLE ;HL7 logical link #870 entry pre
150 N I,J,K,L,Y
151 S I=^HLCS(870,DA,0),J=^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)
152 ;repoint INSTITUTION (0;2)
153 I $P(J,U,2)]"" S Y=$$LK^XPDIA("^DIC(4)",$P(J,U,2)) D:Y="" S $P(J,U,2)=Y
154 .D BMES^XPDUTL(" Couldn't resolve Institution "_$P(J,U,2)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
155 ;repoint LLP TYPE (0;3)
156 S:$P(J,U,3)]"" $P(J,U,3)=$$LK^XPDIA("^HLCS(869.1)",$P(J,U,3))
157 ;repoint DOMAIN (0;7)
158 I $P(J,U,7)]"" S Y=$$LK^XPDIA("^DIC(4.2)",$P(J,U,7)) D:Y="" S $P(J,U,7)=Y
159 .D BMES^XPDUTL(" Couldn't resolve Domain "_$P(J,U,7)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
160 ;save node 0; pieces 4,5,6,7,10,11,12,19,21
161 F L=4:1:7,10:1:12,19,21 S:$P(I,U,L)]"" $P(J,U,L)=$P(I,U,L)
162 ;set SHUTDOWN LLP (0;15) no for DSM multi-listener and yes for all else
163 S Y=$P($G(^HLCS(870,DA,400)),U,3) S:Y]"" $P(J,U,15)=$S(Y="M":(^%ZOSF("OS")["OpenM"),1:1)
164 S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)=J
165 S I=$P($G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100)),U)
166 ;repoint MAIL GROUP (100;1)
167 S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
168 ;save data from site on nodes 200,300,400
169 F L=200,300,400 S I=$G(^HLCS(870,DA,L)) D:I]""
170 . S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)) Q:J=""
171 . ;check local data (I) and if exist set incomming data (J)
172 . F K=1:1:10 S Y=$P(I,U,K) S:Y]"" $P(J,U,K)=Y
173 . S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)=J
174 Q
175KEYF2 ;file post
176 N DA,DIK,I,X,Y,Y0,XPDF
177 ;Repoint fields
178 S DA=0,DIK=DIC,XPDF=19.1 F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
179 . ;repoint Related Frame (3;0)
180 . S I=0 F S I=$O(^DIC(XPDF,DA,3,I)) Q:'I S Y0=$G(^(I,0)),Y=$$LK^XPDIA("^DIC("_XPDF_")",$P(Y0,U,1)) S:Y $P(^DIC(XPDF,DA,2,I,0),U,1)=Y
181 . ;repoint OBJECT (5;0)
182 . S (I,X)=0 F S I=$O(^DIC(XPDF,DA,5,I)) Q:'I S Y0=$G(^(I,0)) D
183 . . S Y=$$LK^XPDIA("^DIC("_XPDF_")",$P(Y0,U)) S:Y $P(^DIC(9.2,DA,5,I,0),U)=Y
184 . D IX1^DIK
185 K ^TMP($J,"XPD")
186 Q
187KEYDEL ;del security keys
188 N XPDI S XPDI=0
189 F S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI D DEL^XPDKEY(XPDI)
190 Q
191LMDEL ;del list manager templates
192 D DELIEN^XPDUTL1(409.61,$NA(^TMP($J,"XPDEL")))
193 Q
194RPCDEL ;del Kernel RPCs
195 D DELIEN^XPDUTL1(8994,$G(%))
196 Q
197CRC32PE ;pre entry for Kernel RPCs CRC32
198 ;if there is a new Description, kill the old Description
199 K:$O(^XTMP("XPDI",XPDA,"KRN",8994.2,OLDA,1,0)) ^XWB(8994.2,DA,1)
200 Q
201CRC32DEL ;del Kernel RPCs CRC32
202 D DELIEN^XPDUTL1(8994.2,$G(%))
203 Q
204HLAPDEL(RT) ;del HL7 application parameter #771
205 D DELIEN^XPDUTL1(771,RT)
206 Q
207HLLLDEL(RT) ;del HL7 logical link #870
208 N DA,DIK,XPDI,XPDJ,Y
209 S XPDI=0
210 ;loop thru protocols, #101, get LL field, 770.7 (700;7)
211 F S XPDI=$O(^ORD(101,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,700)),U,7) D:Y
212 . Q:'$D(^TMP($J,"XPDEL",Y))
213 . K XPDJ S XPDJ(101,XPDI_",",770.7)="@"
214 . D FILE^DIE("","XPDJ")
215 ;subscription, #774
216 F S XPDI=$O(TMP($J,"XPDEL",XPDI)) Q:'XPDI D:$D(^HLS(774,"C",XPDI))
217 . S XPDJ=0 F S XPDJ=$O(^HLS(774,"C",XPDI,XPDJ))
218 D DELIEN^XPDUTL1(870,RT)
219 Q
Note: See TracBrowser for help on using the repository browser.