XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36
;;8.0;KERNEL;**201,498,672**;Jul 10, 1995;Build 28
;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,
;
PAR1E1 ;PARAMETER DEFINITION file 8989.51: entry post
N XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT
S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
D PAR51(DA) ;Handle the entry from 8989.51
S PT=$S($E($G(^XTV(8989.51,DA,1)))="P":$P(^(1),U,2),1:"") ;Data Type & Value - check if pointer in for loop
S:PT]"" PT=$S(PT:$$GR^XPDTA(PT),1:"") ;PT=file # of pointed to file from parm def.
;Now find any entrys in 8989.5 to transport, because we point to them
S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3)
Q:'XP3 ;No package file link
F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance
. F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry
. . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1)
. . S XP3=^XTV(8989.5,XP1,0),XP4=$G(^(1)) ;param def.
. . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2))
. . I PT]"",XP4>0 S $P(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4) ;Data Type pointer - resolve
. . Q ;Will redo the ENT at other end.
Q
;
PAR51(DA) ;Fix one 8989.51 entry in transport global
;Called from both PAR1E1 and PAR2E1
N XP,XP1,XP2,XP3,VP,PN,ROOT
S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
;Don't bring X-ref
K @ROOT@(8989.51,DA,30,"B"),^("AG")
S XP=0
;Entries in the file will be maintained by Toolkit patches.
Q
;
PAR2E1 ;PARAMETER file 8989.52 entry post
N XP1,XP2,XP3,ROOT
S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN"))
;Resolve USE INSTANCE OF
S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3
;Resolve PARAMETERS
S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref
F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D
. S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2)
. I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2)
. I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1)
. S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3
. ;Now to move the entries this points to.
. I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2)
. Q
Q
XULM ;XULM LOCK DICTIONARY file 8993
N XP1,XP2
;resolve PACKAGE
S XP1=$P($G(^XTMP("XPDT",XPDA,"KRN",8993,DA,1)),U)
S:XP1 $P(^XTMP("XPDT",XPDA,"KRN",8993,DA,1),U)=$$PT^XPDTA("^DIC(9.4)",XP1)
;kill X-ref
K ^XTMP("XPDT",XPDA,"KRN",8993,2,"B"),^XTMP("XPDT",XPDA,"KRN",8993,3,"B"),^("C")
Q
;
ENT ;ENTITY file 1.5
N %,%1
;Loop thru ITEM multiple and resolve ENTITY (0;8)
S %1=0 F S %1=$O(^XTMP("XPDT",XPDA,"KRN",1.5,DA,1,%1)) Q:'%1 S %=$G(^(%1,0)) D:$P(%,U,8)
. S $P(%,U,8)=$$PT^XPDTA("^DDE",$P(%,U,8)),^XTMP("XPDT",XPDA,"KRN",1.5,DA,1,%1,0)=%
Q
;
POL ;POLICY file 1.6
N %,%1,%2
;if link, kill everything and just process the MEMBERS(10)
I XPDFL=2 D G POLM
.S %1=0 F S %1=$O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1)) Q:'%1 K:%1'=10 ^(%)
.Q
;resolve ATTRIBUTE FUNCTION (0;4) and RESULT FUNCTION (0;7)
S %=^XTMP("XPDT",XPDA,"KRN",1.6,DA,0) D S ^XTMP("XPDT",XPDA,"KRN",1.6,DA,0)=%
.F %1=4,7 S %2=$P(%,U,%1),$P(%,U,%1)=$$PT^XPDTA("^DIAC(1.62)",%2)
.Q
;resolve DENY OBLIGATION (7) and PERMIT OBLIGATION (8)
F %1=7,8 S %=$G(^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1)) D:$L(%)
.S %2=$P(%,U),$P(%,U)=$$PT^XPDTA("^DIAC(1.62)",%2)
.S ^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1)=%
.Q
;kill under TAGETS (2) ^("B"),^("AKEY")
I $O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,2,0)) K ^("B"),^("AKEY")
;check if CONDITIONS (3) are sent, if yes then kill ^("B") and process
I $O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,0)) K ^("B") D
.;loop thru and resolve FUNCTION (0;2)
.S %1=0 F S %1=$O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,%1)) Q:'%1 S %=$G(^(%1,0)) D
..S %2=$P(%,U,2) Q:'%2
..S $P(%,U,2)=$$PT^XPDTA("^DIAC(1.62)",%2)
..S ^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,%1,0)=%
.Q
POLM ;loop thru 10=MEMEBERS and resolve MEMBER (0;1), kill if it doesn't resolve
Q:'$O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,0))
;kill under MEMBERS (10), "B"=name, "AC"=SEQUENCE
K ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,"B"),^("AC")
S %1=0 F S %1=$O(^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1)) Q:'%1 S %=$G(^(%1,0)) D
.S %2=$$PT^XPDTA("^DIAC(1.6)",+%)
.;MEMBER must also be sent by itself, check "B" x-ref, save text on U node
.I $L(%2),$D(^XPD(9.6,XPDA,"KRN",1.6,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1,U)=%2 Q
.K ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1)
.Q
Q
;
POLE ;EVENT #1.61
N %,%1,%2
S %=^XTMP("XPDT",XPDA,"KRN",1.61,DA,0)
;resolve POLICY (0;5)
S %1=$P(%,U,5) Q:'%1
S %2=$$PT^XPDTA("^DIAC(1.6)",%1),$P(%,U,5)=%2,^XTMP("XPDT",XPDA,"KRN",1.61,DA,0)=%
Q
;
POLF ;FUNCTION #1.62
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDTA2 4932 printed Sep 23, 2025@19:40:37 Page 2
XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36
+1 ;;8.0;KERNEL;**201,498,672**;Jul 10, 1995;Build 28
+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 ;
PAR1E1 ;PARAMETER DEFINITION file 8989.51: entry post
+1 NEW XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT
+2 SET ROOT=$NAME(^XTMP("XPDT",XPDA,"KRN"))
+3 ;Handle the entry from 8989.51
DO PAR51(DA)
+4 ;Data Type & Value - check if pointer in for loop
SET PT=$SELECT($EXTRACT($GET(^XTV(8989.51,DA,1)))="P":$PIECE(^(1),U,2),1:"")
+5 ;PT=file # of pointed to file from parm def.
if PT]""
SET PT=$SELECT(PT:$$GR^XPDTA(PT),1:"")
+6 ;Now find any entrys in 8989.5 to transport, because we point to them
+7 SET XP=0
SET XP3=$PIECE(^XPD(9.6,XPDA,0),U,2)
SET VP=XP3_";DIC(9.4,"
SET PN=$$PT^XPDTA("^DIC(9.4)",XP3)
+8 ;No package file link
if 'XP3
QUIT
+9 ;Instance
FOR
SET XP=$ORDER(^XTV(8989.5,"AC",DA,VP,XP))
SET XP1=0
if 'XP
QUIT
Begin DoDot:1
+10 ;entry
FOR
SET XP1=$ORDER(^XTV(8989.5,"AC",DA,VP,XP,XP1))
if 'XP1
QUIT
Begin DoDot:2
+11 MERGE ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1)
+12 ;param def.
SET XP3=^XTV(8989.5,XP1,0)
SET XP4=$GET(^(1))
+13 SET $PIECE(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$PIECE(XP3,U,2))
+14 ;Data Type pointer - resolve
IF PT]""
IF XP4>0
SET $PIECE(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4)
+15 ;Will redo the ENT at other end.
QUIT
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
PAR51(DA) ;Fix one 8989.51 entry in transport global
+1 ;Called from both PAR1E1 and PAR2E1
+2 NEW XP,XP1,XP2,XP3,VP,PN,ROOT
+3 SET ROOT=$NAME(^XTMP("XPDT",XPDA,"KRN"))
+4 ;Don't bring X-ref
+5 KILL @ROOT@(8989.51,DA,30,"B"),^("AG")
+6 SET XP=0
+7 ;Entries in the file will be maintained by Toolkit patches.
+8 QUIT
+9 ;
PAR2E1 ;PARAMETER file 8989.52 entry post
+1 NEW XP1,XP2,XP3,ROOT
+2 SET ROOT=$NAME(^XTMP("XPDT",XPDA,"KRN"))
+3 ;Resolve USE INSTANCE OF
+4 SET XP2=$PIECE(^XTV(8989.52,DA,0),U,4)
SET XP3=""
IF XP2
SET XP3=$$PT^XPDTA($NAME(^XTV(8989.51)),XP2)
+5 IF $LENGTH(XP3)
SET $PIECE(@ROOT@(8989.52,DA,0),U,4)=XP3
+6 ;Resolve PARAMETERS
+7 ;Drop X-ref
SET XP1=0
KILL ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B")
+8 FOR
SET XP1=$ORDER(^XTV(8989.52,DA,10,XP1))
SET XP3=""
if 'XP1
QUIT
Begin DoDot:1
+9 SET XP2=$PIECE(^XTV(8989.52,DA,10,XP1,0),U,2)
+10 IF XP2
SET XP3=$$PT^XPDTA($NAME(^XTV(8989.51)),XP2)
+11 IF '$LENGTH(XP3)
KILL @ROOT@(8989.52,DA,10,XP1)
+12 SET $PIECE(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3
+13 ;Now to move the entries this points to.
+14 IF '$DATA(@ROOT@(8989.51,XP2))
MERGE @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2)
DO PAR51(XP2)
+15 QUIT
End DoDot:1
+16 QUIT
XULM ;XULM LOCK DICTIONARY file 8993
+1 NEW XP1,XP2
+2 ;resolve PACKAGE
+3 SET XP1=$PIECE($GET(^XTMP("XPDT",XPDA,"KRN",8993,DA,1)),U)
+4 if XP1
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",8993,DA,1),U)=$$PT^XPDTA("^DIC(9.4)",XP1)
+5 ;kill X-ref
+6 KILL ^XTMP("XPDT",XPDA,"KRN",8993,2,"B"),^XTMP("XPDT",XPDA,"KRN",8993,3,"B"),^("C")
+7 QUIT
+8 ;
ENT ;ENTITY file 1.5
+1 NEW %,%1
+2 ;Loop thru ITEM multiple and resolve ENTITY (0;8)
+3 SET %1=0
FOR
SET %1=$ORDER(^XTMP("XPDT",XPDA,"KRN",1.5,DA,1,%1))
if '%1
QUIT
SET %=$GET(^(%1,0))
if $PIECE(%,U,8)
Begin DoDot:1
+4 SET $PIECE(%,U,8)=$$PT^XPDTA("^DDE",$PIECE(%,U,8))
SET ^XTMP("XPDT",XPDA,"KRN",1.5,DA,1,%1,0)=%
End DoDot:1
+5 QUIT
+6 ;
POL ;POLICY file 1.6
+1 NEW %,%1,%2
+2 ;if link, kill everything and just process the MEMBERS(10)
+3 IF XPDFL=2
Begin DoDot:1
+4 SET %1=0
FOR
SET %1=$ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1))
if '%1
QUIT
if %1'=10
KILL ^(%)
+5 QUIT
End DoDot:1
GOTO POLM
+6 ;resolve ATTRIBUTE FUNCTION (0;4) and RESULT FUNCTION (0;7)
+7 SET %=^XTMP("XPDT",XPDA,"KRN",1.6,DA,0)
Begin DoDot:1
+8 FOR %1=4,7
SET %2=$PIECE(%,U,%1)
SET $PIECE(%,U,%1)=$$PT^XPDTA("^DIAC(1.62)",%2)
+9 QUIT
End DoDot:1
SET ^XTMP("XPDT",XPDA,"KRN",1.6,DA,0)=%
+10 ;resolve DENY OBLIGATION (7) and PERMIT OBLIGATION (8)
+11 FOR %1=7,8
SET %=$GET(^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1))
if $LENGTH(%)
Begin DoDot:1
+12 SET %2=$PIECE(%,U)
SET $PIECE(%,U)=$$PT^XPDTA("^DIAC(1.62)",%2)
+13 SET ^XTMP("XPDT",XPDA,"KRN",1.6,DA,%1)=%
+14 QUIT
End DoDot:1
+15 ;kill under TAGETS (2) ^("B"),^("AKEY")
+16 IF $ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,2,0))
KILL ^("B"),^("AKEY")
+17 ;check if CONDITIONS (3) are sent, if yes then kill ^("B") and process
+18 IF $ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,0))
KILL ^("B")
Begin DoDot:1
+19 ;loop thru and resolve FUNCTION (0;2)
+20 SET %1=0
FOR
SET %1=$ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,%1))
if '%1
QUIT
SET %=$GET(^(%1,0))
Begin DoDot:2
+21 SET %2=$PIECE(%,U,2)
if '%2
QUIT
+22 SET $PIECE(%,U,2)=$$PT^XPDTA("^DIAC(1.62)",%2)
+23 SET ^XTMP("XPDT",XPDA,"KRN",1.6,DA,3,%1,0)=%
End DoDot:2
+24 QUIT
End DoDot:1
POLM ;loop thru 10=MEMEBERS and resolve MEMBER (0;1), kill if it doesn't resolve
+1 if '$ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,0))
QUIT
+2 ;kill under MEMBERS (10), "B"=name, "AC"=SEQUENCE
+3 KILL ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,"B"),^("AC")
+4 SET %1=0
FOR
SET %1=$ORDER(^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1))
if '%1
QUIT
SET %=$GET(^(%1,0))
Begin DoDot:1
+5 SET %2=$$PT^XPDTA("^DIAC(1.6)",+%)
+6 ;MEMBER must also be sent by itself, check "B" x-ref, save text on U node
+7 IF $LENGTH(%2)
IF $DATA(^XPD(9.6,XPDA,"KRN",1.6,"NM","B",%2))
SET ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1,U)=%2
QUIT
+8 KILL ^XTMP("XPDT",XPDA,"KRN",1.6,DA,10,%1)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
POLE ;EVENT #1.61
+1 NEW %,%1,%2
+2 SET %=^XTMP("XPDT",XPDA,"KRN",1.61,DA,0)
+3 ;resolve POLICY (0;5)
+4 SET %1=$PIECE(%,U,5)
if '%1
QUIT
+5 SET %2=$$PT^XPDTA("^DIAC(1.6)",%1)
SET $PIECE(%,U,5)=%2
SET ^XTMP("XPDT",XPDA,"KRN",1.61,DA,0)=%
+6 QUIT
+7 ;
POLF ;FUNCTION #1.62
+1 QUIT
