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/XPDTA1.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1XPDTA1 ;SFISC/RSD - Build Actions for Kernel Files Cont. ;05/05/2003 13:42
2 ;;8.0;KERNEL;**44,68,85,131,302**;Jul 10, 1995
3 Q
4 ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root
5 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
6 Q
7HELP ;help frames #9.2
8 ;remove Author (0;4), kill Editor (4;0) and under Object (10) kill "B" x-ref
9 S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,0),U,4)="",%=0 K ^(4),^(10,"B")
10 ;loop thru Objects (10) and resolve (10;1), kill if it doesn't resolve
11 F S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
12 .S %2=$$PT^XPDTA("^MAG",+%1)
13 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%,0),U)=%2 Q
14 .K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)
15 ;kill under Related Frame (2) "B" x-ref
16 K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,"B") S %=0
17 ;loop thru Related Frame (2) and resolve Related Frame (2;2)
18 ;kill if it doesn't resolve
19 F S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)) Q:'% S %1=$P($G(^(%,0)),U,2) D
20 .S %2=$$PT^XPDTA("^DIC(9.2)",%1)
21 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%,0),U,2)=%2 Q
22 .K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)
23 Q
24BUL ;bulletines #3.6
25 ;kill Mailgroups (2)
26 K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,2)
27 Q
28KEY ;security keys entry action #19
29 ;Repoint SUBORDINATE (3) and MUTUALLY EXCLUSIVE KEYS (5).
30 N %,%1,%2 S %=0
31 F S %=$O(^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,3,%)) Q:%'>0 S %1=+$G(^(%,0)) D
32 . S %2=$$PT^XPDTA("^DIC("_XPDFILE_")",%1)
33 . I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,3,%,0),U,1)=%2 Q
34 . K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,3,%)
35 S %=0
36 F S %=$O(^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,5,%)) Q:%'>0 S %1=+$G(^(%,0)) D
37 . S %2=$$PT^XPDTA("^DIC("_XPDFILE_")",%1)
38 . I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,5,%,0),U,1)=%2 Q
39 . K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,5,%)
40 Q
41MAILG ;MAIL GROUP #3.8
42 ;remove REFERENCE COUNT (0;4), LAST REFERENCE (0;5), COORDINATOR (0;7)
43 S %=^XTMP("XPDT",XPDA,"KRN",3.8,DA,0),$P(%,U,4,5)="^",$P(%,U,7)="",^(0)=%
44 ;remove ORGANIZER (3;1)
45 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",3.8,DA,3)),U) S:% $P(^(3),U)=""
46 ;kill MEMBER (1;0), AUTHORIZE SENDER (4;0), DISTRIBUTION LIST (7;0)
47 K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,1),^(4),^(7)
48 ;kill MEMBER GROUP "B" x-ref
49 K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,"B") S %=0
50 ;loop thru MEMBER GROUP and resolve (5;0)
51 F S %=$O(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)) Q:'% S %1=$P($G(^(%,0)),U) D
52 .S %2=$$PT^XPDTA("^XMB(3.8)",%1)
53 .I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%,0),U)=%2 Q
54 .K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)
55 Q
56HLAP ;HL7 application parameter #771
57 S %=^XTMP("XPDT",XPDA,"KRN",771,DA,0)
58 ;resolve MAIL GROUP (0;4)
59 S:$P(%,U,4) $P(%,U,4)=$$PT^XPDTA("^XMB(3.8)",$P(%,U,4))
60 ;resolve COUNTRY CODE (0;7)
61 S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^HL(779.004)",$P(%,U,7))
62 S ^XTMP("XPDT",XPDA,"KRN",771,DA,0)=%
63 ;resolve HL7 SEGMENT (SEG;0)
64 ;kill "B"=name x-ref, it will be re-indexed when installed
65 I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG")) K ^("SEG","B") D
66 .;loop thru SEGs and resolve (SEG;1)
67 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%)) Q:'% S %1=$G(^(%,0)) D
68 ..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
69 ..;if can't resolve then delete
70 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%) Q
71 ..;save the SEG name
72 ..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%,0),U)=%2
73 .Q
74 ;resolve HL7 MESSAGE (MSG;0)
75 I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG")) K ^("MSG","B") D
76 .;loop thru MSGs and resolve (MSG;1)
77 .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%)) Q:'% S %1=$G(^(%,0)) D
78 ..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
79 ..;if can't resolve then delete
80 ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%) Q
81 ..;save the MSG name
82 ..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%,0),U)=%2
83 .Q
84 Q
85HLLLP ;HL7 lower level protocol #869.2
86 ;patch HL*1.6*57 merged this file with 870
87 Q
88HLLL ;HL7 logical link #870
89 S %=^XTMP("XPDT",XPDA,"KRN",870,DA,0)
90 ;resolve INSTITUTION (0;2)
91 S:$P(%,U,2) $P(%,U,2)=$$PT^XPDTA("^DIC(4)",$P(%,U,2))
92 ;resolve LLP TYPE (0;3)
93 S:$P(%,U,3) $P(%,U,3)=$$PT^XPDTA("^HLCS(869.1)",$P(%,U,3))
94 ;resolve DOMAIN (0;7)
95 S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^DIC(4.2)",$P(%,U,7))
96 ;remove all data except (0;1-3,7,21)
97 S %=$P(%,U,1,3)_"^^^^"_$P(%,U,7)_"^^^^^^^^^^^^^^"_$P(%,U,21)
98 S ^XTMP("XPDT",XPDA,"KRN",870,DA,0)=%
99 ;resolve MAIL GROUP (100;1)
100 S %=$P($G(^XTMP("XPDT",XPDA,"KRN",870,DA,100)),U)
101 S:% %=$$PT^XPDTA("^XMB(3.8)",%),$P(^XTMP("XPDT",XPDA,"KRN",870,DA,100),U)=%
102 ;remove HLLP DEVICE (200;1)
103 I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,200)) S $P(^(200),U)=""
104 ;remove X3.28 DEVICE (300;1)
105 I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,300)) S $P(^(300),U)=""
106 ;remove Startup Node (400;6)
107 I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,400)) S $P(^(400),U,6)=""
108 ;remove all queue multiples and pointers
109 K ^XTMP("XPDT",XPDA,"KRN",870,DA,1),^(2),^("IN QUEUE BACK POINTER"),^("IN QUEUE FRONT POINTER")
110 K ^XTMP("XPDT",XPDA,"KRN",870,DA,"OUT QUEUE BACK POINTER"),^("OUT QUEUE FRONT POINTER")
111 Q
Note: See TracBrowser for help on using the repository browser.