XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13
;;8.0;KERNEL;**201,302,393,498,672**;Jul 10, 1995;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
;XPDNM=package name, XPDA=ien in ^XPD(9.6,
;DA=ien in file, OLDA= ien in ^XTMP
;
PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51
;Now load any entries from 8989.5
N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT
S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package
Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0))
S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package
S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5))
F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D
. S XP1=@ROOT@(OLDA,0)
. S $P(XP1,U,1)=PE_";DIC(9.4," ;entity
. S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2))
. S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
. ;Remove the current entry if we have one
. I DA>0 S DIK="^XTV(8989.5," D ^DIK
. ;Otherwise Add the zero node, See that we have a IEN
. I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
. Q:'DA ;don't have a entry
. ;Merge the date ;with IHS fix
. M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
. S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers
. ;Get Definition and check if Data Type is pointer, then get pointed to global ref.
. S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P"
. . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2)
. . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value
. . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3
. ;X-ref it
. S DIK="^XTV(8989.5," D IX1^DIK
Q
;
LKPAR(ENT,PAR,INST) ;Lookup an entry
Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
;
ADDPAR(ENT,PAR,INST) ;Add a parameter instance
N FDA,FDAIEN,DIERR
S FDA(8989.5,"+1,",.01)=ENT
S FDA(8989.5,"+1,",.02)=PAR
S FDA(8989.5,"+1,",.03)=INST
D UPDATE^DIE("","FDA","FDAIEN","DIERR")
Q
;
PAR1F1 ;PARAMETER File 8989.51: file Pre
Q
PAR1E1 ;PARAMETER file 8989.51: entry pre
N XP1,XP2,XP3
S ^TMP($J,"XPD",DA)=""
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20)
;Kill any old Allowable entries
K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30)
Q
PAR1F2 ;PARAMETER file 8989.51: file post
N XPD,DIK,DA
S DA=0
F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
. S DIK="^XTV(8989.51," D IX1^DIK
D PAR0F2 ;Go load the entries from 8989.5
Q
PAR1DEL(RT) ;Delete Parameter Def entries
D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers
D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries
Q
;
PAR2F1 ;PARAMETER TEMPLATE File 8989.52: file Pre
K ^TMP($J,"XPD")
Q
PAR2E1 ;PARAMETER TEMPLATE file 8989.52: entry Pre
N XP1,XP2,ROOT
S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52))
S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of
;Because we change the transport global see that a restart will work
I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
S XP1=0
F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D
. S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter
. I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
. Q
;kill the Parameter multiple at the site
K ^XTV(8989.52,DA,10)
Q
PAR2F2 ;PARAMETER TEMPLATE file 8989.52: file Post
Q
PAR2DEL(RT) ;Delete Parameter Templates
D DELIEN^XPDUTL1(8989.52,RT)
Q
XULM ;XULM LOCK DICTIONARY file 8993; entry Pre
N XP1,XP2,ROOT
S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8993))
;repoint PACKAGE (1;1)
S XP1=$P($G(@ROOT@(OLDA,1)),U)
I XP1]"" S XP1=$$LK^XPDIA("^DIC(9.4)",XP1),$P(@ROOT@(OLDA,1),U)=XP1
;check WP fields, if new then delete old at site
;USAGE #4
K:$O(@ROOT@(OLDA,4,0)) ^XLM(8993,DA,4)
;DESCRIPTION #2, under COMPUTABLE FILE REFERENCES #3 multiple
;XP1 is a file number and is the same on all systems
S XP1=0
F S XP1=$O(@ROOT@(OLDA,3,XP1)) Q:'XP1 I $O(^(XP1,2,0)) K ^XLM(8993,DA,3,XP1,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIA3 4146 printed Sep 23, 2025@19:39:39 Page 2
XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13
+1 ;;8.0;KERNEL;**201,302,393,498,672**;Jul 10, 1995;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
+5 ;XPDNM=package name, XPDA=ien in ^XPD(9.6,
+6 ;DA=ien in file, OLDA= ien in ^XTMP
+7 ;
PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51
+1 ;Now load any entries from 8989.5
+2 NEW XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT
+3 ;Get the package
SET XP1=$ORDER(^XTMP("XPDI",XPDA,"PKG",0))
+4 if 'XP1
QUIT
SET PN=$GET(^XTMP("XPDI",XPDA,"PKG",XP1,0))
+5 ;Get the IEN of the package
SET PE=$$FIND1^DIC(9.4,,"MX",$PIECE(PN,U,2))
+6 SET OLDA=0
SET ROOT=$NAME(^XTMP("XPDI",XPDA,"KRN",8989.5))
+7 FOR
SET OLDA=$ORDER(@ROOT@(OLDA))
if 'OLDA
QUIT
Begin DoDot:1
+8 SET XP1=@ROOT@(OLDA,0)
+9 ;entity
SET $PIECE(XP1,U,1)=PE_";DIC(9.4,"
+10 SET $PIECE(XP1,U,2)=$$LK^XPDIA($NAME(^XTV(8989.51)),$PIECE(XP1,U,2))
+11 SET DA=$$LKPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
+12 ;Remove the current entry if we have one
+13 IF DA>0
SET DIK="^XTV(8989.5,"
DO ^DIK
+14 ;Otherwise Add the zero node, See that we have a IEN
+15 IF DA'>0
DO ADDPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
SET DA=$$LKPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
+16 ;don't have a entry
if 'DA
QUIT
+17 ;Merge the date ;with IHS fix
+18 MERGE ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
+19 ;zero node with new pointers
SET ^XTV(8989.5,DA,0)=XP1
+20 ;Get Definition and check if Data Type is pointer, then get pointed to global ref.
+21 SET PT=$GET(^XTV(8989.51,+$PIECE(XP1,U,2),1))
if $PIECE(PT,U)="P"
Begin DoDot:2
+22 SET XP3=$GET(^XTV(8989.5,DA,1))
SET PT=$PIECE(PT,U,2)
+23 ;resolve pointer value
if PT
SET $PIECE(XP3,U)=$$FIND1^DIC(PT,"","X",$PIECE(XP3,U))
+24 if $PIECE(XP3,U)
SET ^XTV(8989.5,DA,1)=XP3
End DoDot:2
+25 ;X-ref it
+26 SET DIK="^XTV(8989.5,"
DO IX1^DIK
End DoDot:1
+27 QUIT
+28 ;
LKPAR(ENT,PAR,INST) ;Lookup an entry
+1 QUIT $ORDER(^XTV(8989.5,"AC",PAR,ENT,INST,0))
+2 ;
ADDPAR(ENT,PAR,INST) ;Add a parameter instance
+1 NEW FDA,FDAIEN,DIERR
+2 SET FDA(8989.5,"+1,",.01)=ENT
+3 SET FDA(8989.5,"+1,",.02)=PAR
+4 SET FDA(8989.5,"+1,",.03)=INST
+5 DO UPDATE^DIE("","FDA","FDAIEN","DIERR")
+6 QUIT
+7 ;
PAR1F1 ;PARAMETER File 8989.51: file Pre
+1 QUIT
PAR1E1 ;PARAMETER file 8989.51: entry pre
+1 NEW XP1,XP2,XP3
+2 SET ^TMP($JOB,"XPD",DA)=""
+3 ;if there is a new Description, kill the old Description
+4 if $ORDER(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0))
KILL ^XTV(8989.51,DA,20)
+5 ;Kill any old Allowable entries
+6 if $ORDER(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0))
KILL ^XTV(8989.51,DA,30)
+7 QUIT
PAR1F2 ;PARAMETER file 8989.51: file post
+1 NEW XPD,DIK,DA
+2 SET DA=0
+3 FOR
SET DA=$ORDER(^TMP($JOB,"XPD",DA))
if 'DA
QUIT
Begin DoDot:1
+4 SET DIK="^XTV(8989.51,"
DO IX1^DIK
End DoDot:1
+5 ;Go load the entries from 8989.5
DO PAR0F2
+6 QUIT
PAR1DEL(RT) ;Delete Parameter Def entries
+1 ;Cleanup pointers
DO DELPTR^XPDUTL1(8989.51,RT)
+2 ;Cleanup entries
DO DELIEN^XPDUTL1(8989.51,RT)
+3 QUIT
+4 ;
PAR2F1 ;PARAMETER TEMPLATE File 8989.52: file Pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
PAR2E1 ;PARAMETER TEMPLATE file 8989.52: entry Pre
+1 NEW XP1,XP2,ROOT
+2 SET ROOT=$NAME(^XTMP("XPDI",XPDA,"KRN",8989.52))
+3 ;Use instance of
SET XP2=$PIECE(@ROOT@(OLDA,0),U,4)
+4 ;Because we change the transport global see that a restart will work
+5 IF $LENGTH(XP2)
IF XP2?1A.E
SET $PIECE(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NAME(^XTV(8989.51)),XP2)
+6 SET XP1=0
+7 FOR
SET XP1=$ORDER(@ROOT@(OLDA,10,XP1))
SET XP2=""
if 'XP1
QUIT
Begin DoDot:1
+8 ;Parameter
SET XP2=$PIECE(@ROOT@(OLDA,10,XP1,0),U,2)
+9 IF $LENGTH(XP2)
IF XP2?1A.E
SET $PIECE(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NAME(^XTV(8989.51)),XP2)
+10 QUIT
End DoDot:1
+11 ;kill the Parameter multiple at the site
+12 KILL ^XTV(8989.52,DA,10)
+13 QUIT
PAR2F2 ;PARAMETER TEMPLATE file 8989.52: file Post
+1 QUIT
PAR2DEL(RT) ;Delete Parameter Templates
+1 DO DELIEN^XPDUTL1(8989.52,RT)
+2 QUIT
XULM ;XULM LOCK DICTIONARY file 8993; entry Pre
+1 NEW XP1,XP2,ROOT
+2 SET ROOT=$NAME(^XTMP("XPDI",XPDA,"KRN",8993))
+3 ;repoint PACKAGE (1;1)
+4 SET XP1=$PIECE($GET(@ROOT@(OLDA,1)),U)
+5 IF XP1]""
SET XP1=$$LK^XPDIA("^DIC(9.4)",XP1)
SET $PIECE(@ROOT@(OLDA,1),U)=XP1
+6 ;check WP fields, if new then delete old at site
+7 ;USAGE #4
+8 if $ORDER(@ROOT@(OLDA,4,0))
KILL ^XLM(8993,DA,4)
+9 ;DESCRIPTION #2, under COMPUTABLE FILE REFERENCES #3 multiple
+10 ;XP1 is a file number and is the same on all systems
+11 SET XP1=0
+12 FOR
SET XP1=$ORDER(@ROOT@(OLDA,3,XP1))
if 'XP1
QUIT
IF $ORDER(^(XP1,2,0))
KILL ^XLM(8993,DA,3,XP1,2)
+13 QUIT
