source: cprs/branches/tmg-cprs/m_files/TMGXUP.m@ 861

TMGXUP   ;TMG/kst/Altered version of XUP ;03/25/06
         ;;1.0;TMG-LIB;**1**;12/23/05
 
 ;"Customized version of Vista XUP module
 ;"===================================================================================
 ;"The following section started as essentially a copy of ^XUP code, to allow me to
 ;" use just part of it to set up the programmers environment
 ;"...As time has gone on, though, I have added more tweaks...
 ;"===================================================================================
XUP()
        ;"Purpose: Because this configurator will be working with the database,
        ;"      it must have a proper environment setup.  And user must have
        ;"      proper access.  So this function will set up everything needed.
        ;"Output: Environmental variables are setup.
        ;"Result: 1=OK to continue.  0=Abort
 
 ;"Consider:
 ;"DT^DICRW: Required Variables
 ;"Sets up the required variables of VA FileMan. There are no input variables;
 ;"simply call the routine at this entry point.
 ;"NOTE: This entry point kills the variables DIC and DIK.
 
        new result set result=cOKToCont
        if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"^XUP")
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Inside XML Scripter, setting up programmer environment.")
 
        ;"MSC/SGS: added to allow processes to be interrupted
        set $ZINT="X ^%ZOSF(""INTERRUPT"")"
        Set U="^"
 
        goto XLp2   ;"bypass next section
        ;"--------------------------------------------------------------------
        ;"Set up user info.
        set DIC=200   ;"file 200 = ^VA(200,*)
        set DIC(0)="MZ"               ;"   "AEQMZ"
        set X="TMGXINST,BOT"
        ;"set X="Dodd,Norman"  ;"Note: came pre-installed in OpenVistA
        do ^DIC
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Y=",Y)
        if Y<0 set result=cAbort goto XUPDone
        kill DIC
        set DUZ=+Y
        set DUZ(0)=$piece(Y(0),U,4)
        set DTIME=600
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"DUZ(0)=",DUZ(0))
        if DUZ(0)'="@" do  goto XUPAbort
        . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to setup a user with programmer's access privilages.")
        ;"--------------------------------------------------------------------
 
XLp2
        new User,UName
        set User=$get(^VA(200,1,0))
        if User="" do  goto XUPAbort
        . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to access user #1 (expected to be IRM,MGR).  The installer should be modified to log in as another user.  Sorry.  Quiting.")
        set UName=$piece(User,"^",1)
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Logging in as user: ",UName)
        set LoggedUsr=UName  ;" setup global-scope variable that script can access
        set UName=$piece(User,"^",1)
        kill DIC
        set DUZ=1
        set DUZ(0)=$piece(User,"^",4)
        set DTIME=600
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"DUZ(0)=",DUZ(0))
        if DUZ(0)'="@" do
        . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Temporarily giving install-user '@' privilages.")
        . set DUZ(0)="@"
 
XLp3
        do HOME^%ZIS    ;"Reset Home Device IO Variables
 
        new $ESTACK,$ETRAP
        set $ECODE="",$ETRAP="" ;"Clear and error trap
        xecute ^%ZOSF("TYPE-AHEAD")
 
        kill ^UTILITY($J)
        kill ^XUTL("XQ",$J)
        do KILL1  ;"do KILL1^XUSCLEAN
 
        set DT=$$DT^XLFDT ;"DT is a system=wide date variable
 
        set XUEOFF=^%ZOSF("EOFF")
        set XUEON=^%ZOSF("EON")
        set U="^"
        set XUTT=0
        set XUIOP=""
        do GETENV^%ZOSV
        set XUENV=Y
        set XUVOL=$piece(Y,U,2)
        set XUCI=$piece(Y,U,1)
 
        ;"Get user info
        if $get(DUZ)>0 do
        . kill XUDUZ
        . if $data(DUZ(0)) set XUDUZ=DUZ(0)
        . do DUZ^XUP(DUZ)
        . if $data(XUDUZ) set DUZ(0)=XUDUZ
        . kill XUDUZ
 
        if ($get(DUZ)'>0)!(('$data(DUZ(0)))) do ASKDUZ^XUP goto:Y'>0 XUPAbort
 
        if '$data(XQUSER) set XQUSER=$S($data(^VA(200,DUZ,20)):$piece(^(20),"^",2),1:"Unk")
        set DTIME=600 ;Set a temp DTIME
 
        ;"Getting Terminal Type
        ;"if XUTT do ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2
        if 'XUTT goto ZIS2a
        do ENQ^XUS1
        if $data(XUIOP(1)) goto ZIS2
        set Y=0
        do TT^XUS3
        if Y>0 set XUIOP(1)=$P(XUIOP,";",2)
        goto ZIS2
ZIS2a
        set X="`"_+$G(^VA(200,DUZ,1.2))
        set DIC="^%ZIS(2,"
        set DIC(0)="MQ"_$S(X]"`0":"",1:"AE")
        do ^DIC
        if Y'>0 goto XUPAbort
        set XUIOP(1)=$P(Y,U,2)
        if DIC(0)["A",$get(^VA(200,+DUZ,0))]"" set $piece(^VA(200,DUZ,1.2),U,1)=+Y
 
ZIS2
        set %ZIS="L"  ;"will cause IO("ZIO") to contain static physical port name
        set IOP="HOME;"_XUIOP(1)
        do ^%ZIS    ;"Set up device handler
        if POP goto XUPAbort ;"POP has error from ^%ZIS
        if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Using terminal type: ",IOST)
        set DTIME=$$DTIME^XUP(DUZ,IOS)
        set DUZ("BUF")=1
        set XUDEV=IOS
 
        ;"Save info, Set last sign-on
        do SAVE^XUS1
        set $piece(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT   ;DT
 
        ;"Setup error trap
        if $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") set $ETRAP="D ERR^XUP"
        ;do KILL1  ;"do KILL1^XUSCLEAN
        set $piece(XQXFLG,U,3)="XUP"
 
        ;"D ^XQ1  ;<----- one major change made to this code...
 
XUPDone
        if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"^XUP")
        quit result
 
XUPAbort
        do KILL1   ;"do KILL1^XUSCLEAN
        kill XQY,XQY0
        if $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$data(^%ZVEMS) xecute ^%ZVEMS ;"Run VPE
 
        set result=cAbort
        goto XUPDone
 
KILL1
        ;"--------------------------------
        ;"KILL1^XUSCLEAN is included and modified below.
        ;"Purpose: To clean up ALL but kernel variables.
        ;"-------------------------------
        If $$BROKER^XWBLIB do
        . set %2=$piece($text(VARLST^XWBLIB),";;",2)
        . if %2]"" new @%2 ;"Protect Broker variables.
 
        new KWAPI,XGWIN,XGDI,XGEVENT
        new XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID
 
        kill IO("C"),IO("Q")
 
        ;"Note: kill (x) mean kill everything EXCEPT x
        ;"I can't kill everthing because it will crash my script--so I'll just not do it.
        ;"kill (DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,U,DUZ,DUZ,DTIME,DT)
 
        quit
 
 ;"===================================================================================