- 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 Mar 13, 2025@21:09:23 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
