| 1 | XPDTA1 ;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
|
---|
| 7 | HELP ;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
|
---|
| 24 | BUL ;bulletines #3.6
|
---|
| 25 | ;kill Mailgroups (2)
|
---|
| 26 | K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,2)
|
---|
| 27 | Q
|
---|
| 28 | KEY ;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
|
---|
| 41 | MAILG ;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
|
---|
| 56 | HLAP ;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
|
---|
| 85 | HLLLP ;HL7 lower level protocol #869.2
|
---|
| 86 | ;patch HL*1.6*57 merged this file with 870
|
---|
| 87 | Q
|
---|
| 88 | HLLL ;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
|
---|