Released XU*8*498 SEQ #399 Extracted from mail message **KIDS**:XU*8.0*498^ **INSTALL NAME** XU*8.0*498 "BLD",1086,0) XU*8.0*498^KERNEL^0^3080522^y "BLD",1086,1,0) ^^7^7^3080430^^^^ "BLD",1086,1,1,0) Please see the patch description on FORUM, in the National "BLD",1086,1,2,0) Patch Module. "BLD",1086,1,3,0) "BLD",1086,1,4,0) "BLD",1086,1,5,0) "BLD",1086,1,6,0) "BLD",1086,1,7,0) "BLD",1086,4,0) ^9.64PA^^ "BLD",1086,6.3) 13 "BLD",1086,"KRN",0) ^9.67PA^779.2^20 "BLD",1086,"KRN",.4,0) .4 "BLD",1086,"KRN",.401,0) .401 "BLD",1086,"KRN",.402,0) .402 "BLD",1086,"KRN",.403,0) .403 "BLD",1086,"KRN",.5,0) .5 "BLD",1086,"KRN",.84,0) .84 "BLD",1086,"KRN",3.6,0) 3.6 "BLD",1086,"KRN",3.8,0) 3.8 "BLD",1086,"KRN",9.2,0) 9.2 "BLD",1086,"KRN",9.8,0) 9.8 "BLD",1086,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",1086,"KRN",9.8,"NM",1,0) XPDIA3^^0^B10647739 "BLD",1086,"KRN",9.8,"NM",2,0) XPDTA^^0^B30119515 "BLD",1086,"KRN",9.8,"NM",3,0) XPDTA2^^0^B6421820 "BLD",1086,"KRN",9.8,"NM","B","XPDIA3",1) "BLD",1086,"KRN",9.8,"NM","B","XPDTA",2) "BLD",1086,"KRN",9.8,"NM","B","XPDTA2",3) "BLD",1086,"KRN",19,0) 19 "BLD",1086,"KRN",19,"NM",0) ^9.68A^^ "BLD",1086,"KRN",19.1,0) 19.1 "BLD",1086,"KRN",101,0) 101 "BLD",1086,"KRN",409.61,0) 409.61 "BLD",1086,"KRN",771,0) 771 "BLD",1086,"KRN",779.2,0) 779.2 "BLD",1086,"KRN",870,0) 870 "BLD",1086,"KRN",8989.51,0) 8989.51 "BLD",1086,"KRN",8989.52,0) 8989.52 "BLD",1086,"KRN",8994,0) 8994 "BLD",1086,"KRN","B",.4,.4) "BLD",1086,"KRN","B",.401,.401) "BLD",1086,"KRN","B",.402,.402) "BLD",1086,"KRN","B",.403,.403) "BLD",1086,"KRN","B",.5,.5) "BLD",1086,"KRN","B",.84,.84) "BLD",1086,"KRN","B",3.6,3.6) "BLD",1086,"KRN","B",3.8,3.8) "BLD",1086,"KRN","B",9.2,9.2) "BLD",1086,"KRN","B",9.8,9.8) "BLD",1086,"KRN","B",19,19) "BLD",1086,"KRN","B",19.1,19.1) "BLD",1086,"KRN","B",101,101) "BLD",1086,"KRN","B",409.61,409.61) "BLD",1086,"KRN","B",771,771) "BLD",1086,"KRN","B",779.2,779.2) "BLD",1086,"KRN","B",870,870) "BLD",1086,"KRN","B",8989.51,8989.51) "BLD",1086,"KRN","B",8989.52,8989.52) "BLD",1086,"KRN","B",8994,8994) "BLD",1086,"QDEF") ^^^^NO^^^^NO^^NO "BLD",1086,"QUES",0) ^9.62^^ "BLD",1086,"REQB",0) ^9.611^2^2 "BLD",1086,"REQB",1,0) XU*8.0*201^1 "BLD",1086,"REQB",2,0) XU*8.0*393^1 "BLD",1086,"REQB","B","XU*8.0*201",1) "BLD",1086,"REQB","B","XU*8.0*393",2) "MBREQ") 0 "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^^0 "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3051215^2970507^.5 "PKG",3,22,1,"PAH",1,0) 498^3080522 "PKG",3,22,1,"PAH",1,1,0) ^^7^7^3080522 "PKG",3,22,1,"PAH",1,1,1,0) Please see the patch description on FORUM, in the National "PKG",3,22,1,"PAH",1,1,2,0) Patch Module. "PKG",3,22,1,"PAH",1,1,3,0) "PKG",3,22,1,"PAH",1,1,4,0) "PKG",3,22,1,"PAH",1,1,5,0) "PKG",3,22,1,"PAH",1,1,6,0) "PKG",3,22,1,"PAH",1,1,7,0) "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","XPDIA3") 0^1^B10647739^B8738323 "RTN","XPDIA3",1,0) XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13 "RTN","XPDIA3",2,0) ;;8.0;KERNEL;**201,302,393,498**;Jul 10, 1995;Build 13 "RTN","XPDIA3",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDIA3",4,0) Q "RTN","XPDIA3",5,0) ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root "RTN","XPDIA3",6,0) ;XPDNM=package name, XPDA=ien in ^XPD(9.6, "RTN","XPDIA3",7,0) ;DA=ien in file, OLDA= ien in ^XTMP "RTN","XPDIA3",8,0) ; "RTN","XPDIA3",9,0) PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51 "RTN","XPDIA3",10,0) ;Now load any entries from 8989.5 "RTN","XPDIA3",11,0) N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT "RTN","XPDIA3",12,0) S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package "RTN","XPDIA3",13,0) Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0)) "RTN","XPDIA3",14,0) S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package "RTN","XPDIA3",15,0) S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5)) "RTN","XPDIA3",16,0) F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D "RTN","XPDIA3",17,0) . S XP1=@ROOT@(OLDA,0) "RTN","XPDIA3",18,0) . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity "RTN","XPDIA3",19,0) . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2)) "RTN","XPDIA3",20,0) . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) "RTN","XPDIA3",21,0) . ;Remove the current entry if we have one "RTN","XPDIA3",22,0) . I DA>0 S DIK="^XTV(8989.5," D ^DIK "RTN","XPDIA3",23,0) . ;Otherwise Add the zero node, See that we have a IEN "RTN","XPDIA3",24,0) . 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)) "RTN","XPDIA3",25,0) . Q:'DA ;don't have a entry "RTN","XPDIA3",26,0) . ;Merge the date ;with IHS fix "RTN","XPDIA3",27,0) . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA) "RTN","XPDIA3",28,0) . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers "RTN","XPDIA3",29,0) . ;Get Definition and check if Data Type is pointer, then get pointed to global ref. "RTN","XPDIA3",30,0) . S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P" "RTN","XPDIA3",31,0) . . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2) "RTN","XPDIA3",32,0) . . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value "RTN","XPDIA3",33,0) . . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3 "RTN","XPDIA3",34,0) . ;X-ref it "RTN","XPDIA3",35,0) . S DIK="^XTV(8989.5," D IX1^DIK "RTN","XPDIA3",36,0) Q "RTN","XPDIA3",37,0) ; "RTN","XPDIA3",38,0) LKPAR(ENT,PAR,INST) ;Lookup an entry "RTN","XPDIA3",39,0) Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) "RTN","XPDIA3",40,0) ; "RTN","XPDIA3",41,0) ADDPAR(ENT,PAR,INST) ;Add a parameter instance "RTN","XPDIA3",42,0) N FDA,FDAIEN,DIERR "RTN","XPDIA3",43,0) S FDA(8989.5,"+1,",.01)=ENT "RTN","XPDIA3",44,0) S FDA(8989.5,"+1,",.02)=PAR "RTN","XPDIA3",45,0) S FDA(8989.5,"+1,",.03)=INST "RTN","XPDIA3",46,0) D UPDATE^DIE("","FDA","FDAIEN","DIERR") "RTN","XPDIA3",47,0) Q "RTN","XPDIA3",48,0) ; "RTN","XPDIA3",49,0) PAR1F1 ;PARAMETER File 8989.51: file Pre "RTN","XPDIA3",50,0) Q "RTN","XPDIA3",51,0) PAR1E1 ;PARAMETER file 8989.51: entry pre "RTN","XPDIA3",52,0) N XP1,XP2,XP3 "RTN","XPDIA3",53,0) S ^TMP($J,"XPD",DA)="" "RTN","XPDIA3",54,0) ;if there is a new Description, kill the old Description "RTN","XPDIA3",55,0) K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20) "RTN","XPDIA3",56,0) ;Kill any old Allowable entries "RTN","XPDIA3",57,0) K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30) "RTN","XPDIA3",58,0) Q "RTN","XPDIA3",59,0) PAR1F2 ;PARAMETER file 8989.51: file post "RTN","XPDIA3",60,0) N XPD,DIK,DA "RTN","XPDIA3",61,0) S DA=0 "RTN","XPDIA3",62,0) F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D "RTN","XPDIA3",63,0) . S DIK="^XTV(8989.51," D IX1^DIK "RTN","XPDIA3",64,0) D PAR0F2 ;Go load the entries from 8989.5 "RTN","XPDIA3",65,0) Q "RTN","XPDIA3",66,0) PAR1DEL(RT) ;Delete Parameter Def entries "RTN","XPDIA3",67,0) D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers "RTN","XPDIA3",68,0) D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries "RTN","XPDIA3",69,0) Q "RTN","XPDIA3",70,0) ; "RTN","XPDIA3",71,0) PAR2F1 ;PARAMETER File 8989.52: file Pre "RTN","XPDIA3",72,0) K ^TMP($J,"XPD") "RTN","XPDIA3",73,0) Q "RTN","XPDIA3",74,0) PAR2E1 ;PARAMETER file 8989.52: entry Pre "RTN","XPDIA3",75,0) N XP1,XP2,ROOT "RTN","XPDIA3",76,0) S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52)) "RTN","XPDIA3",77,0) S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of "RTN","XPDIA3",78,0) ;Because we change the transport global see that a restart will work "RTN","XPDIA3",79,0) I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) "RTN","XPDIA3",80,0) S XP1=0 "RTN","XPDIA3",81,0) F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D "RTN","XPDIA3",82,0) . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter "RTN","XPDIA3",83,0) . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) "RTN","XPDIA3",84,0) . Q "RTN","XPDIA3",85,0) Q "RTN","XPDIA3",86,0) PAR2F2 ;PARAMETER file 8989.52: file Post "RTN","XPDIA3",87,0) Q "RTN","XPDIA3",88,0) PAR2DEL(RT) ;Delete Parameter Templates "RTN","XPDIA3",89,0) D DELIEN^XPDUTL1(8989.52,RT) "RTN","XPDIA3",90,0) Q "RTN","XPDTA") 0^2^B30119515^B28341432 "RTN","XPDTA",1,0) XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 "RTN","XPDTA",2,0) ;;8.0;KERNEL;**15,44,58,131,229,393,498**;Jul 10, 1995;Build 13 "RTN","XPDTA",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDTA",4,0) Q "RTN","XPDTA",5,0) ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root "RTN","XPDTA",6,0) ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, "RTN","XPDTA",7,0) OPT ;options "RTN","XPDTA",8,0) N %,%1,%2 "RTN","XPDTA",9,0) ;if link, kill everything and just process the menu items "RTN","XPDTA",10,0) I XPDFL=2 D G OPTT "RTN","XPDTA",11,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) "RTN","XPDTA",12,0) ;resolve Package (0;12), remove Creator (0;5) "RTN","XPDTA",13,0) S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" "RTN","XPDTA",14,0) ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) "RTN","XPDTA",15,0) S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) "RTN","XPDTA",16,0) ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) "RTN","XPDTA",17,0) 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)=% "RTN","XPDTA",18,0) ;resolve RPC (RPC;0), must be type Broker "RTN","XPDTA",19,0) I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D "RTN","XPDTA",20,0) .;kill "B"=name x-ref, it will be re-indexed when installed "RTN","XPDTA",21,0) .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") "RTN","XPDTA",22,0) .;loop thru RPCs and resolve (RPC;1) "RTN","XPDTA",23,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",24,0) ..S %2=$$PT("^XWB(8994)",+%1) "RTN","XPDTA",25,0) ..;if can't resolve then delete "RTN","XPDTA",26,0) ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q "RTN","XPDTA",27,0) ..;save the RPC name "RTN","XPDTA",28,0) ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 "RTN","XPDTA",29,0) .Q "RTN","XPDTA",30,0) OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, "RTN","XPDTA",31,0) ;extended action, limited, window suite "RTN","XPDTA",32,0) I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q "RTN","XPDTA",33,0) ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed "RTN","XPDTA",34,0) K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") "RTN","XPDTA",35,0) ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve "RTN","XPDTA",36,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",37,0) .S %2=$$PT("^DIC(19)",+%1) "RTN","XPDTA",38,0) .;items must be sent by themselves, check "B" x-ref "RTN","XPDTA",39,0) .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q "RTN","XPDTA",40,0) .;if I couldn't resolve this option, then kill it "RTN","XPDTA",41,0) .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) "RTN","XPDTA",42,0) Q "RTN","XPDTA",43,0) ; "RTN","XPDTA",44,0) PRO ;protocols "RTN","XPDTA",45,0) N %,%1,%2 "RTN","XPDTA",46,0) ;if link, kill everything and just process the menu items "RTN","XPDTA",47,0) I XPDFL=2 D G PROT "RTN","XPDTA",48,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%) "RTN","XPDTA",49,0) ;resolve Package (0;12), remove Creator (0;5) "RTN","XPDTA",50,0) S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" "RTN","XPDTA",51,0) ;kill under Menus (10), "B"=name, "C"=synonyms "RTN","XPDTA",52,0) S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% "RTN","XPDTA",53,0) ;resolve File Link (5;1), its a variable pointer "RTN","XPDTA",54,0) S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) "RTN","XPDTA",55,0) I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 "RTN","XPDTA",56,0) ;resolve HL7 fields, node 770 "RTN","XPDTA",57,0) S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% "RTN","XPDTA",58,0) .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) "RTN","XPDTA",59,0) .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) "RTN","XPDTA",60,0) .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) "RTN","XPDTA",61,0) .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) "RTN","XPDTA",62,0) .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) "RTN","XPDTA",63,0) PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve "RTN","XPDTA",64,0) ;kill under Menus (10), "B"=name, "C"=synonyms "RTN","XPDTA",65,0) I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") "RTN","XPDTA",66,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",67,0) .;%2=.01 of Menu(protocol) "RTN","XPDTA",68,0) .S %2=$$PT("^ORD(101)",+%1) "RTN","XPDTA",69,0) .;Menu must also be sent by itself, check "B" x-ref "RTN","XPDTA",70,0) .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 "RTN","XPDTA",71,0) .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) "RTN","XPDTA",72,0) ;If type is Event Driver and sending Subscribers (775) "RTN","XPDTA",73,0) I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D "RTN","XPDTA",74,0) . ;kill Menu multiple and Subscriber x-ref "B"=name "RTN","XPDTA",75,0) . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") "RTN","XPDTA",76,0) . ;loop thru 775=Subscribers and resolve pointer (775;1) "RTN","XPDTA",77,0) . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",78,0) .. ;%2=.01 of subscriber(protocol) "RTN","XPDTA",79,0) .. S %2=$$PT("^ORD(101)",+%1) "RTN","XPDTA",80,0) .. ;protocol must also be sent by itself, check "B" x-ref "RTN","XPDTA",81,0) .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q "RTN","XPDTA",82,0) .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) "RTN","XPDTA",83,0) ;quit if no Access multiple "RTN","XPDTA",84,0) Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") "RTN","XPDTA",85,0) ;loop thru Access and resolve (3;1), kill if it doesn't resolve "RTN","XPDTA",86,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",87,0) .;%2=.01 of Menu(protocol) "RTN","XPDTA",88,0) .S %2=$$PT("^DIC(19.1)",+%1) "RTN","XPDTA",89,0) .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q "RTN","XPDTA",90,0) .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) "RTN","XPDTA",91,0) Q "RTN","XPDTA",92,0) ; "RTN","XPDTA",93,0) RTNE ;routine entry build action "RTN","XPDTA",94,0) N %,X,XPD "RTN","XPDTA",95,0) ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name "RTN","XPDTA",96,0) ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in "RTN","XPDTA",97,0) ;Build file "RTN","XPDTA",98,0) S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) "RTN","XPDTA",99,0) Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% "RTN","XPDTA",100,0) K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) "RTN","XPDTA",101,0) Q "RTN","XPDTA",102,0) ; "RTN","XPDTA",103,0) RTNF ;routine file build action "RTN","XPDTA",104,0) N X,Y,% S Y=0 "RTN","XPDTA",105,0) ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be "RTN","XPDTA",106,0) ;deleted at site, move name field to RTN node "RTN","XPDTA",107,0) F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D "RTN","XPDTA",108,0) .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 "RTN","XPDTA",109,0) ;kill everything "RTN","XPDTA",110,0) K ^XTMP("XPDT",XPDA,"KRN",9.8) "RTN","XPDTA",111,0) Q "RTN","XPDTA",112,0) ; "RTN","XPDTA",113,0) PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value "RTN","XPDTA",114,0) Q:'DA "" "RTN","XPDTA",115,0) Q:GR="" "" "RTN","XPDTA",116,0) I $D(@GR@(+DA,0))#2 Q $P(^(0),U) "RTN","XPDTA",117,0) Q "" "RTN","XPDTA",118,0) ; "RTN","XPDTA",119,0) GR(FN) ;returns closed global root, FN=file number "RTN","XPDTA",120,0) N Y "RTN","XPDTA",121,0) Q:'$G(FN) "" "RTN","XPDTA",122,0) S Y=$G(^DIC(FN,0,"GL")) Q:Y="" "" "RTN","XPDTA",123,0) Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"") "RTN","XPDTA",124,0) ; "RTN","XPDTA",125,0) LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file "RTN","XPDTA",126,0) ;XPD = 0-load, 1-delete, 2-skip, returns checksum "RTN","XPDTA",127,0) ;quit if routine is already saved "RTN","XPDTA",128,0) Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) "RTN","XPDTA",129,0) N DIF,XCNP,%N,%A,FDA,IEN,LN2 "RTN","XPDTA",130,0) S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 "RTN","XPDTA",131,0) X ^%ZOSF("LOAD") "RTN","XPDTA",132,0) 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) "RTN","XPDTA",133,0) S IEN=$$FIND1^DIC(9.8,"","X",X) "RTN","XPDTA",134,0) ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum "RTN","XPDTA",135,0) S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) "RTN","XPDTA",136,0) S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece "RTN","XPDTA",137,0) S ^XTMP("XPDT",XPDA,"RTN",X)=XPD "RTN","XPDTA",138,0) ;update count node "RTN","XPDTA",139,0) S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 "RTN","XPDTA",140,0) N XUA,XUB S (XUA,XUB)="" "RTN","XPDTA",141,0) ;Update Dev Patch field in Routine file "RTN","XPDTA",142,0) I IEN D "RTN","XPDTA",143,0) . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) "RTN","XPDTA",144,0) . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB "RTN","XPDTA",145,0) . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) "RTN","XPDTA",146,0) . D UPDATE^DIE("","FDA","IEN") "RTN","XPDTA",147,0) Q %N "RTN","XPDTA2") 0^3^B6421820^B4661967 "RTN","XPDTA2",1,0) XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36 "RTN","XPDTA2",2,0) ;;8.0;KERNEL;**201,498**;Jul 10, 1995;Build 13 "RTN","XPDTA2",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDTA2",4,0) Q "RTN","XPDTA2",5,0) ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root "RTN","XPDTA2",6,0) ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, "RTN","XPDTA2",7,0) ; "RTN","XPDTA2",8,0) PAR1E1 ;PARAMETER file 8989.51: entry post "RTN","XPDTA2",9,0) N XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT "RTN","XPDTA2",10,0) S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) "RTN","XPDTA2",11,0) D PAR51(DA) ;Handle the entry from 8989.51 "RTN","XPDTA2",12,0) 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 "RTN","XPDTA2",13,0) S:PT]"" PT=$S(PT:$$GR^XPDTA(PT),1:"") ;PT=file # of pointed to file from parm def. "RTN","XPDTA2",14,0) ;Now find any entrys in 8989.5 to transport, because we point to them "RTN","XPDTA2",15,0) S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3) "RTN","XPDTA2",16,0) Q:'XP3 ;No package file link "RTN","XPDTA2",17,0) F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance "RTN","XPDTA2",18,0) . F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry "RTN","XPDTA2",19,0) . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1) "RTN","XPDTA2",20,0) . . S XP3=^XTV(8989.5,XP1,0),XP4=$G(^(1)) ;param def. "RTN","XPDTA2",21,0) . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2)) "RTN","XPDTA2",22,0) . . I PT]"",XP4>0 S $P(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4) ;Data Type pointer - resolve "RTN","XPDTA2",23,0) . . Q ;Will redo the ENT at other end. "RTN","XPDTA2",24,0) Q "RTN","XPDTA2",25,0) ; "RTN","XPDTA2",26,0) PAR51(DA) ;Fix one 8989.51 entry in transport global "RTN","XPDTA2",27,0) ;Called from both PAR1E1 and PAR2E1 "RTN","XPDTA2",28,0) N XP,XP1,XP2,XP3,VP,PN,ROOT "RTN","XPDTA2",29,0) S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) "RTN","XPDTA2",30,0) ;Don't bring X-ref "RTN","XPDTA2",31,0) K @ROOT@(8989.51,DA,30,"B"),^("AG") "RTN","XPDTA2",32,0) S XP=0 "RTN","XPDTA2",33,0) ;Entries in the file will be maintained by Toolkit patches. "RTN","XPDTA2",34,0) Q "RTN","XPDTA2",35,0) ; "RTN","XPDTA2",36,0) PAR2E1 ;PARAMETER file 8989.52 entry post "RTN","XPDTA2",37,0) N XP1,XP2,XP3,ROOT "RTN","XPDTA2",38,0) S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) "RTN","XPDTA2",39,0) ;Resolve USE INSTANCE OF "RTN","XPDTA2",40,0) S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) "RTN","XPDTA2",41,0) I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3 "RTN","XPDTA2",42,0) ;Resolve PARAMETERS "RTN","XPDTA2",43,0) S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref "RTN","XPDTA2",44,0) F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D "RTN","XPDTA2",45,0) . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2) "RTN","XPDTA2",46,0) . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) "RTN","XPDTA2",47,0) . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1) "RTN","XPDTA2",48,0) . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3 "RTN","XPDTA2",49,0) . ;Now to move the entries this points to. "RTN","XPDTA2",50,0) . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2) "RTN","XPDTA2",51,0) . Q "RTN","XPDTA2",52,0) Q "VER") 8.0^22.0 "BLD",1086,6) ^399 **END** **END**