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/XPDTA.m@ 1713

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006
2 ;;8.0;KERNEL;**15,44,58,131,229,393**;Jul 10, 1995;Build 12
3 Q
4 ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
5 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
6OPT ;options
7 N %,%1,%2
8 ;if link, kill everything and just process the menu items
9 I XPDFL=2 D G OPTT
10 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%)
11 ;resolve Package (0;12), remove Creator (0;5)
12 S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
13 ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
14 S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200)
15 ;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
16 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
17 ;resolve RPC (RPC;0), must be type Broker
18 I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D
19 .;kill "B"=name x-ref, it will be re-indexed when installed
20 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
21 .;loop thru RPCs and resolve (RPC;1)
22 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D
23 ..S %2=$$PT("^XWB(8994)",+%1)
24 ..;if can't resolve then delete
25 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q
26 ..;save the RPC name
27 ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
28 .Q
29OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu,
30 ;extended action, limited, window suite
31 I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q
32 ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
33 K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
34 ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
35 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
36 .S %2=$$PT("^DIC(19)",+%1)
37 .;items must be sent by themselves, check "B" x-ref
38 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q
39 .;if I couldn't resolve this option, then kill it
40 .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
41 Q
42PRO ;protocols
43 N %,%1,%2
44 ;if link, kill everything and just process the menu items
45 I XPDFL=2 D G PROT
46 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%)
47 ;resolve Package (0;12), remove Creator (0;5)
48 S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
49 ;kill under Menus (10), "B"=name, "C"=synonyms
50 S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=%
51 ;resolve File Link (5;1), its a variable pointer
52 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2)
53 I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1
54 ;resolve HL7 fields, node 770
55 S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
56 .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2))
57 .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11))
58 .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7))
59 .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9))
60 .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10))
61PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
62 ;kill under Menus (10), "B"=name, "C"=synonyms
63 I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C")
64 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
65 .;%2=.01 of Menu(protocol)
66 .S %2=$$PT("^ORD(101)",+%1)
67 .;Menu must also be sent by itself, check "B" x-ref
68 .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q
69 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
70 ;If type is Event Driver and sending Subscribers (775)
71 I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D
72 . ;kill Menu multiple and Subscriber x-ref "B"=name
73 . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B")
74 . ;loop thru 775=Subscribers and resolve pointer (775;1)
75 . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D
76 .. ;%2=.01 of subscriber(protocol)
77 .. S %2=$$PT("^ORD(101)",+%1)
78 .. ;protocol must also be sent by itself, check "B" x-ref
79 .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q
80 .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)
81 ;quit if no Access multiple
82 Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B")
83 ;loop thru Access and resolve (3;1), kill if it doesn't resolve
84 S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D
85 .;%2=.01 of Menu(protocol)
86 .S %2=$$PT("^DIC(19.1)",+%1)
87 .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q
88 .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
89 Q
90RTNE ;routine entry build action
91 N %,X,XPD
92 ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
93 ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
94 ;Build file
95 S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1)
96 Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=%
97 K ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
98 Q
99RTNF ;routine file build action
100 N X,Y,% S Y=0
101 ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
102 ;deleted at site, move name field to RTN node
103 F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D
104 .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
105 ;kill everything
106 K ^XTMP("XPDT",XPDA,"KRN",9.8)
107 Q
108PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value
109 Q:'DA ""
110 I $D(@GR@(+DA,0))#2 Q $P(^(0),U)
111 Q ""
112 ;
113LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file
114 ;XPD = 0-load, 1-delete, 2-skip, returns checksum
115 ;quit if routine is already saved
116 Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3)
117 N DIF,XCNP,%N,%A,FDA,IEN,LN2
118 S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0
119 X ^%ZOSF("LOAD")
120 S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0)
121 S IEN=$$FIND1^DIC(9.8,"","X",X)
122 ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
123 S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X)))
124 S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece
125 S ^XTMP("XPDT",XPDA,"RTN",X)=XPD
126 ;update count node
127 S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
128 N XUA,XUB S (XUA,XUB)=""
129 ;Update Dev Patch field in Routine file
130 I IEN D
131 . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2)
132 . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB
133 . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5)
134 . D UPDATE^DIE("","FDA","IEN")
135 Q %N
Note: See TracBrowser for help on using the repository browser.