XPDTA1 ;SFISC/RSD - Build Actions for Kernel Files Cont. ;06/24/2008
;;8.0;KERNEL;**44,68,85,131,302,399,507**;Jul 10, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root
;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
Q
HELP ;help frames #9.2
;remove Author (0;4), kill Editor (4;0) and under Object (10) kill "B" x-ref
S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,0),U,4)="",%=0 K ^(4),^(10,"B")
;loop thru Objects (10) and resolve (10;1), kill if it doesn't resolve
F S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
.S %2=$$PT^XPDTA("^MAG",+%1)
.I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%,0),U)=%2 Q
.K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)
;kill under Related Frame (2) "B" x-ref
K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,"B")
S %=0
;loop thru Related Frame (2) and resolve Related Frame (2;2)
;kill if it doesn't resolve
F S %=$O(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)) Q:'% S %1=$P($G(^(%,0)),U,2) D
.S %2=$$PT^XPDTA("^DIC(9.2)",%1)
.I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%,0),U,2)=%2 Q
.K ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)
Q
BUL ;bulletines #3.6
;kill Mailgroups (2)
K ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,2)
Q
KEY ;security keys entry action #19.1
;Repoint SUBORDINATE (3) and MUTUALLY EXCLUSIVE KEYS (5), kill "B" x-ref
N %,%1,%2 S %=0
F S %=$O(^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%)) Q:%'>0 S %1=+$G(^(%,0)) D
. S %2=$$PT^XPDTA("^DIC(19.1)",%1)
. I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%,0),U,1)=%2 Q
. K ^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%)
;kill "B" x-ref
K ^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,"B")
S %=0
F S %=$O(^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%)) Q:%'>0 S %1=+$G(^(%,0)) D
. S %2=$$PT^XPDTA("^DIC(19.1)",%1)
. I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%,0),U,1)=%2 Q
. K ^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%)
;kill "B" x-ref
K ^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,"B")
Q
MAILG ;MAIL GROUP #3.8
;remove REFERENCE COUNT (0;4), LAST REFERENCE (0;5), COORDINATOR (0;7)
S %=^XTMP("XPDT",XPDA,"KRN",3.8,DA,0),$P(%,U,4,5)="^",$P(%,U,7)="",^(0)=%
;remove ORGANIZER (3;1)
S %=$P($G(^XTMP("XPDT",XPDA,"KRN",3.8,DA,3)),U) S:% $P(^(3),U)=""
;kill MEMBER (1;0), AUTHORIZE SENDER (4;0), DISTRIBUTION LIST (7;0)
;p399 add MEMBERS-REMOTE (6;0)
K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,1),^(4),^(7),^(6)
;kill MEMBER GROUP "B" x-ref
K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,"B") S %=0
;loop thru MEMBER GROUP and resolve (5;0)
F S %=$O(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)) Q:'% S %1=$P($G(^(%,0)),U) D
.S %2=$$PT^XPDTA("^XMB(3.8)",%1)
.I $L(%2) S $P(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%,0),U)=%2 Q
.K ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)
Q
HLAP ;HL7 application parameter #771
S %=^XTMP("XPDT",XPDA,"KRN",771,DA,0)
;resolve MAIL GROUP (0;4)
S:$P(%,U,4) $P(%,U,4)=$$PT^XPDTA("^XMB(3.8)",$P(%,U,4))
;resolve COUNTRY CODE (0;7)
S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^HL(779.004)",$P(%,U,7))
S ^XTMP("XPDT",XPDA,"KRN",771,DA,0)=%
;resolve HL7 SEGMENT (SEG;0)
;kill "B"=name x-ref, it will be re-indexed when installed
I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG")) K ^("SEG","B") D
.;loop thru SEGs and resolve (SEG;1)
.S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%)) Q:'% S %1=$G(^(%,0)) D
..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
..;if can't resolve then delete
..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%) Q
..;save the SEG name
..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%,0),U)=%2
.Q
;resolve HL7 MESSAGE (MSG;0)
I $D(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG")) K ^("MSG","B") D
.;loop thru MSGs and resolve (MSG;1)
.S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%)) Q:'% S %1=$G(^(%,0)) D
..S %2=$$PT^XPDTA("^HL(771.3)",+%1)
..;if can't resolve then delete
..I %2="" K ^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%) Q
..;save the MSG name
..S $P(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%,0),U)=%2
.Q
Q
HLLLP ;HL7 lower level protocol #869.2
;patch HL*1.6*57 merged this file with 870
Q
HLLL ;HL7 logical link #870
S %=^XTMP("XPDT",XPDA,"KRN",870,DA,0)
;resolve INSTITUTION (0;2)
S:$P(%,U,2) $P(%,U,2)=$$PT^XPDTA("^DIC(4)",$P(%,U,2))
;resolve LLP TYPE (0;3)
S:$P(%,U,3) $P(%,U,3)=$$PT^XPDTA("^HLCS(869.1)",$P(%,U,3))
;resolve MAILMAN DOMAIN (0;7)
S:$P(%,U,7) $P(%,U,7)=$$PT^XPDTA("^DIC(4.2)",$P(%,U,7))
;remove all data except (0;1-3,7-8,21)
S %=$P(%,U,1,3)_"^^^^"_$P(%,U,7,8)_"^^^^^^^^^^^^^"_$P(%,U,21)
S ^XTMP("XPDT",XPDA,"KRN",870,DA,0)=%
;resolve MAIL GROUP (100;1)
S %=$P($G(^XTMP("XPDT",XPDA,"KRN",870,DA,100)),U)
S:% %=$$PT^XPDTA("^XMB(3.8)",%),$P(^XTMP("XPDT",XPDA,"KRN",870,DA,100),U)=%
;remove HLLP DEVICE (200;1)
I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,200)) S $P(^(200),U)=""
;remove X3.28 DEVICE (300;1)
I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,300)) S $P(^(300),U)=""
;remove Startup Node (400;6)
I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,400)) S $P(^(400),U,6)=""
;remove TCP/IP PORT OPENFAIL TIMEOUT (400;9)
I $D(^XTMP("XPDT",XPDA,"KRN",870,DA,400)) S $P(^(400),U,9)=""
;remove all queue multiples and pointers
K ^XTMP("XPDT",XPDA,"KRN",870,DA,1),^(2),^("IN QUEUE BACK POINTER"),^("IN QUEUE FRONT POINTER")
K ^XTMP("XPDT",XPDA,"KRN",870,DA,"OUT QUEUE BACK POINTER"),^("OUT QUEUE FRONT POINTER")
Q
HLOAP ;HLO application registry #779.2
;resolve APPLICATION SPECIFIC LISTENER (0;9)
S %=^XTMP("XPDT",XPDA,"KRN",779.2,DA,0)
S:$P(%,U,9) $P(%,U,9)=$$PT^XPDTA("^HLCS(870)",$P(%,U,9))
S ^XTMP("XPDT",XPDA,"KRN",779.2,DA,0)=%
;resolve Package File Link (2;1)
S %=^XTMP("XPDT",XPDA,"KRN",779.2,DA,2)
S:$P(%,U,1) $P(%,U,1)=$$PT^XPDTA("^DIC(9.4)",$P(%,U,1))
S ^XTMP("XPDT",XPDA,"KRN",779.2,DA,2)=%
Q
XPDTA1 ;SFISC/RSD - Build Actions for Kernel Files Cont. ;06/24/2008
+1 ;;8.0;KERNEL;**44,68,85,131,302,399,507**;Jul 10, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+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 QUIT
HELP ;help frames #9.2
+1 ;remove Author (0;4), kill Editor (4;0) and under Object (10) kill "B" x-ref
+2 SET $PIECE(^XTMP("XPDT",XPDA,"KRN",9.2,DA,0),U,4)=""
SET %=0
KILL ^(4),^(10,"B")
+3 ;loop thru Objects (10) and resolve (10;1), kill if it doesn't resolve
+4 FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%))
IF '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:1
+5 SET %2=$$PT^XPDTA("^MAG",+%1)
+6 IF $LENGTH(%2)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%,0),U)=%2
QUIT
+7 KILL ^XTMP("XPDT",XPDA,"KRN",9.2,DA,10,%)
End DoDot:1
+8 ;kill under Related Frame (2) "B" x-ref
+9 KILL ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,"B")
+10 SET %=0
+11 ;loop thru Related Frame (2) and resolve Related Frame (2;2)
+12 ;kill if it doesn't resolve
+13 FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%))
IF '%
QUIT
SET %1=$PIECE($GET(^(%,0)),U,2)
Begin DoDot:1
+14 SET %2=$$PT^XPDTA("^DIC(9.2)",%1)
+15 IF $LENGTH(%2)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%,0),U,2)=%2
QUIT
+16 KILL ^XTMP("XPDT",XPDA,"KRN",9.2,DA,2,%)
End DoDot:1
+17 QUIT
BUL ;bulletines #3.6
+1 ;kill Mailgroups (2)
+2 KILL ^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA,2)
+3 QUIT
KEY ;security keys entry action #19.1
+1 ;Repoint SUBORDINATE (3) and MUTUALLY EXCLUSIVE KEYS (5), kill "B" x-ref
+2 NEW %,%1,%2
SET %=0
+3 FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%))
IF %'>0
QUIT
SET %1=+$GET(^(%,0))
Begin DoDot:1
+4 SET %2=$$PT^XPDTA("^DIC(19.1)",%1)
+5 IF $LENGTH(%2)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%,0),U,1)=%2
QUIT
+6 KILL ^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,%)
End DoDot:1
+7 ;kill "B" x-ref
+8 KILL ^XTMP("XPDT",XPDA,"KRN",19.1,DA,3,"B")
+9 SET %=0
+10 FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%))
IF %'>0
QUIT
SET %1=+$GET(^(%,0))
Begin DoDot:1
+11 SET %2=$$PT^XPDTA("^DIC(19.1)",%1)
+12 IF $LENGTH(%2)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%,0),U,1)=%2
QUIT
+13 KILL ^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,%)
End DoDot:1
+14 ;kill "B" x-ref
+15 KILL ^XTMP("XPDT",XPDA,"KRN",19.1,DA,5,"B")
+16 QUIT
MAILG ;MAIL GROUP #3.8
+1 ;remove REFERENCE COUNT (0;4), LAST REFERENCE (0;5), COORDINATOR (0;7)
+2 SET %=^XTMP("XPDT",XPDA,"KRN",3.8,DA,0)
SET $PIECE(%,U,4,5)="^"
SET $PIECE(%,U,7)=""
SET ^(0)=%
+3 ;remove ORGANIZER (3;1)
+4 SET %=$PIECE($GET(^XTMP("XPDT",XPDA,"KRN",3.8,DA,3)),U)
IF %
SET $PIECE(^(3),U)=""
+5 ;kill MEMBER (1;0), AUTHORIZE SENDER (4;0), DISTRIBUTION LIST (7;0)
+6 ;p399 add MEMBERS-REMOTE (6;0)
+7 KILL ^XTMP("XPDT",XPDA,"KRN",3.8,DA,1),^(4),^(7),^(6)
+8 ;kill MEMBER GROUP "B" x-ref
+9 KILL ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,"B")
SET %=0
+10 ;loop thru MEMBER GROUP and resolve (5;0)
+11 FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%))
IF '%
QUIT
SET %1=$PIECE($GET(^(%,0)),U)
Begin DoDot:1
+12 SET %2=$$PT^XPDTA("^XMB(3.8)",%1)
+13 IF $LENGTH(%2)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%,0),U)=%2
QUIT
+14 KILL ^XTMP("XPDT",XPDA,"KRN",3.8,DA,5,%)
End DoDot:1
+15 QUIT
HLAP ;HL7 application parameter #771
+1 SET %=^XTMP("XPDT",XPDA,"KRN",771,DA,0)
+2 ;resolve MAIL GROUP (0;4)
+3 IF $PIECE(%,U,4)
SET $PIECE(%,U,4)=$$PT^XPDTA("^XMB(3.8)",$PIECE(%,U,4))
+4 ;resolve COUNTRY CODE (0;7)
+5 IF $PIECE(%,U,7)
SET $PIECE(%,U,7)=$$PT^XPDTA("^HL(779.004)",$PIECE(%,U,7))
+6 SET ^XTMP("XPDT",XPDA,"KRN",771,DA,0)=%
+7 ;resolve HL7 SEGMENT (SEG;0)
+8 ;kill "B"=name x-ref, it will be re-indexed when installed
+9 IF $DATA(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG"))
KILL ^("SEG","B")
Begin DoDot:1
+10 ;loop thru SEGs and resolve (SEG;1)
+11 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%))
IF '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:2
+12 SET %2=$$PT^XPDTA("^HL(771.3)",+%1)
+13 ;if can't resolve then delete
+14 IF %2=""
KILL ^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%)
QUIT
+15 ;save the SEG name
+16 SET $PIECE(^XTMP("XPDT",XPDA,"KRN",771,DA,"SEG",%,0),U)=%2
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;resolve HL7 MESSAGE (MSG;0)
+19 IF $DATA(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG"))
KILL ^("MSG","B")
Begin DoDot:1
+20 ;loop thru MSGs and resolve (MSG;1)
+21 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%))
IF '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:2
+22 SET %2=$$PT^XPDTA("^HL(771.3)",+%1)
+23 ;if can't resolve then delete
+24 IF %2=""
KILL ^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%)
QUIT
+25 ;save the MSG name
+26 SET $PIECE(^XTMP("XPDT",XPDA,"KRN",771,DA,"MSG",%,0),U)=%2
End DoDot:2
+27 QUIT
End DoDot:1
+28 QUIT
HLLLP ;HL7 lower level protocol #869.2
+1 ;patch HL*1.6*57 merged this file with 870
+2 QUIT
HLLL ;HL7 logical link #870
+1 SET %=^XTMP("XPDT",XPDA,"KRN",870,DA,0)
+2 ;resolve INSTITUTION (0;2)
+3 IF $PIECE(%,U,2)
SET $PIECE(%,U,2)=$$PT^XPDTA("^DIC(4)",$PIECE(%,U,2))
+4 ;resolve LLP TYPE (0;3)
+5 IF $PIECE(%,U,3)
SET $PIECE(%,U,3)=$$PT^XPDTA("^HLCS(869.1)",$PIECE(%,U,3))
+6 ;resolve MAILMAN DOMAIN (0;7)
+7 IF $PIECE(%,U,7)
SET $PIECE(%,U,7)=$$PT^XPDTA("^DIC(4.2)",$PIECE(%,U,7))
+8 ;remove all data except (0;1-3,7-8,21)
+9 SET %=$PIECE(%,U,1,3)_"^^^^"_$PIECE(%,U,7,8)_"^^^^^^^^^^^^^"_$PIECE(%,U,21)
+10 SET ^XTMP("XPDT",XPDA,"KRN",870,DA,0)=%
+11 ;resolve MAIL GROUP (100;1)
+12 SET %=$PIECE($GET(^XTMP("XPDT",XPDA,"KRN",870,DA,100)),U)
+13 IF %
SET %=$$PT^XPDTA("^XMB(3.8)",%)
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",870,DA,100),U)=%
+14 ;remove HLLP DEVICE (200;1)
+15 IF $DATA(^XTMP("XPDT",XPDA,"KRN",870,DA,200))
SET $PIECE(^(200),U)=""
+16 ;remove X3.28 DEVICE (300;1)
+17 IF $DATA(^XTMP("XPDT",XPDA,"KRN",870,DA,300))
SET $PIECE(^(300),U)=""
+18 ;remove Startup Node (400;6)
+19 IF $DATA(^XTMP("XPDT",XPDA,"KRN",870,DA,400))
SET $PIECE(^(400),U,6)=""
+20 ;remove TCP/IP PORT OPENFAIL TIMEOUT (400;9)
+21 IF $DATA(^XTMP("XPDT",XPDA,"KRN",870,DA,400))
SET $PIECE(^(400),U,9)=""
+22 ;remove all queue multiples and pointers
+23 KILL ^XTMP("XPDT",XPDA,"KRN",870,DA,1),^(2),^("IN QUEUE BACK POINTER"),^("IN QUEUE FRONT POINTER")
+24 KILL ^XTMP("XPDT",XPDA,"KRN",870,DA,"OUT QUEUE BACK POINTER"),^("OUT QUEUE FRONT POINTER")
+25 QUIT
HLOAP ;HLO application registry #779.2
+1 ;resolve APPLICATION SPECIFIC LISTENER (0;9)
+2 SET %=^XTMP("XPDT",XPDA,"KRN",779.2,DA,0)
+3 IF $PIECE(%,U,9)
SET $PIECE(%,U,9)=$$PT^XPDTA("^HLCS(870)",$PIECE(%,U,9))
+4 SET ^XTMP("XPDT",XPDA,"KRN",779.2,DA,0)=%
+5 ;resolve Package File Link (2;1)
+6 SET %=^XTMP("XPDT",XPDA,"KRN",779.2,DA,2)
+7 IF $PIECE(%,U,1)
SET $PIECE(%,U,1)=$$PT^XPDTA("^DIC(9.4)",$PIECE(%,U,1))
+8 SET ^XTMP("XPDT",XPDA,"KRN",779.2,DA,2)=%
+9 QUIT
