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

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

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