XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006
;;8.0;KERNEL;**15,44,58,131,229,393,498,539,713,796**;Jul 10, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
OPT ;options
N %,%1,%2
;if link, kill everything and just process the menu items
I XPDFL=2 D G OPTT
.S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%)
;resolve Package (0;12), remove Creator (0;5)
S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200)
;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
;resolve RPC (RPC;0), must be type Broker
I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D
.;kill "B"=name x-ref, it will be re-indexed when installed
.K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
.;loop thru RPCs and resolve (RPC;1)
.S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D
..S %2=$$PT("^XWB(8994)",+%1)
..;if can't resolve then delete
..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q
..;save the RPC name
..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
.Q
OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu,
;extended action, limited, window suite
I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q
;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
.S %2=$$PT("^DIC(19)",+%1)
.;items must be sent by themselves, check "B" x-ref
.I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q
.;if I couldn't resolve this option, then kill it
.K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
Q
;
PRO ;protocols
N %,%1,%2
;if link, kill everything and just process the item(10) and subscribers (775) multiples
I XPDFL=2 D G PROT
.S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10&(%'=775) ^(%)
;resolve Package (0;12), remove Creator (0;5)
S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)=""
;kill under Menus (10), "B"=name, "C"=synonyms
S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=%
;resolve File Link (5;1), its a variable pointer
S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2)
I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1
;resolve HL7 fields, node 770
S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
.S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2))
.S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11))
.S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7))
.S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9))
.S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10))
PROT ;loop thru 10=ITEM and 775=SUBSCRIBER and resolve Menu (10;1), kill if it doesn't resolve
;kill under Menus (10), "B"=name, "C"=synonyms
I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C")
S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D
.;%2=.01 of Menu(protocol)
.S %2=$$PT("^ORD(101)",+%1)
.;Menu must also be sent by itself, check "B" x-ref
.I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q
.K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
;If type is Event Driver and sending Subscribers (775)
I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D
. ;kill Menu multiple and Subscriber x-ref "B"=name
. K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B")
. ;loop thru 775=Subscribers and resolve pointer (775;1)
. S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D
.. ;%2=.01 of subscriber(protocol)
.. S %2=$$PT("^ORD(101)",+%1)
.. ;protocol must also be sent by itself, check "B" x-ref
.. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q
.. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)
;quit if no Access multiple
Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B")
;loop thru Access and resolve (3;1), kill if it doesn't resolve
S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D
.;%2=.01 of Menu(protocol)
.S %2=$$PT("^DIC(19.1)",+%1)
.I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q
.K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
Q
;
RTNE ;routine entry build action
N %,X,XPD
;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
;Build file
S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1)
Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=%
K ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
Q
;
RTNF ;routine file build action
N X,Y,% S Y=0
;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
;deleted at site, move name field to RTN node
F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D
.I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
;kill everything
K ^XTMP("XPDT",XPDA,"KRN",9.8)
Q
;
PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value
Q:'DA ""
Q:GR="" ""
I $D(@GR@(+DA,0))#2 Q $P(^(0),U)
Q ""
;
GR(FN) ;returns closed global root, FN=file number
N Y
Q:'$G(FN) ""
S Y=$G(^DIC(FN,0,"GL")) Q:Y="" ""
Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"")
;
LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file
;XPD = 0-load, 1-delete, 2-skip, returns checksum
;quit if routine is already saved
Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3)
X ^%ZOSF("TEST") E W !,X,?10," Failed %ZOSF(""TEST"")! " S XPDERR=1 Q "" ;p713 ;p796 add ""
N DIF,XCNP,%N,%A,FDA,IEN,LN2
S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0
X ^%ZOSF("LOAD")
S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0)
S IEN=$$FIND1^DIC(9.8,"","X",X)
;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X)))
S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece
S ^XTMP("XPDT",XPDA,"RTN",X)=XPD
;update count node
S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1
N XUA,XUB S (XUA,XUB)=""
;Update Dev Patch field in Routine file
I IEN D
. S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2)
. S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB
. S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5)
. D UPDATE^DIE("","FDA","IEN")
Q %N
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDTA 7303 printed Oct 16, 2024@18:05:18 Page 2
XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006
+1 ;;8.0;KERNEL;**15,44,58,131,229,393,498,539,713,796**;Jul 10, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root
+5 ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6,
OPT ;options
+1 NEW %,%1,%2
+2 ;if link, kill everything and just process the menu items
+3 IF XPDFL=2
Begin DoDot:1
+4 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",19,DA,%))
if '%
QUIT
if %'=10
KILL ^(%)
End DoDot:1
GOTO OPTT
+5 ;resolve Package (0;12), remove Creator (0;5)
+6 SET %=^XTMP("XPDT",XPDA,"KRN",19,DA,0)
SET $PIECE(%,U,12)=$$PT("^DIC(9.4)",$PIECE(%,U,12))
SET $PIECE(%,U,5)=""
+7 ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200)
+8 SET $PIECE(%,U,7)=$$PT("^DIC(9.2)",$PIECE(%,U,7))
SET ^XTMP("XPDT",XPDA,"KRN",19,DA,0)=%
KILL ^(3.96),^(200)
+9 ;resolve Server Bulletin (220;1), Server Mailgroup (220;3)
+10 IF $DATA(^XTMP("XPDT",XPDA,"KRN",19,DA,220))
SET %=^(220)
SET $PIECE(%,U)=$$PT("^XMB(3.6)",+%)
SET $PIECE(%,U,3)=$$PT("^XMB(3.8)",$PIECE(%,U,3))
SET ^XTMP("XPDT",XPDA,"KRN",19,DA,220)=%
+11 ;resolve RPC (RPC;0), must be type Broker
+12 IF $DATA(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC"))
if $PIECE(^(0),U,4)'="B"
KILL ^("RPC")
Begin DoDot:1
+13 ;kill "B"=name x-ref, it will be re-indexed when installed
+14 KILL ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B")
+15 ;loop thru RPCs and resolve (RPC;1)
+16 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%))
if '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:2
+17 SET %2=$$PT("^XWB(8994)",+%1)
+18 ;if can't resolve then delete
+19 IF %2=""
KILL ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0)
QUIT
+20 ;save the RPC name
+21 SET $PIECE(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2
End DoDot:2
+22 QUIT
End DoDot:1
OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu,
+1 ;extended action, limited, window suite
+2 IF "LMOQXZ"'[$PIECE(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4)
KILL ^(10)
QUIT
+3 ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed
+4 KILL ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C")
+5 ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve
+6 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%))
if '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:1
+7 SET %2=$$PT("^DIC(19)",+%1)
+8 ;items must be sent by themselves, check "B" x-ref
+9 IF $LENGTH(%2)
IF $DATA(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2))
SET ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2
QUIT
+10 ;if I couldn't resolve this option, then kill it
+11 KILL ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)
End DoDot:1
+12 QUIT
+13 ;
PRO ;protocols
+1 NEW %,%1,%2
+2 ;if link, kill everything and just process the item(10) and subscribers (775) multiples
+3 IF XPDFL=2
Begin DoDot:1
+4 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",101,DA,%))
if '%
QUIT
if %'=10&(%'=775)
KILL ^(%)
End DoDot:1
GOTO PROT
+5 ;resolve Package (0;12), remove Creator (0;5)
+6 SET %=^XTMP("XPDT",XPDA,"KRN",101,DA,0)
SET $PIECE(%,U,12)=$$PT("^DIC(9.4)",$PIECE(%,U,12))
SET $PIECE(%,U,5)=""
+7 ;kill under Menus (10), "B"=name, "C"=synonyms
+8 SET ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=%
+9 ;resolve File Link (5;1), its a variable pointer
+10 SET %=$PIECE($GET(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U)
SET %1=$PIECE(%,";",2)
+11 IF %
IF $DATA(@("^"_%1_+%_",0)"))
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$PIECE(^(0),U)_";"_%1
+12 ;resolve HL7 fields, node 770
+13 SET %=$GET(^XTMP("XPDT",XPDA,"KRN",101,DA,770))
IF $LENGTH(%)
Begin DoDot:1
+14 SET $PIECE(%,U)=$$PT("^HL(771)",$PIECE(%,U))
SET $PIECE(%,U,2)=$$PT("^HL(771)",$PIECE(%,U,2))
+15 SET $PIECE(%,U,3)=$$PT("^HL(771.2)",$PIECE(%,U,3))
SET $PIECE(%,U,11)=$$PT("^HL(771.2)",$PIECE(%,U,11))
+16 SET $PIECE(%,U,4)=$$PT("^HL(779.001)",$PIECE(%,U,4))
SET $PIECE(%,U,7)=$$PT("^HLCS(870)",$PIECE(%,U,7))
+17 SET $PIECE(%,U,8)=$$PT("^HL(779.003)",$PIECE(%,U,8))
SET $PIECE(%,U,9)=$$PT("^HL(779.003)",$PIECE(%,U,9))
+18 SET $PIECE(%,U,10)=$$PT("^HL(771.5)",$PIECE(%,U,10))
End DoDot:1
SET ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=%
PROT ;loop thru 10=ITEM and 775=SUBSCRIBER and resolve Menu (10;1), kill if it doesn't resolve
+1 ;kill under Menus (10), "B"=name, "C"=synonyms
+2 IF $DATA(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0))
KILL ^("B"),^("C")
+3 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%))
if '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:1
+4 ;%2=.01 of Menu(protocol)
+5 SET %2=$$PT("^ORD(101)",+%1)
+6 ;Menu must also be sent by itself, check "B" x-ref
+7 IF $LENGTH(%2)
IF $DATA(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2))
SET ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2
SET $PIECE(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$PIECE(%1,U,4))
QUIT
+8 KILL ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)
End DoDot:1
+9 ;If type is Event Driver and sending Subscribers (775)
+10 IF $PIECE(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E"
Begin DoDot:1
+11 ;kill Menu multiple and Subscriber x-ref "B"=name
+12 KILL ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B")
+13 ;loop thru 775=Subscribers and resolve pointer (775;1)
+14 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%))
if '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:2
+15 ;%2=.01 of subscriber(protocol)
+16 SET %2=$$PT("^ORD(101)",+%1)
+17 ;protocol must also be sent by itself, check "B" x-ref
+18 IF $LENGTH(%2)
IF $DATA(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2))
SET ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2
QUIT
+19 KILL ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)
End DoDot:2
End DoDot:1
+20 ;quit if no Access multiple
+21 if '$DATA(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0))
QUIT
KILL ^("B")
+22 ;loop thru Access and resolve (3;1), kill if it doesn't resolve
+23 SET %=0
FOR
SET %=$ORDER(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%))
if '%
QUIT
SET %1=$GET(^(%,0))
Begin DoDot:1
+24 ;%2=.01 of Menu(protocol)
+25 SET %2=$$PT("^DIC(19.1)",+%1)
+26 IF $LENGTH(%2)
SET ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2
QUIT
+27 KILL ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)
End DoDot:1
+28 QUIT
+29 ;
RTNE ;routine entry build action
+1 NEW %,X,XPD
+2 ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name
+3 ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in
+4 ;Build file
+5 SET X=$PIECE(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U)
SET XPD=^(-1)
+6 if X=""
QUIT
SET %=$$LOAD(X,XPD)
SET $PIECE(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$PIECE(XPD,U,2),0),U,4)=%
+7 KILL ^XTMP("XPDT",XPDA,"KRN",9.8,DA)
+8 QUIT
+9 ;
RTNF ;routine file build action
+1 NEW X,Y,%
SET Y=0
+2 ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be
+3 ;deleted at site, move name field to RTN node
+4 FOR
SET Y=$ORDER(^XTMP("XPDT",XPDA,"KRN",9.8,Y))
if 'Y
QUIT
SET %=^(Y,-1)
SET X=^(0)
Begin DoDot:1
+5 IF +%=1
SET ^XTMP("XPDT",XPDA,"RTN",X)=%
SET ^("RTN")=$GET(^XTMP("XPDT",XPDA,"RTN"))+1
End DoDot:1
+6 ;kill everything
+7 KILL ^XTMP("XPDT",XPDA,"KRN",9.8)
+8 QUIT
+9 ;
PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value
+1 if 'DA
QUIT ""
+2 if GR=""
QUIT ""
+3 IF $DATA(@GR@(+DA,0))#2
QUIT $PIECE(^(0),U)
+4 QUIT ""
+5 ;
GR(FN) ;returns closed global root, FN=file number
+1 NEW Y
+2 if '$GET(FN)
QUIT ""
+3 SET Y=$GET(^DIC(FN,0,"GL"))
if Y=""
QUIT ""
+4 QUIT $EXTRACT(Y,1,($LENGTH(Y)-1))_$SELECT($LENGTH(Y,",")>1:")",1:"")
+5 ;
LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file
+1 ;XPD = 0-load, 1-delete, 2-skip, returns checksum
+2 ;quit if routine is already saved
+3 if $DATA(^XTMP("XPDT",XPDA,"RTN",X))
QUIT $PIECE(^(X),U,3)
+4 ;p713 ;p796 add ""
XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,X,?10," Failed %ZOSF(""TEST"")! "
SET XPDERR=1
QUIT ""
+5 NEW DIF,XCNP,%N,%A,FDA,IEN,LN2
+6 SET DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,"
SET XCNP=0
+7 XECUTE ^%ZOSF("LOAD")
+8 SET $PIECE(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3))
SET LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0)
+9 SET IEN=$$FIND1^DIC(9.8,"","X",X)
+10 ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum
+11 SET %N="B"_$$SUMB^XPDRSUM($NAME(^XTMP("XPDT",XPDA,"RTN",X)))
+12 ;Make sure the Checksum is in the 3rd piece
SET $PIECE(XPD,"^",3)=%N
+13 SET ^XTMP("XPDT",XPDA,"RTN",X)=XPD
+14 ;update count node
+15 SET ^("RTN")=$GET(^XTMP("XPDT",XPDA,"RTN"))+1
+16 NEW XUA,XUB
SET (XUA,XUB)=""
+17 ;Update Dev Patch field in Routine file
+18 IF IEN
Begin DoDot:1
+19 SET XUB=$PIECE(XPDT(XPDT),U,2)
if XUB["*"
SET $PIECE(XUB,"*",2)=+$PIECE(XUB,"*",2)
+20 SET IEN="?+2,"_IEN_","
SET FDA(9.819,IEN,.01)=XUB
+21 SET FDA(9.819,IEN,2)=%N
SET FDA(9.819,IEN,3)=$PIECE(LN2,";",5)
+22 DO UPDATE^DIE("","FDA","IEN")
End DoDot:1
+23 QUIT %N
