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/XPDIA.m@ 1724

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1XPDIA ;SFISC/RSD - Install Pre/Post Actions for Kernel Files ;03/27/2000 12:58
2 ;;8.0;KERNEL;**10,15,21,28,44,58,68,131,145**;Jul 10, 1995
3 Q
4OPTF1 ;options file pre
5 K ^TMP($J,"XPD")
6 Q
7OPTE1 ;options entry pre
8 N %,I
9 ;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
10 ;attach & disable never get here
11 S ^TMP($J,"XPD",DA)=XPDFL
12 ;if Menu linking or merge save menu mult. and process in FPOS code
13 I XPDFL>1 M ^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",19,OLDA,10) K ^XTMP("XPDI",XPDA,"KRN",19,OLDA,10)
14 ;if Menu link, XPDQUIT prevents data merge
15 I XPDFL=2 S XPDQUIT=1 Q
16 ;if this is new to the site then disable and quit
17 I $G(XPDNEW) D:XPDSET Q
18 .;quit if option already has out of order msg.
19 .Q:$P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)]""
20 .S $P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)=$P(XPDSET,U,3)
21 .D ADD^XQOO1($P(XPDSET,U,2),19,DA)
22 S I=^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),%=^DIC(19,DA,0)
23 ;$P(%,U,3)=out of order message, keep sending ooo msg
24 S:$P(I,U,3)="" $P(I,U,3)=$P(%,U,3)
25 ;if there is no new Security Key, save the old Key
26 S:$P(I,U,6)="" $P(I,U,6)=$P(%,U,6)
27 ;if there is no reverse key, save the old key and flag
28 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)
29 S ^XTMP("XPDI",XPDA,"KRN",19,OLDA,0)=I
30 ;if there is a new Description, kill the old Description
31 K:$O(^XTMP("XPDI",XPDA,"KRN",19,OLDA,1,0)) ^DIC(19,DA,1)
32 ;kill old RCPs (RPC)
33 K ^DIC(19,DA,"RPC")
34 ;if Menu Text, (U;1) is different, kill C x-ref
35 S I=$G(^DIC(19,DA,"U")) I I]"",I'=$G(^XTMP("XPDI",XPDA,"KRN",19,OLDA,"U")) K ^DIC(19,"C",I)
36 S I=0
37 ;XPDFL=3-merge menu items, Quit
38 ;the new menu items have already been saved into ^TMP, will restore in
39 ;the file post action as a relink
40 Q:XPDFL=3
41 ;we are replacing menu items, kill the old.
42 ;loop thru and kill "AD" x-ref., it will be reset with new options
43 F S I=$O(^DIC(19,DA,10,I)) Q:'I S %=+$G(^(I,0)) K:% ^DIC(19,"AD",%,DA,I)
44 ;kill Menus (10)
45 K ^DIC(19,DA,10)
46 Q
47OPTF2 ;options file post
48 N ACT,DA,DIK,I,X,Y,Y0
49 ;loop thru all the new incomming options
50 S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
51 .;if use as link then goto OPTFL, just update menus
52 .G:ACT=2 OPTFL
53 .;repoint Bulletin (220;1) and Mail Group (220;3)
54 .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
55 .;repoint RPC (RPC;1)
56 .S (I,X)=0 F S I=$O(^DIC(19,DA,"RPC",I)) Q:'I S Y0=$P($G(^(I,0)),U) D
57 ..S Y=$$LK("^XWB(8994)",Y0)
58 ..I 'Y K ^DIC(19,DA,"RPC",I) D BMES^XPDUTL(" RPC "_Y0_" in Option "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
59 ..S $P(^DIC(19,DA,"RPC",I,0),U)=Y,X=I_U_(X+1)
60 .S:X $P(^DIC(19,DA,"RPC",0),U,3,4)=X
61 .;repoint Package (0;12) and Help Frame (0;7)
62 .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
63OPTFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
64 .;merged, they could also be linked menu, but treat like merge
65 .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)
66 .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
67 .;also need to recount all menus and reset zeroth node, use X
68 .S (I,X)=0 F S I=$O(^DIC(19,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
69 ..I $L(Y0) D Q:'Y
70 ...S Y=$$LK("^DIC(19)",Y0)
71 ...K ^DIC(19,DA,10,I,U)
72 ...I 'Y K ^DIC(19,DA,10,I) D BMES^XPDUTL(" Option "_Y0_" in Menu "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
73 ...S $P(^DIC(19,DA,10,I,0),U)=Y
74 ..S X=I_U_(X+1)
75 .S:X $P(^DIC(19,DA,10,0),U,3,4)=X
76 .;re-index this option
77 .D IX1^DIK
78 K ^TMP($J,"XPD")
79 Q
80OPTDEL ;option delete
81 D DEL("^DIC(19,",DUZ)
82 D OPT^XPDIA2
83 Q
84PROF1 ;protocols file pre
85 K ^TMP($J,"XPD")
86 Q
87PROE1 ;protocols entry pre
88 G PROE1^XPDIA0
89 ;
90PROF2 ;protocols file post
91 N ACT,DA,DIK,I,X,Y,Y0
92 ;loop thru all the new incomming protocols
93 S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
94 .;if use as link then goto PROFL, just update menus
95 .G:ACT=2 PROFL
96 .;repoint Package (0;12)
97 .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
98 .;repoint File Link (5;1), its a variable pointer
99 .S Y0=$P($G(^ORD(101,DA,5)),U),Y=$P(Y0,";",2),Y0=$P(Y0,";")
100 .I Y0,$L(Y) S Y0=$O(@("^"_Y_"""B"","""_Y0_""",0)")),$P(^ORD(101,DA,5),U)=$S(Y0:Y0_";"_Y,1:"")
101 .;repoint HL7 fields, node 770
102 .S Y0=$G(^ORD(101,DA,770)) I $L(Y0) D S ^ORD(101,DA,770)=Y0
103 ..S $P(Y0,U)=$$LK("^HL(771)",$P(Y0,U)),$P(Y0,U,2)=$$LK("^HL(771)",$P(Y0,U,2))
104 ..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))
105 ..S $P(Y0,U,4)=$$LK("^HL(779.001)",$P(Y0,U,4)),$P(Y0,U,7)=$$LK("^HLCS(870)",$P(Y0,U,7))
106 ..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))
107 ..S $P(Y0,U,10)=$$LK("^HL(771.5)",$P(Y0,U,10))
108 .;loop thru Access and resolve (3;1), kill if it doesn't resolve
109 .S (I,X)=0 F S I=$O(^ORD(101,DA,3,I)) Q:'I S Y0=$P($G(^(I,0)),U) D
110 ..;Y0=.01 of Access(Security Key)
111 ..S Y=$$LK("^DIC(19.1)",Y0)
112 ..I 'Y K ^ORD(101,DA,3,I) D BMES^XPDUTL(" Key "_Y0_" in Protocol "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
113 ..S $P(^ORD(101,DA,3,I,0),U)=Y,X=I_U_(X+1)
114 .S:X $P(^ORD(101,DA,3,0),U,3,4)=X
115PROFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
116 .;merged, they are also linked menu, but treat like merge
117 .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)
118 .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
119 .;also need to recount all menus and reset zeroth node, use X
120 .S (I,X)=0 F S I=$O(^ORD(101,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
121 ..I $L(Y0) D Q:'Y
122 ...S Y=$$LK("^ORD(101)",Y0)
123 ...K ^ORD(101,DA,10,I,U)
124 ...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
125 ...S $P(^ORD(101,DA,10,I,0),U)=Y
126 ..S X=I_U_(X+1)
127 .S:X $P(^ORD(101,DA,10,0),U,3,4)=X
128 .;need to loop through ^TMP($J,"XPD",DA,775,I) these are subscribers that need to be
129 .;merged, they are also linked subscriber, but treat like merge
130 .S I=0 F S I=$O(^TMP($J,"XPD",DA,775,I)) Q:'I S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" SUBS(DA,X)
131 .;loop thru subscriber and repoint Option (0;1), text is on ^(U) node
132 .;also need to recount all menus and reset zeroth node, use X
133 .S (I,X)=0 F S I=$O(^ORD(101,DA,775,I)) Q:'I S Y0=$G(^(I,U)) D
134 ..I $L(Y0) D Q:'Y
135 ...S Y=$$LK("^ORD(101)",Y0)
136 ...K ^ORD(101,DA,775,I,U)
137 ...I 'Y K ^ORD(101,DA,775,I) D BMES^XPDUTL(" Protocol "_Y0_" in Protocol Subscriber "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
138 ...S $P(^ORD(101,DA,775,I,0),U)=Y
139 ..S X=I_U_(X+1)
140 .S:X $P(^ORD(101,DA,775,0),U,3,4)=X
141 .;re-index this option
142 .D IX1^DIK
143 K ^TMP($J,"XPD")
144 Q
145PRODEL ;option delete
146 D DEL("^ORD(101,",DUZ)
147 D PRO^XPDIA2
148 Q
149LK(GR,X) ;lookup, GR=global root, X=lookup value
150 Q:$G(X)="" ""
151 N I S I=$O(@GR@("B",X,0))
152 I I,$D(@GR@(I,0))#2 Q I
153 Q ""
154 ;
155ADD(XPDSDD,XPDSDA,X) ;add to multiple, XPDSDD=sub DD#, XPDSDA=DA, X=value
156 Q:$G(X)=""
157 N XPD
158 S XPD(XPDSDD,"?+1,"_XPDSDA_",",.01)=X
159 D UPDATE^DIE("E","XPD")
160 Q
161 ;this is used to add menu items to an option or protocol
162MENU(DA,X,X0) ;DA=ien of option/protocol, X=Menu item, X0=0 node of menu item
163 N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
164 S DIC=$S(XPDFIL=19:"^DIC(19,",1:"^ORD(101,")_DA_",10,",DIC(0)="L",DLAYGO=XPDFIL,(D0,DA(1))=DA
165 S:'$D(@(DIC_"0)")) @(DIC_"0)")=U_$P(^DD(XPDFIL,10,0),U,2)
166 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:"")
167 D ^DIC
168 Q
169 ;this is used to add subscriber items to a protocol
170SUBS(DA,X) ;DA=ien of protocol, X=subscriber
171 N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
172 S DIC="^ORD(101,"_DA_",775,",DIC(0)="L",DLAYGO=XPDFIL,(D0,DA(1))=DA
173 S:'$D(@(DIC_"0)")) @(DIC_"0)")=U_$P(^DD(XPDFIL,775,0),U,2)
174 D ^DIC
175 Q
176DEL(DIK,DUZ) ;delete
177 N DA,XPDI,XPDF
178 S XPDI=0,DUZ(0)="@",XPDF=+$P(DIK,"(",2)
179 F S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI D
180 .K ^TMP("DIFIXPT",$J) S DA=XPDI
181 .D ^DIK ;FIXPT^DIA3("D",XPDF,XPDI)
182 .I $D(^TMP("DIFIXPT",$J)) D WP^XPDUTL("^TMP(""DIFIXPT"",$J)")
183 Q
Note: See TracBrowser for help on using the repository browser.