Released XU*8*629 SEQ #502 Extracted from mail message **KIDS**:XU*8.0*629^ **INSTALL NAME** XU*8.0*629 "BLD",1497,0) XU*8.0*629^KERNEL^0^3130606^y "BLD",1497,1,0) ^^1^1^3130416^ "BLD",1497,1,1,0) See patch description on FORUM for XU*8*629. "BLD",1497,4,0) ^9.64PA^^ "BLD",1497,6.3) 17 "BLD",1497,"INID") ^y "BLD",1497,"INIT") XU8PS629 "BLD",1497,"KRN",0) ^9.67PA^9002226^22 "BLD",1497,"KRN",.4,0) .4 "BLD",1497,"KRN",.401,0) .401 "BLD",1497,"KRN",.402,0) .402 "BLD",1497,"KRN",.403,0) .403 "BLD",1497,"KRN",.5,0) .5 "BLD",1497,"KRN",.84,0) .84 "BLD",1497,"KRN",3.6,0) 3.6 "BLD",1497,"KRN",3.8,0) 3.8 "BLD",1497,"KRN",9.2,0) 9.2 "BLD",1497,"KRN",9.8,0) 9.8 "BLD",1497,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",1497,"KRN",9.8,"NM",1,0) XU8PS629^^0^B14238522 "BLD",1497,"KRN",9.8,"NM",2,0) XQ84^^0^B72156194 "BLD",1497,"KRN",9.8,"NM","B","XQ84",2) "BLD",1497,"KRN",9.8,"NM","B","XU8PS629",1) "BLD",1497,"KRN",19,0) 19 "BLD",1497,"KRN",19,"NM",0) ^9.68A^^0 "BLD",1497,"KRN",19.1,0) 19.1 "BLD",1497,"KRN",101,0) 101 "BLD",1497,"KRN",409.61,0) 409.61 "BLD",1497,"KRN",771,0) 771 "BLD",1497,"KRN",779.2,0) 779.2 "BLD",1497,"KRN",870,0) 870 "BLD",1497,"KRN",8989.51,0) 8989.51 "BLD",1497,"KRN",8989.51,"NM",0) ^9.68A^^0 "BLD",1497,"KRN",8989.52,0) 8989.52 "BLD",1497,"KRN",8993,0) 8993 "BLD",1497,"KRN",8994,0) 8994 "BLD",1497,"KRN",8994,"NM",0) ^9.68A^1^1 "BLD",1497,"KRN",8994,"NM",1,0) XU REBUILD MENU TREE^^0 "BLD",1497,"KRN",8994,"NM","B","XU REBUILD MENU TREE",1) "BLD",1497,"KRN",9002226,0) 9002226 "BLD",1497,"KRN","B",.4,.4) "BLD",1497,"KRN","B",.401,.401) "BLD",1497,"KRN","B",.402,.402) "BLD",1497,"KRN","B",.403,.403) "BLD",1497,"KRN","B",.5,.5) "BLD",1497,"KRN","B",.84,.84) "BLD",1497,"KRN","B",3.6,3.6) "BLD",1497,"KRN","B",3.8,3.8) "BLD",1497,"KRN","B",9.2,9.2) "BLD",1497,"KRN","B",9.8,9.8) "BLD",1497,"KRN","B",19,19) "BLD",1497,"KRN","B",19.1,19.1) "BLD",1497,"KRN","B",101,101) "BLD",1497,"KRN","B",409.61,409.61) "BLD",1497,"KRN","B",771,771) "BLD",1497,"KRN","B",779.2,779.2) "BLD",1497,"KRN","B",870,870) "BLD",1497,"KRN","B",8989.51,8989.51) "BLD",1497,"KRN","B",8989.52,8989.52) "BLD",1497,"KRN","B",8993,8993) "BLD",1497,"KRN","B",8994,8994) "BLD",1497,"KRN","B",9002226,9002226) "BLD",1497,"QUES",0) ^9.62^^ "BLD",1497,"REQB",0) ^9.611^^ "INIT") XU8PS629 "KRN",8994,288,-1) 0^1 "KRN",8994,288,0) XU REBUILD MENU TREE^REBUILD^XQ84^1^P "KRN",8994,288,1,0) ^^2^2^3130416^ "KRN",8994,288,1,1,0) This API rebuilds the menu trees and display nodes for a single user "KRN",8994,288,1,2,0) (DUZ). It returns 0 if unsuccessful, 1 if successful. "MBREQ") 0 "ORD",16,8994) 8994;16;1;;;;;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^2^2 "PKG",3,20,1,0) 200^^XDRM200N "PKG",3,20,1,1) "PKG",3,20,2,0) 2^^RGDRM03 "PKG",3,20,2,1) "PKG",3,20,"B",2,2) "PKG",3,20,"B",200,1) "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3090706^3090706^6 "PKG",3,22,1,"PAH",1,0) 629^3130606 "PKG",3,22,1,"PAH",1,1,0) ^^1^1^3130606 "PKG",3,22,1,"PAH",1,1,1,0) See patch description on FORUM for XU*8*629. "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") 2 "RTN","XQ84") 0^2^B72156194^B60218862 "RTN","XQ84",1,0) XQ84 ;SEA/LUKE,ISD/HGW - Menu Rebuild Utilities ;06/06/13 12:59 "RTN","XQ84",2,0) ;;8.0;KERNEL;**157,253,614,629**;Jul 10, 1995;Build 17 "RTN","XQ84",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XQ84",4,0) ; "RTN","XQ84",5,0) SHOW ; Show what's in the global ^XUTL("XQO","REBUILDS") "RTN","XQ84",6,0) ; ZEXCEPT: DIRUT,DUOUT,IOF,IOSL ; Kernel exemptions "RTN","XQ84",7,0) I '$D(^XUTL("XQO","REBUILDS")) W !," Sorry, there is no data in the global ^XUTL(""XQO"",""REBUILDS"") to show you.",! Q "RTN","XQ84",8,0) ; "RTN","XQ84",9,0) N %,XQI,XQNL,XQNI,XQNT "RTN","XQ84",10,0) N XQB,XQE,XQBY,XQTYPE,XQT,XQUCI,XQJ "RTN","XQ84",11,0) ; "RTN","XQ84",12,0) I '$D(IOF) D HOME^%ZIS "RTN","XQ84",13,0) W @IOF "RTN","XQ84",14,0) S XQNL=0 ;Line counter "RTN","XQ84",15,0) S XQNI=1 ;Item or occurance counter "RTN","XQ84",16,0) S XQNT=$S($D(IOSL):IOSL-4,1:18) ;Number of lines on the screen "RTN","XQ84",17,0) ; "RTN","XQ84",18,0) D TITLE "RTN","XQ84",19,0) D TOP "RTN","XQ84",20,0) ; "RTN","XQ84",21,0) S XQI=0 "RTN","XQ84",22,0) F Q:$D(DIRUT) S XQI=$O(^XUTL("XQO","REBUILDS",XQI)) Q:XQI="" D "RTN","XQ84",23,0) .S %=^XUTL("XQO","REBUILDS",XQI) "RTN","XQ84",24,0) .S XQBY=$P($P(%,U,3),","),XQBY=$E(XQBY,1,12) "RTN","XQ84",25,0) .S XQB=$P(%,U,1),XQE=$P(%,U,2),XQTYPE=$P(%,U,4),XQT=$P(%,U,5) "RTN","XQ84",26,0) .S XQUCI=" Location: "_$P(%,U,6,8) "RTN","XQ84",27,0) .S XQJ=" Job #: "_$P(%,U,9) "RTN","XQ84",28,0) .D WRITE "RTN","XQ84",29,0) .Q "RTN","XQ84",30,0) ; "RTN","XQ84",31,0) K DIRUT,DUOUT "RTN","XQ84",32,0) Q "RTN","XQ84",33,0) ; "RTN","XQ84",34,0) WRITE ;Write an entry unless the screen is full "RTN","XQ84",35,0) ; ZEXCEPT: IOF,XQB,XQBY,XQE,XQJ,XQNI,XQNL,XQNT,XQT,XQTYPE,XQUCI ; Kernel exemptions "RTN","XQ84",36,0) I XQNL>XQNT D "RTN","XQ84",37,0) .D WAIT Q:$D(DIRUT) "RTN","XQ84",38,0) .W @IOF "RTN","XQ84",39,0) .S XQNL=0 "RTN","XQ84",40,0) .D TOP "RTN","XQ84",41,0) .Q "RTN","XQ84",42,0) Q:$D(DIRUT) "RTN","XQ84",43,0) W !,XQNI,".",?4,XQB,?28,XQE,?51,XQBY,?60,XQTYPE,?71,XQT,!,XQUCI,XQJ,! "RTN","XQ84",44,0) S XQNL=XQNL+3,XQNI=XQNI+1 "RTN","XQ84",45,0) Q "RTN","XQ84",46,0) ; "RTN","XQ84",47,0) TOP ; Format the top of the page "RTN","XQ84",48,0) ; ZEXCEPT: XQNL ; Kernel exemption "RTN","XQ84",49,0) W !,?11,"Start",?35,"End",?53,"By",?59,"Type/Name",?72,"Task #",! "RTN","XQ84",50,0) S XQNL=XQNL+2 "RTN","XQ84",51,0) Q "RTN","XQ84",52,0) ; "RTN","XQ84",53,0) TITLE ;What is this all about? "RTN","XQ84",54,0) ; ZEXCEPT: XQNL ; Kernel exemption "RTN","XQ84",55,0) N % "RTN","XQ84",56,0) S %=$G(^XUTL("XQO","MICRO")) "RTN","XQ84",57,0) W ?36,"Recent Menu Rebuilds",! "RTN","XQ84",58,0) S XQNL=XQNL+2 "RTN","XQ84",59,0) W ?14,$S(%>0:%,1:"No")_" instances of Micro Surgery since last rebuild." "RTN","XQ84",60,0) S XQNL=XQNL+2 "RTN","XQ84",61,0) Q "RTN","XQ84",62,0) ; "RTN","XQ84",63,0) WAIT ;That's a screen load hold it here for a minute "RTN","XQ84",64,0) ; ZEXCEPT: DIR ; Kernel exemption "RTN","XQ84",65,0) N X,Y "RTN","XQ84",66,0) S DIR(0)="E" D ^DIR K DIR "RTN","XQ84",67,0) Q "RTN","XQ84",68,0) ; "RTN","XQ84",69,0) USER ;Rebuild the menu trees of a specific user "RTN","XQ84",70,0) ;called by the option XQBUILDUSER "RTN","XQ84",71,0) ; ZEXCEPT: XQCNTS,XQREACTS,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions "RTN","XQ84",72,0) ; ZEXCEPT: XTMUNIT,ZZ8XUN - Variables set for unit testing "RTN","XQ84",73,0) N XUN,XQCNT,XQSEC,XQREACT,XQPRIM,XQFL "RTN","XQ84",74,0) S (XQCNT,XQSEC)=0 "RTN","XQ84",75,0) ; Select user "RTN","XQ84",76,0) S XUN=$G(ZZ8XUN) "RTN","XQ84",77,0) I '$D(XTMUNIT) D "RTN","XQ84",78,0) . S XUN=+$$LOOKUP^XUSER Q:XUN'>0 "RTN","XQ84",79,0) S XQPRIM=$G(^VA(200,XUN,201)) I XQPRIM'>0 W !!,"No Primary Menu defined for this user." Q "RTN","XQ84",80,0) ; Build array of options "RTN","XQ84",81,0) S XQCNT=1,XQREACT(XQCNT)=XQPRIM "RTN","XQ84",82,0) F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D "RTN","XQ84",83,0) . Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it "RTN","XQ84",84,0) . I $P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)=XQSEC "RTN","XQ84",85,0) . Q "RTN","XQ84",86,0) ; "RTN","XQ84",87,0) M XQREACTS=XQREACT ;Save the originals "RTN","XQ84",88,0) S XQCNTS=XQCNT "RTN","XQ84",89,0) ; "RTN","XQ84",90,0) S XQFL=$$FLAG(.XQREACT,.XQCNT) "RTN","XQ84",91,0) I (XQFL=1)&('$D(XTMUNIT)) D "RTN","XQ84",92,0) . N DIR "RTN","XQ84",93,0) . S DIR(0)="Y" "RTN","XQ84",94,0) . S DIR("A")=" Are you sure you want to force a rebuild? " "RTN","XQ84",95,0) . S DIR("A",1)=" ***WARNING*** " "RTN","XQ84",96,0) . S DIR("A",2)=" Someone else may be rebuilding these trees right now." "RTN","XQ84",97,0) . S DIR("?")=" Enter 'Y' to force a rebuild, 'N' to quit." "RTN","XQ84",98,0) . D ^DIR "RTN","XQ84",99,0) . I Y=1 D "RTN","XQ84",100,0) . . M XQREACT=XQREACTS ;Restore original list of menus "RTN","XQ84",101,0) . . S XQCNT=XQCNTS "RTN","XQ84",102,0) . . S XQFL=0 "RTN","XQ84",103,0) . . Q "RTN","XQ84",104,0) . Q "RTN","XQ84",105,0) ; "RTN","XQ84",106,0) Q:XQFL ;Flags are set, let's not mess with it. "RTN","XQ84",107,0) ; "RTN","XQ84",108,0) I '$D(XTMUNIT) D "RTN","XQ84",109,0) . S DIR(0)="Y",DIR("A")=" Queue this rebuild? ",DIR("B")="Y" "RTN","XQ84",110,0) . S DIR("?")=" Please enter 'Y'es or 'N'o." "RTN","XQ84",111,0) . D ^DIR I Y=1 D "RTN","XQ84",112,0) . . S ZTRTN="REACTQ^XQ84" "RTN","XQ84",113,0) . . S ZTSAVE("XUN")="" "RTN","XQ84",114,0) . . S ZTSAVE("XQREACT(")="",ZTSAVE("XQCNT")="" "RTN","XQ84",115,0) . . S ZTIO="",ZTDTH=$H "RTN","XQ84",116,0) . . S ZTDESC="Rebuild "_$P(^VA(200,XUN,0),U)_"'s menu trees (DUZ="_XUN_")" "RTN","XQ84",117,0) . . D ^%ZTLOAD "RTN","XQ84",118,0) . . I $D(ZTSK) W !!," Task number: ",ZTSK "RTN","XQ84",119,0) . Q "RTN","XQ84",120,0) K DIR,Y "RTN","XQ84",121,0) ; "RTN","XQ84",122,0) I '$D(ZTSK) D REACTQ I '$D(XTMUNIT) W !!," Done." "RTN","XQ84",123,0) K ZTSK "RTN","XQ84",124,0) Q "RTN","XQ84",125,0) ; "RTN","XQ84",126,0) REACT(XUN) ;From XUSERNEW, check trees for reactivated user "RTN","XQ84",127,0) ; ZEXCEPT: XQQUE,XQUEUED,XWB,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ; Kernel exemptions "RTN","XQ84",128,0) ; "RTN","XQ84",129,0) N XQCNT,XQSEC,XQREACT,XQPRIM,XQCHAT "RTN","XQ84",130,0) S XQCHAT=1 I $D(XQUEUED)!$D(XWB) S XQCHAT=0 ;Anybody out there? "RTN","XQ84",131,0) S XQPRIM=$G(^VA(200,XUN,201)) I 'XQPRIM,'$D(XQQUE) W:XQCHAT !!,"** WARNING ** No Primary Menu defined." Q "RTN","XQ84",132,0) I (XQPRIM'=+XQPRIM)!($G(^DIC(19,XQPRIM,0))="") Q "RTN","XQ84",133,0) S (XQCNT,XQSEC)=0 "RTN","XQ84",134,0) I XQPRIM,'$D(^DIC(19,"AXQ","P"_XQPRIM)),$P(^DIC(19,XQPRIM,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)="P"_XQPRIM "RTN","XQ84",135,0) F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D "RTN","XQ84",136,0) .Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it "RTN","XQ84",137,0) .I '$D(^DIC(19,"AXQ","P"_XQSEC)),$P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)="P"_XQSEC "RTN","XQ84",138,0) .Q "RTN","XQ84",139,0) ; "RTN","XQ84",140,0) Q:XQCNT=0 ;The menu trees look OK to me. "RTN","XQ84",141,0) ; "RTN","XQ84",142,0) N % "RTN","XQ84",143,0) S %=$$FLAG(.XQREACT,.XQCNT) ;Are we already merging them (1) "RTN","XQ84",144,0) Q:% "RTN","XQ84",145,0) ; "RTN","XQ84",146,0) I XQCNT>0 D "RTN","XQ84",147,0) .S ZTRTN="REACTQ^XQ84" "RTN","XQ84",148,0) .S ZTSAVE("XQREACT(")="",ZTSAVE("XUN")="" "RTN","XQ84",149,0) .S ZTIO="",ZTDTH=$H "RTN","XQ84",150,0) .S ZTDESC="Rebuild reactivated user's menu trees (DUZ="_XUN_")" "RTN","XQ84",151,0) .D ^%ZTLOAD "RTN","XQ84",152,0) .K ZTSK "RTN","XQ84",153,0) .Q "RTN","XQ84",154,0) Q "RTN","XQ84",155,0) ; "RTN","XQ84",156,0) FLAG(XQARRAY,XQNUM1) ;Should we build a particular array of trees "RTN","XQ84",157,0) ;Input: XQARRAY - array of trees e.g. P106, etc. XQNUM1 number of trees "RTN","XQ84",158,0) ;Output: 0 - There are trees to rebuild, 1 - Trees are already flagged "RTN","XQ84",159,0) ;Merge flags e.g. [^XUTL("XQO","XQMERGED","P106)=$H] are set here "RTN","XQ84",160,0) ; and killed in REACTQ+16 "RTN","XQ84",161,0) ; "RTN","XQ84",162,0) N %,XQNUM,XQPXU S XQNUM=0 "RTN","XQ84",163,0) S %=$$STATUS^XQ81() I '% Q 1 ;Menus rebuilding "RTN","XQ84",164,0) S XQPXU=$G(^DIC(19,"AXQ","PXU",0)) Q:XQPXU="" 1 "RTN","XQ84",165,0) S %="" F S %=$O(XQARRAY(%)) Q:%="" D "RTN","XQ84",166,0) .N X "RTN","XQ84",167,0) .S X=XQARRAY(%) "RTN","XQ84",168,0) .I $D(^XUTL("XQO","XQMERGED",X)) D "RTN","XQ84",169,0) ..N Y,Z "RTN","XQ84",170,0) ..S Y=$G(^XUTL("XQO","XQMERGED",X)) Q:Y="" ;Flag's gone "RTN","XQ84",171,0) ..S Z=$$HDIFF^XLFDT(XQPXU,Y) "RTN","XQ84",172,0) ..I Z>0 K ^XUTL("XQO","XQMERGED",X) ;Old Flag "RTN","XQ84",173,0) ..Q "RTN","XQ84",174,0) .I $D(^XUTL("XQO","XQMERGED",X)) K XQARRAY(%) Q "RTN","XQ84",175,0) .S ^XUTL("XQO","XQMERGED",X)=$H,XQNUM=XQNUM+1 ;We'll merge this one "RTN","XQ84",176,0) .Q "RTN","XQ84",177,0) I XQNUM>0 S XQNUM1=XQNUM Q 0 ;There are some left to rebuild "RTN","XQ84",178,0) Q 1 "RTN","XQ84",179,0) ; "RTN","XQ84",180,0) REACTQ ;Queued job to rebuild a reactivated user's menu trees "RTN","XQ84",181,0) ; can also be run in real time by USER (above) "RTN","XQ84",182,0) ; ZEXCEPT: D,I,W,X,XQFG1,XQK,XQQUE,XQREACT,XQSTAT,XQXUF,XUN,Y,Z,ZTQUEUED,ZTREQ ; Kernel exemptions "RTN","XQ84",183,0) N % S %=0 "RTN","XQ84",184,0) K ZTREQ ;Don't delete the task information "RTN","XQ84",185,0) I $D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS^XQ81 Q:'XQSTAT ;Menus are being rebuilt "RTN","XQ84",186,0) Q:'$D(XQREACT) ;Nothing to rebuild "RTN","XQ84",187,0) ; "RTN","XQ84",188,0) D MICRO^XQ81 ;Turn off Micro Surgery "RTN","XQ84",189,0) S ^DIC(19,"AXQ","P0")=$H "RTN","XQ84",190,0) N XQCNT,XQDIC S XQCNT="" "RTN","XQ84",191,0) K ^TMP($J),^TMP("XQO",$J) "RTN","XQ84",192,0) F S XQCNT=$O(XQREACT(XQCNT)) Q:XQCNT="" D "RTN","XQ84",193,0) .S (XQFG1,XQXUF)="",XQDIC="P"_XQREACT(XQCNT) "RTN","XQ84",194,0) .D PM2^XQ8 "RTN","XQ84",195,0) .Q:'$D(^TMP("XQO",$J,XQDIC)) "RTN","XQ84",196,0) .M ^DIC(19,"AXQ",XQDIC)=^TMP("XQO",$J,XQDIC) ;D MERGET^XQ81 "RTN","XQ84",197,0) .M ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC) ;D MERGEX^XQ81 "RTN","XQ84",198,0) .K ^XUTL("XQO","XQMERGED",XQREACT(XQCNT)) "RTN","XQ84",199,0) .Q "RTN","XQ84",200,0) N DUZ S DUZ=XUN S XQDIC="U"_XUN D NEWSET^XQSET "RTN","XQ84",201,0) K ^DIC(19,"AXQ","P0"),^TMP($J),^TMP("XQO",$J) "RTN","XQ84",202,0) D REPORT($E($P(^VA(200,XUN,0),U),1,9)) "RTN","XQ84",203,0) K ^DIC(19,"AXQ","P0","STOP") "RTN","XQ84",204,0) K D,I,W,X,XQK,XQQUE,XQXUF,Y,Z "RTN","XQ84",205,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","XQ84",206,0) Q "RTN","XQ84",207,0) ; "RTN","XQ84",208,0) REPORT(XQTYPE) ;Tell us what happened. "RTN","XQ84",209,0) ; ZEXCEPT: XQSTART,ZTSK ; Kernel exemptions "RTN","XQ84",210,0) N %,X,XQI,XQJ,XQK,XQLINE,XQEND,Y "RTN","XQ84",211,0) I '$D(^XUTL("XQO","MICRO")) S ^XUTL("XQO","MICRO")=0 "RTN","XQ84",212,0) I XQTYPE["MICRO" S ^XUTL("XQO","MICRO")=^XUTL("XQO","MICRO")+1 Q ;Update Micro count "RTN","XQ84",213,0) S XQEND=$$HTE^XLFDT($H) "RTN","XQ84",214,0) I '$D(XQSTART) S XQSTART=XQEND "RTN","XQ84",215,0) S XQLINE=XQSTART_"^"_XQEND_"^"_$P(^VA(200,DUZ,0),U,1)_"^" "RTN","XQ84",216,0) S X=XQTYPE K XQTYPE "RTN","XQ84",217,0) S Y=$S($D(ZTSK):ZTSK,1:"LIVE") "RTN","XQ84",218,0) S XQLINE=XQLINE_X_"^"_Y "RTN","XQ84",219,0) D GETENV^%ZOSV "RTN","XQ84",220,0) S XQLINE=XQLINE_"^"_$P(Y,"^",1,3)_"^"_$J "RTN","XQ84",221,0) I $D(^XUTL("XQO","REBUILDS")) D "RTN","XQ84",222,0) .S (XQJ,XQK)=0 "RTN","XQ84",223,0) .F S XQJ=$O(^XUTL("XQO","REBUILDS",XQJ)) Q:XQJ=""!(XQJ=49) S XQK=XQK+1 "RTN","XQ84",224,0) .F XQI=XQK:-1:1 S ^XUTL("XQO","REBUILDS",XQI+1)=^(XQI) "RTN","XQ84",225,0) .Q "RTN","XQ84",226,0) S ^XUTL("XQO","REBUILDS",1)=XQLINE "RTN","XQ84",227,0) Q "RTN","XQ84",228,0) ; "RTN","XQ84",229,0) NOW ;Is there a rebuild of any kind running right now? "RTN","XQ84",230,0) N % S %=0 "RTN","XQ84",231,0) I $D(^DIC(19,"AXQ","P0","MICRO")) D "RTN","XQ84",232,0) .W !!?6,"Micro surgery is currently updating the compiled menus." "RTN","XQ84",233,0) .I $D(^DIC(19,"AXQ","AXQ","STOP")) D "RTN","XQ84",234,0) ..W !?6,"... but it has been instructed to stop." "RTN","XQ84",235,0) ..Q "RTN","XQ84",236,0) .S %=47 "RTN","XQ84",237,0) .Q "RTN","XQ84",238,0) Q:%=47 "RTN","XQ84",239,0) I $D(^DIC(19,"AXQ","P0")) D "RTN","XQ84",240,0) .W !!?6," A complete menu rebuild is currently running." "RTN","XQ84",241,0) .S %=47 "RTN","XQ84",242,0) .Q "RTN","XQ84",243,0) Q:%=47 "RTN","XQ84",244,0) W !!?6,"There is no menu rebuild activity running on your system right now." "RTN","XQ84",245,0) Q "RTN","XQ84",246,0) ; "RTN","XQ84",247,0) REBUILD(RESULT) ; RPC. [XU REBUILD MENU TREE] public (p629) "RTN","XQ84",248,0) ; input - none (uses DUZ) "RTN","XQ84",249,0) ; output - 0 if unsuccessful, 1 if successful "RTN","XQ84",250,0) N XUN,XQPRIM,XQSEC,XQREACT,XQCNT "RTN","XQ84",251,0) S RESULT=0 "RTN","XQ84",252,0) S XUN=DUZ "RTN","XQ84",253,0) S XQPRIM=$G(^VA(200,XUN,201)) I XQPRIM'>0 Q 0 ; No Primary Menu defined for this user "RTN","XQ84",254,0) S XQCNT=1,XQREACT(XQCNT)=XQPRIM,XQSEC=0 "RTN","XQ84",255,0) F S XQSEC=$O(^VA(200,XUN,203,"B",XQSEC)) Q:XQSEC'=+XQSEC D "RTN","XQ84",256,0) .Q:'$D(^DIC(19,XQSEC,0)) ;Bad pointer don't use it "RTN","XQ84",257,0) .I $P(^DIC(19,XQSEC,0),U,4)="M" S XQCNT=XQCNT+1,XQREACT(XQCNT)=XQSEC "RTN","XQ84",258,0) .Q "RTN","XQ84",259,0) ; "RTN","XQ84",260,0) D REACTQ "RTN","XQ84",261,0) S RESULT=1 "RTN","XQ84",262,0) Q "RTN","XU8PS629") 0^1^B14238522^n/a "RTN","XU8PS629",1,0) XU8PS629 ;ISD/HGW - Post-Install for 629 ;03/22/13 13:45 "RTN","XU8PS629",2,0) ;;8.0;KERNEL;**629**;Mar 20, 2013;Build 17 "RTN","XU8PS629",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XU8PS629",4,0) ; Post Installation Routine for patch XU*8.0*629 "RTN","XU8PS629",5,0) ; "RTN","XU8PS629",6,0) ; Installs entry into the REMOTE APPLICATION file (#8994.5) "RTN","XU8PS629",7,0) ; "RTN","XU8PS629",8,0) ; EXTERNAL REFERENCES "RTN","XU8PS629",9,0) ; BMES^XPDUTL 10141 "RTN","XU8PS629",10,0) ; $$FIND1^DIC "RTN","XU8PS629",11,0) ; UPDATE^DIE 2053 "RTN","XU8PS629",12,0) ; "RTN","XU8PS629",13,0) MAIN ; Control subroutine "RTN","XU8PS629",14,0) N XU8ERRX,XU8DATA "RTN","XU8PS629",15,0) S XU8DATA(1)="VRAM" ; Name "RTN","XU8PS629",16,0) S XU8DATA(2)="KPA VRAM GUI" ; ContextOption Name "RTN","XU8PS629",17,0) S XU8DATA(3)="KPA VRAM GUI" ; ContextOption Menu Text "RTN","XU8PS629",18,0) S XU8DATA(4)="It's better to light a candle than curse the darkness" ; Security phrase "RTN","XU8PS629",19,0) ; For TYPE multiple, each entry should be XU8DATA(n)=CallBackType^CallBackPort^CallBackServer^URLString "RTN","XU8PS629",20,0) ; where n is 5, 6, 7, 8 etc. "RTN","XU8PS629",21,0) S XU8DATA(5)="R"_"^"_"9400"_"^"_"FORUM.DOMAIN.EXT"_"^"_"" "RTN","XU8PS629",22,0) ;S XU8DATA(6)="R"_"^"_"9300"_"^"_"FORUM.DOMAIN.EXT"_"^"_"" "RTN","XU8PS629",23,0) ;S XU8DATA(7)="H"_"^"_"80"_"^"_"VANCRWEBV4.VHA.DOMAIN.EXT"_"^"_"/MDWS2/Web/Validate.aspx" "RTN","XU8PS629",24,0) ;S XU8DATA(8)="H"_"^"_"80"_"^"_"VANCRWEBV5.VHA.DOMAIN.EXT"_"^"_"/MDWS2/Web/Validate.aspx" "RTN","XU8PS629",25,0) S XU8ERRX=$$OPTION(.XU8DATA) ; Create CONTEXTOPTION if doesn't exist "RTN","XU8PS629",26,0) ;D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text" "RTN","XU8PS629",27,0) S XU8ERRX=$$CREATE(.XU8DATA) ; Create REMOTE APPLICATION entry "RTN","XU8PS629",28,0) D BMES^XPDUTL(XU8ERRX) ; XU8ERRX is "Success message" or "Error text" "RTN","XU8PS629",29,0) Q "RTN","XU8PS629",30,0) ; "RTN","XU8PS629",31,0) OPTION(XU8DATA) ; Create CONTEXTOPTION if doesn't exist "RTN","XU8PS629",32,0) N XU8ERR,XU8FDA,XU8IEN,XU8MSG "RTN","XU8PS629",33,0) S XU8IEN=$$FIND1^DIC(19,"","X",XU8DATA(2),"B") "RTN","XU8PS629",34,0) S XU8ERR="Error message: "_XU8IEN "RTN","XU8PS629",35,0) I +XU8IEN>0 S XU8ERR="OPTION exists at IEN = "_XU8IEN "RTN","XU8PS629",36,0) I +XU8IEN=0 S XU8ERR="OPTION "_XU8DATA(2)_" created" D "RTN","XU8PS629",37,0) . S XU8FDA(19,"?+1,",.01)=XU8DATA(2) "RTN","XU8PS629",38,0) . S XU8FDA(19,"?+1,",1)=XU8DATA(3) "RTN","XU8PS629",39,0) . S XU8FDA(19,"?+1,",4)="B" ; B:Broker (Client/Server) "RTN","XU8PS629",40,0) . D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG") "RTN","XU8PS629",41,0) . I $D(XU8MSG) S XU8ERR=" **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create OPTION entry "_XU8DATA(2) "RTN","XU8PS629",42,0) D CLEAN^DILF "RTN","XU8PS629",43,0) Q XU8ERR "RTN","XU8PS629",44,0) ; "RTN","XU8PS629",45,0) CREATE(XU8DATA) ; Create new REMOTE APPLICATION entry "RTN","XU8PS629",46,0) N XU8ERR,XU8FDA,XU8IEN,XU8MSG,XU8I,XU8IENS,DA,DIK "RTN","XU8PS629",47,0) ; Delete existing entry if it exists, before creating updated entry "RTN","XU8PS629",48,0) S XU8IEN=$$FIND1^DIC(8994.5,"","X",XU8DATA(1),"B") "RTN","XU8PS629",49,0) I $G(XU8IEN)>0 D "RTN","XU8PS629",50,0) . S DIK="^XWB(8994.5,",DA=XU8IEN "RTN","XU8PS629",51,0) . D ^DIK "RTN","XU8PS629",52,0) . K XU8IEN "RTN","XU8PS629",53,0) S XU8ERR=" REMOTE APPLICATION entry created: "_XU8DATA(1) "RTN","XU8PS629",54,0) S XU8FDA(8994.5,"?+1,",.01)=XU8DATA(1) ; NAME "RTN","XU8PS629",55,0) S XU8FDA(8994.5,"?+1,",.02)=$$FIND1^DIC(19,"","X",XU8DATA(2),"B") ; CONTEXTOPTION "RTN","XU8PS629",56,0) S XU8FDA(8994.5,"?+1,",.03)=$$EN^XUSHSH(XU8DATA(4)) ; APPLICATIONCODE "RTN","XU8PS629",57,0) D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG") "RTN","XU8PS629",58,0) I $D(XU8MSG) D "RTN","XU8PS629",59,0) . S XU8ERR=" **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to create REMOTE APPLICATION "_XU8DATA(1) "RTN","XU8PS629",60,0) ; Find the REMOTE APPLICATION "RTN","XU8PS629",61,0) S XU8IENS=$$FIND1^DIC(8994.5,"","X",XU8DATA(1),"B") "RTN","XU8PS629",62,0) I +XU8IENS<1 S XU8ERR=XU8IENS Q XU8ERR "RTN","XU8PS629",63,0) ; Fill in CALLBACKTYPE multiple "RTN","XU8PS629",64,0) S XU8I=4 F S XU8I=$O(XU8DATA(XU8I)) Q:XU8I="" D "RTN","XU8PS629",65,0) . N XU8FDA,XU8IEN,XU8MSG,XU8TEST,XU8J,XU8FLAG "RTN","XU8PS629",66,0) . ; Check for duplicates (loop through CALLBACKTYPE for this entry) "RTN","XU8PS629",67,0) . S XU8J=0 F S XU8J=$O(^XWB(8994.5,XU8IENS,1,"B",$E(XU8DATA(XU8I),1,1),XU8J)) Q:(XU8J="")!($D(XU8FLAG)) D "RTN","XU8PS629",68,0) . . I $G(XU8DATA(XU8I))=$G(^XWB(8994.5,XU8IENS,1,XU8J,0)) S XU8FLAG=1 "RTN","XU8PS629",69,0) . I '$D(XU8FLAG) D "RTN","XU8PS629",70,0) . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.01)=$P(XU8DATA(XU8I),"^",1) ; CALLBACKTYPE "RTN","XU8PS629",71,0) . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.02)=$P(XU8DATA(XU8I),"^",2) ; CALLBACKPORT "RTN","XU8PS629",72,0) . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.03)=$P(XU8DATA(XU8I),"^",3) ; CALLBACKSERVER "RTN","XU8PS629",73,0) . . S XU8FDA(8994.51,"+2,"_XU8IENS_",",.04)=$P(XU8DATA(XU8I),"^",4) ; URLSTRING "RTN","XU8PS629",74,0) . . D UPDATE^DIE("","XU8FDA","XU8IEN","XU8MSG") "RTN","XU8PS629",75,0) . . I $D(XU8MSG) D "RTN","XU8PS629",76,0) . . . S XU8ERR=" **ERROR** "_$G(XU8MSG("DIERR",1))_" Unable to update REMOTE APPLICATION "_XU8DATA(1) "RTN","XU8PS629",77,0) ; "RTN","XU8PS629",78,0) D CLEAN^DILF "RTN","XU8PS629",79,0) Q XU8ERR "VER") 8.0^22.0 "BLD",1497,6) ^502 **END** **END**