Routine: XPDTA2

XPDTA2 ;SFISC/RWF -  Build Actions for Kernel Files Cont. ;08/09/2001  12:36

 ;;8.0;KERNEL;**201,498**;Jul 10, 1995;Build 13

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;^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 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.

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.

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

XPDTA2    ;SFISC/RWF -  Build Actions for Kernel Files Cont. ;08/09/2001  12:36

 +1       ;;8.0;KERNEL;**201,498**;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       ;

PAR1E1    ;PARAMETER 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

XPDTA2.m