4:51 PM  26-MAY-99
XQ72,ZIBGSVEM,ZIBGSVEP,ZISHMNT,ZISHMSMU,ZU,ZUMSM patches to Krn 8 patch 5- restore to your production UCI's
XQ72
XQ72 ;SEA/MJM - ^Jump Utilities ;05/08/98  10:16
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;8.0;KERNEL;**47,46**;Jul 03, 1995
 ;
JUMP ;Entry point for D+1^XQ and  LEGAL^XQ74.
 ;With +XQY: target opt, XQY0: 0th node with pathway, XQY1: parent's
 ;0th node; XQ(XQ) array of alternate pathways, if any; XQDIC:
 ;P-tree of target option; XQPSM: XQDIC or mutiple trees (U66,P258)
 ;XQSV: XQY^XQDIC^XQY0 of origin (previous) option.
 ;
 ;** Variables **
 ;XQFLAG=1 usually means we're done.  Head for the door.
 S XQJMP=1 ;Flag indicating we are in a jump process
 N XQFLAG,XQI,XQJ,XQTT,XQSTK,XQSVSTK,XQONSTK,XQOLDSTK
 ;
 ;Get current stack pointer and Primary Menu tree, set "all done" flag
 S XQTT=^XUTL("XQ",$J,"T"),XQPMEN="P"_^("XQM")
 ;
 ;If we are already in a rubber-band jump, unwind it
 I $D(^XUTL("XQ",$J,"RBX")) S XQFLG=1,XQSAV=XQY_U_XQPSM_U_XQY0,XQY=+^("RBX"),XQY0=$P(^("RBX"),U,2,99) D RBX^XQ73 S XQY=+XQSAV,XQPSM=$P(XQSAV,U,2),XQY0=$P(XQSAV,U,3,99) K XQFLG,XQSAV
 ;
 ;Get the stack and see if target option is already on it
 S XQSTK=""
 F XQI=1:1:XQTT S XQOLDSTK(XQI)=^XUTL("XQ",$J,XQI),XQSTK=XQSTK_+XQOLDSTK(XQI)_","
 ;
 I (","_XQSTK)[(","_XQY_","),'$D(XQRB) D NOJ^XQ72A G OUT
 ;
 ;See if target option is in the current display tree (+XQDISTR)
 S XQDISTR=+XQSV
 I $S('$D(^XUTL("XQO",XQDISTR,0)):1,'$D(^DIC(19,XQDISTR,99)):1,^DIC(19,XQDISTR,99)'=$P(^XUTL("XQO",XQDISTR,0),U,2):1,1:0) L +^XUTL("XQO",XQDISTR):5 S XQSAVE=XQDIC,XQDIC=XQDISTR D ^XQSET L -^XUTL("XQO",XQDISTR) S XQDIC=XQSAVE
 I $D(^XUTL("XQO",XQDISTR,"^",+XQY)),($P(^(+XQY),U,6)=+XQY!($P(^(+XQY),U,6)="")) S XQY0=$P(^(+XQY),U,2,99),^DISV(DUZ,"XQ",XQDISTR)=XQY G OUT
 ;
 ;Set XQMA to the parent of the tree we're jumping from
 S XQMA=$P(XQSV,U,2)
 I XQMA']"" S XQMA=XQY
 ;
 ;Find shortest path to target if there are more than one in XQ(XQ)
 I $D(XQ),XQ>0 D MPW G:XQ<0 OUT
 ;
 ;Get jump path and add parent menu option.
 S XQJP=$P(XQY0,U,5)
 I XQPSM["PXU" S %=0,%=$O(^DIC(19,"B","XUCOMMAND",%)),XQJP=%_","_XQJP
 I XQPSM["," S %=$P(XQPSM,",",2),XQJP=$P(%,"P",2)_","_XQJP
 S XQNP=XQTT_U_XQJP
 ;
 ;Save stack as it was before we messed with it.
 S XQSVSTK=XQTT_U_XQSTK
 S XQONSTK="" ;Those options we put on the stack are collected here.
 ;
 ;
 ;** BEGIN PROCESSING PRIMARY AND SECONDARY JUMPS **
 ;
 S XQNOW=^XUTL("XQ",$J,XQTT)
 ;
 ;See if we are jumping FROM a Secondary menu tree
 S XQFLAG=0
 S XQSFROM=$S($P(XQNOW,U)["U":1,1:0)
 I XQSFROM D
 .N %,XQI,XQT,XQDIC
 .S XQT=XQTT
 .S XQDIC=XQPSM I XQDIC["," S XQDIC=$P(XQDIC,",",2)
 .I $D(^XUTL("XQO",XQDIC,U,+XQSV)) S XQFLAG=1 D SAMTREE Q  ;target in current tree.
 .F XQI=XQT:-1:1 S %=$P(^XUTL("XQ",$J,XQI),U,1) Q:%'[","&(%'["PXU")  D POP(XQI) ;Remove current secondary from the stack
 .Q
 G:XQFLAG B1
 ;
 ;See if we're staying in the Primary Menu's tree
 S XQFLAG=0
 I $D(^XUTL("XQO",XQPMEN,U,XQY)) D
 .S XQJP=XQMA_","_XQJP
 .S XQFLAG=1
 .D:XQTT>1 SAMTREE
 .Q
 G:XQFLAG B1
 ;
 ;See if we are jumping TO a secondary menu: just load and go.
 S XQSTO=0
 S XQFLAG=0
 I XQPSM["U" D
 .S XQSTO=1
 .S XQFLAG=1
 .I XQPSM["," S XQDIC=$P(XQPSM,",",2)
 .S (^XUTL("XQ",$J,"T"),XQST)=XQTT
 .Q
 ;
 ;
 ;
B1 ;Get the path of options and process them one by one
 S XQZ=$P(XQNP,U,2) I '$L(XQZ) S ^XUTL("XQ",$J,"T")=1 G OUT
 I '$D(XQUIT) F XQSTPT=1:1 S XQD=$P(XQZ,",",XQSTPT) Q:(+XQD=+XQY)!('$L(XQD))  D JUMP1 I $D(XQUIT) S XQUIT=2,XQOPQT=XQD D ^XQUIT Q:$D(XQUIT)  D RXQ
 ;
 S:'$D(XQUIT) ^DISV(DUZ,"XQ",XQMA)=XQY,XQY0=$P(^XUTL("XQO",XQDIC,U,+XQY),U,2,5)_"^^"_$P(^(+XQY),U,7,11)_"^^"_$P(^(+XQY),U,13)_"^^"_$P(^(+XQY),U,15,99)
 ;
 ;
OUT ;Reset the stack pointer, clean up, and return to XQ
 S:'$D(XQUIT) ^XUTL("XQ",$J,"T")=$S(XQTT'<1:XQTT,1:1)
 ;
 K %,%XQJP,X,XQ,XQCH,XQD,XQDISTR,XQEX,XQI,XQII,XQJ,XQJMP,XQJP,XQJS,XQK,XQMA,XQN,XQNO,XQNOW,XQNO1,XQNP,XQOLDSTK,XQPMEN,XQSAV,XQSTO,XQSFROM,XQST,XQSTK,XQSTPT,XQSVSTK,XQT,XQTT,XQV,XQW,XQY1,XQZ,Y,Z
 ;
 I $D(XQUIT) K XQUIT G M1^XQ
 G M^XQ
 ;
 ;
 ;** SUBROUTINES **
 ;
POP(XQSTPT) ;Pop one level on the stack
 ;Execute Exit Actions and Headers
 N %,XQY,XQY0
 S %=^XUTL("XQ",$J,XQSTPT)
 S XQY=+%,XQY0=$P(%,U,2,99)
 I $P(XQY0,U,15),$D(^DIC(19,XQY,15)),$L(^(15)) X ^(15) ;W " ==> POP^XQ72"
 S %=^XUTL("XQ",$J,XQSTPT-1)
 S XQY=+%,XQY0=$P(%,U,2,99)
 I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26) ;W " ==> POP^XQ72"
 I '$D(XQTT) S XQTT=^XUTL("XQ",$J,"T")
 S XQTT=XQTT-1 ;Reset stack pointer to next option
 Q
 ;
JUMP1 ;Check pathway for prohibitions
 ;Push intermediate option onto the stack
 ;Execute Entry Actions and Headers
 S XQST=+XQNP
 S XQY0=$S($D(^XUTL("XQO",XQMA,U,+XQD))#2:$P(^(+XQD),U,2,99),1:^DIC(19,+XQD,0)),XQMA=XQD
 S ^XUTL("XQ",$J,XQTT+1)=XQD_XQPSM_U_XQY0 ;,^("T")=XQST+XQSTPT
 I $P(XQY0,U,14) Q:'$D(^DIC(19,XQD,20))  Q:'$L(^(20))  X ^(20) ;W " ==> JUMP1^XQ72"
 Q:$D(XQUIT)
 ;
RXQ ;Return if XQUIT is cancelled by the application
 I $P(XQY0,U,17),$D(^DIC(19,XQD,26)),$L(^(26)) X ^(26) ;W " ==> JUMP1^XQ72"
 S XQTT=XQTT+1 ;Reset stack pointer
 S XQONSTK=XQTT_U_XQONSTK
 Q
 ;
MPW ;Multiple paths, choose shortest or best
 S XQ(XQ+1)=$P(XQY0,U,5),XQJ=1,%="" F XQI=0:0 S %=$O(XQ(%)) Q:%=""!(%'=+%)  S XQ(XQJ)=XQ(%),XQJ=XQJ+1
 S XQ=XQJ-1 F XQJ=1:1:$L(XQSTK,",")-2 S X=","_$P(XQSTK,",",XQJ)_"," F XQI=1:1:XQ S %=","_XQ(XQI) I %[X,'$D(Y(XQI)) S XQ(XQI)=$E(X,2,99)_$P(XQ(XQI),X,2,99),Y(XQI)=""
 F XQI=1:1:XQ S %($L(XQ(XQI),","),XQI)=XQ(XQI)
 S X="",Z=1 F XQI=1:1:XQ S X=$O(%(X)) Q:X=""  S Y="" F XQJ=0:0 S Y=$O(%(X,Y)) Q:Y=""  S XQ(Z)=%(X,Y),Z=Z+1
 F XQI=1:1:XQ S %XQJP=XQ(XQI) Q:%XQJP=""  D JMP^XQCHK Q:$L(%XQJP)
 I %XQJP="" W " ??",*7 S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99),XQ=-1 Q
 S XQY0=$P(XQY0,U,1,4)_U_XQ(XQI)_U_$P(XQY0,U,6,99)
 Q
 ;
SAMTREE ;Jump target is in the same tree, find the modified path
 N XQI,XQJ,XQY1
 ;Find in XQI the 1st option in XQJP not already on the stack
 F XQI=1:1:$L(XQJP,",")-1  Q:XQSTK'[($P(XQJP,",",XQI)_",")
 ;Remove that part of jump path already on the stack
 S XQNP=$P(XQJP,",",XQI,99),XQNP=$L(XQNP,",")-1_U_XQNP
 ;
 ;Calculate where we push XQNP (the new path) onto the stack
 S %=$P(XQJP,",",1,XQI-1),XQY1=$P(%,",",$L(%,","))
 ;
 ;Pop the stack until we are pointing to where we need to be
 F XQM=XQTT:-1:2 Q:$P(XQSTK,",",XQM)=XQY1  D POP(XQM)
 Q
 ;
 ;
SOLVE(XQY1,XQJP,XQNP) ;See if and where we are on the jump path.
 ;Returns the remainder of XQJP after XQY1 and everything
 ;under it is removed from the path.  With XQJP = "1,2,3,4,5,"
 ;and XQY1 = 3 (or "3,"; or "2,3"; or "1,2,3,") it returns XQNP
 ;equal to "4,5,".  If XQY1 is not in XQJP, XQNP is returned as
 ;null.
 ;
 N X,IN,OUT
 S IN=+XQY1
 S X=$S(XQY1[",":1,1:0) ;Is it a string or a number?
 S XQNP=$P($E(XQJP,$F(XQJP,XQY1)-X,99),",",2,99)
 I +XQNP=IN S XQNP="" ;No match
 Q

ZIBGSVEM
ZIBGSVEM ; IHS/ADC/GTH - SAVE GLOBAL TO MSM UNIX ; [ 11/02/1998  1:50 PM ]
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
 ;
 I ^%ZOSF("OS")["PC"!(^%ZOSF("OS")["Windows NT")!($P($G(^AUTTSITE(1,0)),U,21)=2) G ^ZIBGSVEP
 G:$D(XBMED) NOSELT
ASK ;
 R !!,"Copy transaction file to  ('^' TO EXIT WITHOUT SAVING)",!!?10,"[T]ape, [C]artridge, [D]iskette, or [F]ile   F// ",XBMED:DTIME
 S XBMED=$$UP^XLFSTR($E(XBMED_"F"))
 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
 G HELP:"?"[XBMED,ASK:'("CDFT"[XBMED)
NOSELT ;
 S (IO,XBZDEV)=XBIO
 D TAPE:"T"[XBMED,CART:"C"[XBMED,DISK:"D"[XBMED,UNIX:"F"[XBMED
 Q
 ;
HELP ;
 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a tape,",!,"a floppy diskette, or a Unix file. The default is to a unix file",!,"in the ",XBUF," directory."
 W !,"Enter either a ""C"" for tape cartridge, a ""T"" for 9-track tape, a ""D"" for floppy disk, or an ""F"" for Unix file."
 G ASK
 ;
DISK ; -----  Transfer TX Global to floppy disk.
 U IO(0)
 W !!,"Mount a FORMATTED Floppy Diskette, 'WRITE ENABLED' ",*7,!,"Press RETURN When Ready  or ""^"" to Exit WITHOUT SAVING "
 R X:DTIME
 I X[U!('$T) S XBFLG(1)="Job Aborted by Operator During Floppy Mount",XBFLG=-1 G END
 I $$OPEN^%ZISH("/dev/","fd0","W") S XBERRMSG="Floppy Disk" G ERRMESS
 U IO
 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G DISK
 U IO(0)
 W !,"Please Standby - Copying Data to Floppy",!
 U IO
 D SAVEMSM
 D ^%ZISC
 U IO(0)
 R !!,"Remove the Floppy... Press RETURN when Ready:",X:DTIME
 G END
 ;
UNIX ; -----  Transfer TX Global to unix file.
 S XBPRE=$E(XBGL,2,5),XBASUFAC=$S('$D(XBSUFAC):$P(^AUTTLOC(DUZ(2),0),U,10),1:XBSUFAC)
 S XBFN=$S('$D(XBFN):XBPRE_XBASUFAC_"."_XBCARTNO,1:XBFN)
 S XBTEMPFN=XBUF_"/"_XBFN
 S %=$$OPEN^%ZISH(XBUF_"/",XBFN,"W")
 I % S XBERRMSG=$S(%=1:"All Host File Servers Busy!",1:"UNIX File") G ERRMESS
 I '$D(ZTQUEUED) U IO(0) W !,"Please Standby - Copying Data to UNIX File ",XBTEMPFN,!
 S X=$$JOBWAIT^%HOSTCMD("chmod 666 "_XBUF_"/"_XBFN)
 U IO
 D SAVEMSM
 G CLOSE
 ;
TAPE ;
 S XBDEV="rmt0",XBMSG="9-Track"
 G TAPETST
CART ;
 S XBDEV="rct",XBMSG="Cartridge"
 ;
TAPETST ; -----  Transfer global to cartridge or 9-track.
 W !,"Do you want to test the ",XBMSG," DRIVE? (Y/N) Y//"
 R Y:DTIME
 S Y=$E(Y_"Y")
 I "Yy"[Y D TAPETEST G:$D(XBFLG) CLOSE I Y[U S XBFLG(1)="Job Aborted by Operator During Tape Test",XBFLG=-1 G END
S ;
 U IO(0)
 W !!,"Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
 R !,"Press RETURN When Ready  - ""^"" to Exit ",X:DTIME
 I X[U S XBFLG(1)="Job Terminated By Operator at Mount Message",XBFLG=-1 G CLOSE
MAGOPEN ;
 I $$OPEN^%ZISH("/dev/",XBDEV,"W") S XBERRMSG="Magtape Device" G ERRMESS
 U IO
 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G S
 U IO(0)
 W !,"Please Standby - Copying Data to Tape",!
 U IO
 D SAVEMSM
 G EXIT
 ;
SW ;
 U IO(0)
 W *7,!!,"  The Tape Is WRITE PROTECTED. Please Remove The Tape,"
 W !,"  And Re-position The Write Protect/Enable Switch.",!,"  "
 G MAGOPEN
 ;
ERRMESS ;
 S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1
 I '$D(ZTQUEUED) U IO(0) W !,XBFLG(1)
 G END
 ;
EXIT ;
 D ^%ZISC
 U IO(0)
 W !!,"Rewinding tape. <WAIT>."
 H 2
 W !!,"Remove the tape... Press RETURN when Ready:"
 R X:DTIME
 G END
 ;
CLOSE ;
 D ^%ZISC
END ;
 I XBMED="F",'$D(XBFLG),XBQ="Y" D UUCPQ
 D HOME^%ZIS
 KILL XBPRE,XBASUFAC,XBOUTDAT,XBINDATA,XBDEV,XBMSG,XBERRMSG,XBTEMPFN,XBZDEV
 Q
 ;
TAPETEST ;
 U IO(0)
 W !!,"TAPE TEST...Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
 R !,"TAPE TEST...Press RETURN When Ready  - ""^"" to Exit ",X:DTIME
 I X[U S XBFLG(1)="Job Aborted by Operator during Tape Test",XBFLG=-1 Q
 W !,"TAPE TEST...Opening tape drive."
 H 1
 I $$OPEN^%ZISH("/dev/",XBDEV,"W") G TESTERR
 U IO
 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G TAPETEST
 U IO(0)
 W !,"TAPE TEST...Tape drive opened.",!,"TAPE TEST...Writing test data to tape."
 H 1
WRITE ;
 S XBOUTDAT="TEST DATA RECORD WRITTEN TO TAPE ON "_XBDT
 U IO
 W XBOUTDAT,!,"**",!,"**",!!
 U IO(0)
 W !,"TAPE TEST...Data written."
 D ^%ZISC
 H 6
 U IO(0)
 W !,"TAPE TEST...Reading test data from tape.",!
 H 1
 I $$OPEN^%ZISH("/dev/",XBDEV,"R") G TESTERR
 U IO
 R XBINDATA:DTIME
 D ^%ZISC
 U IO(0)
 W !,"WROTE : '",XBOUTDAT,"'",!," READ : '",XBINDATA,"'"
 I XBINDATA=XBOUTDAT W !,"TAPE TEST...Successful."
 E  W !,"TAPE TEST...FAILED...$#@!" S XBFLG(1)="Tape Test Failed During Testing",XBFLG=-1
 Q
 ;
TESTERR ;
 S XBFLG(1)="Device Not Available During Tape Testing",XBFLG=-1
 U IO(0)
 W !,*7,XBFLG(1),*7
 Q
 ;
UUCPQ ;auto queue to uucp subroutine, must have system id in RPMS SITE file
 I $$JOBWAIT^%HOSTCMD("/usr/bin/sendto "_XBQTO_" "_XBUF_"/"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed"
 E  W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",!
 Q
 ;
SAVEMSM ;EP - $QUERY thru global, write to output.
 I '$G(XBFLT) W XBDT,!,XBTLE,!
 S X=XBGL_XBF_")"
 F  S X=$Q(@X) Q:X=""  S Y=$P($P($P(X,")",1),"(",2),",",1) Q:($L(XBE)&($$FOLLOW(Y,XBE)))  Q:$D(XBCON)&('(Y=+Y))  S Y=X S:$E(Y,2)="[" Y=U_$P(Y,"]",2,999) W:'$G(XBFLT) Y,! W @X,!
 I '$G(XBFLT) W "**",!,"**",!!
 Q
 ;
FOLLOW(Y,XBE) ; If Y follows XBE return 1.  Else return 0.
 I '(Y=+Y) S Y=$E(Y,2,$L(Y)-1)
 Q $S(Y]XBE:1,1:0)
 ;

ZIBGSVEP
ZIBGSVEP ; IHS/ADC/GTH - SAVE GLOBAL TO DOS MEDIA ; [ 11/03/1998  9:27 AM ]
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
 ;
 S XBUF=$S($P($G(^AUTTSITE(1,1)),U,2)]"":$P(^AUTTSITE(1,1),U,2),1:"C:\EXPORT")
 G:$D(XBMED) NOSELT
ASK ;
 R !!,"Copy transaction file to ('^' TO EXIT WITHOUT SAVING)",!!?10,"[D]iskette, or [F]ile   F// ",XBMED:DTIME
 S XBMED=$$UP^XLFSTR($E(XBMED_"F"))
 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
 G HELP:"?"[XBMED,ASK:"DF"'[XBMED
NOSELT ;
 S IO=XBIO
 D DISK:"D"[XBMED,DOS:"F"[XBMED
 Q
 ;
HELP ;
 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a floppy",!,"diskette, or a Dos file on the Hard Disk. The default is to a Dos file",!,"in the ",XBUF," directory."
 W !,"Enter either a ""D"" for floppy disk, or an ""F"" for Dos file."
 G ASK
 ;
DISK ;TRANSFER TX GLOBAL TO FLOPPY DISK
 F  R !,"Select the drive (A,B,C):  B//",Y:DTIME S Y=$$UP^XLFSTR($E(Y_"B")) Q:"ABC"[Y  W:'(U[Y) "  ??" I U[Y!('$T) S XBFLG(1)="Abort at drive select",XBFLG=-1 G END
 S XBUF=Y_":"
 W !!,"Insert a FORMATTED Floppy Diskette into drive '",XBUF,"', 'WRITE ENABLED' ",*7,!,"Press RETURN When Ready  or ""^"" to Exit WITHOUT SAVING "
 R X:DTIME
 I X[U!('$T) S XBFLG(1)="Job Aborted by Operator During Floppy Mount",XBFLG=-1 G END
DOS ;TRANSFER TX GLOBAL TO DOS FILE.
 I '$D(ZTQUEUED) U IO(0) W !!,"DOS File Being Created' ",*7
 I '$D(XBFN) D
 .; if you're on NT put the full location code to be compatible with
 .; area unix boxes
 .I ^%ZOSF("OS")["Windows NT" S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S X=X+1,XBFN=$E(XBGL,2,5)_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_X Q
 .S X2=$E(DT,1,3)_"0101",X1=DT D ^%DTC S X=X+1,XBFN=$E(XBGL,2,5)_$E($P(^AUTTLOC(DUZ(2),0),U,10),3,6)_"."_X
 I $$OPEN^%ZISH(XBUF_"\",XBFN,"W") S XBERRMSG="DOS File" G ERRMESS
 U IO(0)
 W !,"Please Standby - Copying Data to DOS File ",XBUF,"\",XBFN
 U IO
 D SAVEMSM^ZIBGSVEM
 G END
 ;
UUCPQ ;auto queue to sendto and ftp, must have system id in RPMS SITE file
 I $$JOBWAIT^%HOSTCMD("sendto "_XBQTO_" "_XBUF_"\"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed"
 E  W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",!
 Q
 ;
ERRMESS ;
 S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1
 U IO(0)
 W !,XBFLG(1)
END ;
 I '$D(AUFLG),$P(^AUTTSITE(1,0),"^",14)]"" D UUCPQ ;IHS/MFD added line
 D ^%ZISC,HOME^%ZIS
 KILL XBERRMSG
 Q

ZISHMNT
%ZISH ;IHS\PR,SFISC/AC - Host File Control for MSM ;05/21/98  11:17 [ 04/21/99  8:45 AM ]
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;8.0;KERNEL;**24,36,49,65,84**;JUL 10, 1995
 ;
OPEN(X1,X2,X3,X4,X5)    ;SR. Open Host File
 I '$D(X4) Q $$OPEN^ZISHMSMD(X1,X2,X3); IHS/ANMC/LJF 6/1/98
 ;X1=handle name
 ;X2=directory name \dir\
 ;X3=file name
 ;X4=file access mode e.g.: W for write, R for read, A for append, B for block.
 ;X5=Max record size for a new file
 N %,%1,%2,%I,%P1,%P2,%P6,%T,%ZA,%ZISHIO
 S %I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%Q=$C(34) M %ZISHIO=IO
 S %P2=$S(X4["RW":"RW",X4["W":"W",X4["N":"W",X4["A":"A",1:"R")
 S %P1=X2_X3,%P6=$S(X4["B":%Q_%Q,1:$C(13,10))
 F %2=51:1:54 I '$D(IO(1,%2)) O %2:(%P1:%P2::::%P6):0 I $T S %T=%2 Q
 I '%T S POP=1 Q
 ;S %1=$$MODE^%ZISF(X2_X3,X4)
 U %2 S %ZA=$ZA
 I %ZA=-1 U:%I]"" %I C %2 S POP=1 Q
 S IO=%2,IO(1,IO)="",IOT="HFS",POP=0
 I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
 Q
 ;
CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
 ;X=HANDLE NAME, IO=Device
 N %
 I $G(IO)]"" C IO K IO(1,IO)
 I $G(X)]"" D RMDEV^%ZISUTL(X)
 D HOME^%ZIS
 Q
 ;
OPENERR ;
 Q 0
 ;
DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
 ;S Y=$$DEL^ZOSHMSM("\dir\","fl")
 ;                         ,.array)
 ;Changed %ZX2 to a $NAME string
 N %,%ZH,ZOSHDA,ZOSHF,ZOSHX,ZOSHQ,ZOSHDF,ZOSHC
 S %ZX1=$$DEFDIR($G(%ZX1)) S:$D(@%ZX2)=1 @%ZX2(@%ZX2)=""
 ;Get fls to act on
 ;No '*' allowed
 S %ZH="" F  S %ZH=$O(@%ZX2@(%ZH)) Q:'%ZH  I %ZH["*" S ZOSHQ=1 Q
 Q:$D(ZOSHQ) 0
 S %ZH="" F   S %ZH=$O(@%ZX2@(%ZH)) Q:%ZH=""  D
 .;S ZOSHC="rm "_X1_%
 .S ZOSHC=$ZOS(2,%ZX1_%ZH) ;Use system function to delete file
 Q 1
 ;
LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding fl names
 ;S Y=$$LIST^ZOSHDOS("\dir\","fl",".return array")
 ;                           "fl*",
 ;                           .array,
 ;IHS/HQW/JLB 2/16/99 Enables NT to read directory of files
 ;IHS/OKCAO/POC 1/22/99
 D LIST1
 Q VAR
LIST1 ;
 S VAR=1 ;VAR=1 MEANS NO FILES OR A PROBLEM
 I $G(%ZX1)']""!($G(%ZX2)']"") Q   ;PROBLEM
 D DF(.%ZX1); IHS/AAO/RPL 4/21/99
 S X=$ZOS(12,%ZX1_%ZX2,0) Q:$P(X,"^")=""  S %ZX3(1)=$P(X,"^",1); IHS/AAO/RPL 4/14/99 changed %ZX3(0) to %ZX3(1) to start counting with 1 not 0
 F I=2:1 S X=$ZOS(13,X) Q:$P(X,"^",1)=""  S %ZX3(I)=$P(X,"^",1); IHS/AAO/RPL changed F I=1:1 to F I=2:1
 I $P(X,"^")'="" S X=$ZOS(16,X)
 S VAR='$D(%ZX3)
 Q 
 ;
 ;Change X2 = $NAME OF CLOSE ROOT
 ;Change X3 = $NAME OF CLOSE ROOT
 ;
 N %ZISH,%ZISHN,%ZX,%ZISHY
 S %ZISHN=0,%ZX1=$$DEFDIR($G(%ZX1)) S:$D(@%ZX2)=1 @%ZX2(@%ZX2)=""
 ;Get fls to act on
 S %ZISH="" F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
 .S %ZX=%ZX1_%ZISH
 .F %ZISHN=1:1 D  Q:$P(%ZISHY,"^")=""!(%ZISHY<0)  S @%ZX3@($P(%ZISHY,"^"))="" ;S @%ZX3@(%ZISHN)=$P(%ZISHY,"^")
 ..I %ZISHN>1 S %ZISHY=$ZOS(13,%ZISHY)
 ..E  S %ZISHY=$ZOS(12,%ZX,0)
 Q $O(@%ZX3@(""))]""
 ;
MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
 ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl")
 ;
 N %ZB,%ZC,%ZISHDV1,%ZISHDV2,%ZISHFN1,%ZISHFN2,%ZISHPCT,%ZISHSIZ,%ZISHX,X,Y
 S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
 I X1=Y1 Q $ZOS(3,X2,Y2)'<0
 S X=X1_X2,Y=Y1_Y2
 ;
 S %ZISHDV1=51,%ZISHDV2=52,%ZISHFN1=X,%ZISHFN2=Y
 O %ZISHDV1:(%ZISHFN1)
 O %ZISHDV2:(%ZISHFN2:"W")
 U %ZISHDV1:(::0:2) S %ZISHSIZ=$ZB U %ZISHDV1:(::0:0) S (%ZISHPCT,%ZB,%ZC)=0
 D SLOWCOPY S %ZISHX(X2)="" S Y=$$DEL^%ZISH(X1,$NA(%ZISHX))
 Q 1
 ;
SLOWCOPY ; Copy without view buffer
 N X,Y
 O %ZISHDV1:(%ZISHFN1:"R"::::""),%ZISHDV2:(%ZISHFN2:"W"::::"")
 FOR  DO  Q:%ZC!(%ZB=%ZISHSIZ)
 . U %ZISHDV1 R X#1024 Q:$L(X)=0
 . U %ZISHDV2 W X S %ZB=$ZB,%ZC=$ZC Q:%ZC
 . I %ZB=%ZISHSIZ C %ZISHDV2 S %ZC=($ZA=-1)
 . S X=%ZB/%ZISHSIZ*100\1 ; %done
 . Q:X=%ZISHPCT  S %ZISHPCT=X
 . Q  ;U 0 W $J(%ZISHPCT,3),*13
 Q
 ;
PWD(X) ;ef,SR. Print working directory
 Q $$PWD^ZISHMSMD(.X) ; IHS/ANMC/LJF 2/19/97 
 N Y
 S Y=$$DEFDIR("") I $L(Y) Q Y
 S Y=$ZOS(11,$ZOS(14))
 Q:Y<0 ""
 S Y=Y_$S($E(Y,$L(Y))'="\":"\",1:"")
 Q $ZOS(14)_":"_Y
 ;
JW ;Call dos $ZOS
 S ZOSHX=$ZOS(ZOSHNUM,ZOSHC)
 Q
DF(X) ;Dir frmt  ; IHS/MFD added subroutine and edited for NT/DOS
 Q:X=""
 S X=$TR(X,"/","\")
 I $E(X,$L(X))'="\" S X=X_"\"
 Q
DEFDIR(DF) ;ef. Default Dir and frmt
 Q:DF="." "" ;Special way to get current dir.
 S:DF="" DF=$G(^XTV(8989.3,1,"DEV")) S DF=$TR(DF,"/","\")
 I $E(DF,$L(DF))'="\" S DF=DF_"\"
 Q DF
FL(X) ;Fl len
 N ZOSHP1,ZOSHP2
 S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
 ;DONT CARE IF LESS THAN 3 OR GREATER THAN 8 ON NT BOX IHS/OKCAO/POC 1/25/99
 ;I $L(ZOSHP1)>8 S X=4 Q
 ;I $L(ZOSHP2)>3 S X=4 Q
 Q
READNXT(REC) ;Read any sized record into array.
 N T,I,X,LB
 U IO S LB=$ZB R REC#255 S %ZA=$ZA,%ZB=$ZB,%ZC=$ZC,%ZL=%ZA Q:$$EOF(%ZC)
 Q:%ZA<255
 F I=1:1 S LB=LB+%ZA Q:LB<%ZB  R X#255 S %ZA=$ZA,%ZB=$ZB,%ZC=$ZC Q:$$EOF(%ZC)!('$L(X))  S REC(I)=X
 Q
STATUS() ;ef,SR. Return EOF status
 U $I
 Q $$EOF($ZC)
 ;
EOF(X) ;Eof flag, pass in $ZC
 Q (X=-1)
 ;
READREC(X) ;Read record from host file.
 N Y
 U IO R X S Y=$ZC
 U $P
 Q Y
MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
 ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
 N I,F,MX
 S OVF=$G(OVF,"%ZISHOF")
 S %ZISHI=$QS(HF,IX),MX=$QL(HF) ;
 S F=$NA(@HF,IX-1) ;Get first part
 I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
 I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
 S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
 F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I)
 S %ZISHF=%ZISHF_")"
 Q
FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
 ;p1=host file directory 
 ;p2=host file name
 ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
 ;p4=INCREMENT SUBSCRIPT
 ;p5=Overflow subscript, defaults to "OVF"
 N %ZA,%ZB,%ZC,%ZL,%OVFCNT,%CONT,%XX
 N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB
 S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
 D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
 D OPEN^%ZISH(,%ZX1,%ZX2,"R")
 I POP Q 0
 S X="ERREOF^%ZISH",@^%ZOSF("TRAP")
 U IO F  K %XX D READNXT(.%XX) D  Q:$$EOF(%ZC)
 . S I=('$$EOF(%ZC))!($$EOF(%ZC)&$L(%XX)) Q:'I
 . S @%ZISHF=%XX
 . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT))  S @%ZISHO=%XX(%OVFCNT)
 . S %ZISHI=%ZISHI+1
 . Q
 D CLOSE() ;Normal exit
 Q 1
 ;
ERREOF D CLOSE() ;Error close and exit
 Q 0
 ;
GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
 ;Previously name LOAD
 ;p1=$NAME of global reference
 ;p2=incrementing subscript
 ;p3=host file directory, p4=host file name
 N %ZISHY,%ZISHOX
 S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W")
 Q %ZISHY
 ;
GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
 ;
 ;p1=$NAME of global reference
 ;p2=incrementing subscript
 ;p3=host file directory
 ;p4=host file name
 N %ZISHY
 S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A")
 Q %ZISHY
MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
 ;p1=$NAME of global reference
 ;p2=incrementing subscript
 ;p3=host file directory
 ;p4=host file name
 N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y
 D MAKEREF(%ZX1,%ZX2)
 D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open
 I POP Q 0
 N X
 S X="ERREOF^%ZISH",@^%ZOSF("TRAP")
 F  Q:'($D(@%ZISHF)#2)  S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
 D CLOSE()
 Q 1
 ;

ZISHMSMU
ZISHMSMU ; IHS/DSM/MFD - HOST COMMANDS FOR UNIX (MSMU); [ 04/21/99  9:00 AM ]
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;8.0;KERNEL;;JUL 10, 1995
 ;
 ; Excepted from IHS SAC 6.1.5, 6.1.2.2 and 6.1.2.3 memo dated 16Nov93.
 ;
 ;IHS/HQW/JLS 12/24/97  This routine called by %ZISH on UNIX Systems
 ;
 ;IHS/ANMC/LJF 12/11/96
 ; -- changed exit value for PWD call to make it work for VA calls
 ;
OPEN(ZISH1,ZISH2,ZISH3) ; -----  Open unix file.
 ;  S Y=$$OPEN^%ZISH("/directory/","filename","R")
 ;error    1=no device
 ;         2=open new file with 'R'
 ;         3=passed files by reference
 ;         4=invalid filename length
 ;
 ; ---------------------------------------------------------------
 ; PROGRAMMERS NOTE:  IHS/ADC/GTH - 06-03-96
 ; The VA's K8 version of %ZISH added another parameter to $$OPEN,
 ; the "handle name" of the file, but put the parameter at the
 ; beginning of the formal parameter list, instead of at the end,
 ; causing backwards incompatibility problems.
 ; This version is the IHS's version, with three parameters.
 ; ---------------------------------------------------------------
 ;
 NEW ZISHDF,ZISHIOP,%ZIS,POP,ZISHQ,IOUPAR
 ;
 ; -- Directory format.
 D DF(.ZISH1)
 ;
 ; -- Pass by value, or quit.
 I $O(ZISH2(0)) Q 3
 ;
 ; -- Check filename length.
 D FL(.ZISH2)
 I ZISH2=4 Q 4
 ;
 S ZISHDF=$S(ZISH1'="":ZISH1_ZISH2,1:ZISH2)
 ;
 ; -- Open MSM host.
 F ZISHIOP=51:1:54 I '$D(IO(1,ZISHIOP)) S IOP=ZISHIOP,%ZIS("IOPAR")="("""_ZISHDF_""":"""_ZISH3_""")" D ^%ZIS Q:'POP
 I POP Q 1
 ;
 ; -- Check new filename with "R" privileges.
 I ZISH3="R" U IO I $ZA=-1 S ZISHQ=2 D ^%ZISC
 ; Excepted from SAC 6.1.5, 6.1.2.2 and 6.1.2.3 memo dated 16Nov93.
 ;
 I '$D(ZISHQ),'$D(ZTQUEUED) U IO(0)
 Q $S($D(ZISHQ):ZISHQ,1:0)
 ;
DEL(ZISH1,ZISH2) ; -----  Delete file(s).
 ;  S Y=$$DEL^%ZISH("/directory/","filename")
 ;                               ,.array)
 NEW ZISHDA,ZISHF,ZISHX,ZISHQ,ZISHDF,ZISHC
 ;
 ; -- Directory format.
 D DF(.ZISH1)
 ;
 ; -- Set array if filename(s) passed by value.
 I '$O(ZISH2(0)) S ZISH2(1)=ZISH2
 ;
 ; -- Get filename(s) to act on.
 ; -- No '*' allowed.
 F ZISHDA=0:0 S ZISHDA=$O(ZISH2(ZISHDA)) Q:'ZISHDA  S ZISHF=ZISH2(ZISHDA) I ZISHF["*" S ZISHX=1,ZISHQ=1 Q
 I $D(ZISHQ) Q ZISHX
 F ZISHDA=0:0 S ZISHDA=$O(ZISH2(ZISHDA)) Q:'ZISHDA  S ZISHF=ZISH2(ZISHDA) D
 . I ZISH1'="" S ZISHDF=ZISH1_ZISHF
 . S ZISHC="rm "_$S(ZISH1'="":ZISHDF,1:ZISHF)
 . D JW
 .Q
 Q ZISHX
 ;
FROM(ZISH1,ZISH2,ZISH3,ZISH4,ZISH5) ; -----  Get unix file(s) from.
 ;  S Y=$$FROM^%ZISH("/dir/","fl","mach","qlfr","/dir/")
 ;                           "fl*"
 ;                           .array
 Q 20
 ;
SEND(ZISH1,ZISH2,ZISH3) ;Send unix fl
 ;  S Y=$$SEND^%ZISH("/dir/","fl","mach")
 ;                           "fl*"
 ;                           .array
 NEW ZISH,ZISHPARM
 S ZISH1=$G(ZISH1) ; If directory not passed, use system.
 I '$L($G(ZISH2)) Q "-1^<file not specified>"
 I '$L($G(ZISH3)) Q "-1^<destination not specified>"
 S Y=$$LIST(.ZISH1,ZISH2,.ZISH2) ; Put array of files in ZISH2()
 ;I OS=AIX S ZISHPARM="-nc"
 S ZISHPARM="-a";IHS/AAO/RPL -a for ascii mode with ftpsend
 ; -n = suppress sending results in UNIX mail message to the user
 ; -c = pack file(s) with 'compress' before sending
 ;I OS=SCO S ZISHPARM="-p"
 ; -p = pack the file before the send request
 F ZISH=1:1 Q:'$D(ZISH2(ZISH))  S ZISHC="cd /usr/spool/uucppublic; ftpsend "_ZISHPARM_" "_ZISH3_" "_ZISH2(ZISH) D JW;IHS/AAO/RPL 4/9/99 ftpsend after cd to public or nothing gets sent.
 Q ZISHX  ;IHS/AAO/RPL moved down from above line
 ;
LIST(ZISH1,ZISH2,ZISH3) ; -----  Set local array holding filename(s).
 ;  S Y=$$LIST^%ZISH("/dir/","fl",".return array")
 ;                           "fl*",
 ;                           .array,
 ;
 NEW ZISHC,ZISHDA,ZISHDF,ZISHX,ZISHLN,ZISHF,X,Y,POP,ZISHIOP1
 ;
 ; -- Directory format.
 D DF(.ZISH1)
 ;
 ; -- Init ZISHAUTO.$J.
 S ZISHC="rm /tmp/ZISHAUTO."_$J
 D JW
 ;
 ; -- Set array if filename(s) are passed by value.
 I '$O(ZISH2(0)) S ZISH2(1)=ZISH2
 ;
 ; -- Get filename(s) to act on.
 ; -- Append listing to ZISHAUTO.$J.
 F ZISHDA=0:0 S ZISHDA=$O(ZISH2(ZISHDA)) Q:'ZISHDA  S ZISHF=ZISH2(ZISHDA) D
 . S ZISHDF=$S(ZISH1'="":ZISH1_ZISHF,1:ZISHF)
 . S ZISHC="ls "_ZISHDF_" >> /tmp/ZISHAUTO."_$J
 . D JW
 .Q
 ;
 ; -- Open ZISHAUTO.$J to read.
 ; -- Create the 'Return Array' to pass back to user.
 S ZISHIOP1=ION_";"_IOST_";"_IOM_";"_IOSL
 S ZISHX=$$OPEN("/tmp/","ZISHAUTO."_$J,"R")
 I ZISHX Q ZISHX
 F ZISHLN=1:1 U IO R X Q:$$STATUS=-1  S ZISH3(ZISHLN)=$P(X,"/",$L(X,"/"))
 D ^%ZISC
 S IOP=ZISHIOP1
 D ^%ZIS
 ;
 ; -- Remove ZISHAUTO.$J.
 S ZISHC="rm /tmp/ZISHAUTO."_$J
 D JW
 ;
 Q ZISHX
 ;
MV(ZISH1,ZISH2,ZISH3,ZISH4) ; -----  Rename a file.
 ;  S Y=$$MV^%ZISH("/from_dir/","from_fl","/to_dir/","to_fl")
 ;
 NEW ZISHC,ZISHX
 ;
 ; -- Directory format.
 D DF(.ZISH1)
 D DF(.ZISH3)
 ;
 ; -- Check for pass by value, or quit.
 I $O(ZISH2(0))!($O(ZISH4(0))) Q 3
 ;
 ; -- Check for 'from' and 'to' directory.
 S ZISH2=$S(ZISH1="":ZISH2,1:ZISH1_ZISH2)
 S ZISH4=$S(ZISH3="":ZISH4,1:ZISH3_ZISH4)
 ;
 S ZISHC="mv "_ZISH2_" "_ZISH4
 D JW
 Q ZISHX
 ;
PWD(ZISH1) ; -----  Print working directory.
 ;  S Y=$$PWD^%ZISH(.return array)
 ;
 ; ---------------------------------------------------------------
 ; PROGRAMMERS NOTE:  IHS/ADC/GTH - 06-03-96
 ; The VA's K 8 version makes $$PWD a parameter-less extrinsic, which
 ; makes it backwards incompatible with IHS.  This is the IHS's
 ; version of $$PWD.
 ; ---------------------------------------------------------------
 ;
 S ZISH1(1)="/tmp"
 Q ZISH1(1)   ;IHS/ANMC/LJF 12/11/96
 ;Q 1         ;IHS/ANMC/LJF 12/11/96
 ;
JW ; -- MSM extrinsic.
 S ZISHX=$$JOBWAIT^%HOSTCMD(ZISHC)
 ; Excepted from SAC 6.1.5, 6.1.2.2 and 6.1.2.3 memo dated 16Nov93.
 Q
 ;
DF(X) ; ----- Directory format.
 Q:X=""
 S X=$TR(X,"\","/")
 I $E(X,$L(X))'="/" S X=X_"/"
 Q
 ;
STATUS() ; ----- EndOfFile flag.
 Q $ZC
 ; Excepted from SAC 6.1.5, 6.1.2.2 and 6.1.2.3 memo dated 16Nov93.
 ;
 ;
FL(X) ; ----- Filename length.
 NEW ZISHP1,ZISHP2
 S ZISHP1=$P(X,"."),ZISHP2=$P(X,".",2)
 I $L(ZISHP1)>14 S X=4 Q
 I $L(ZISHP2)>8 S X=4 Q
 Q
 ;
IHS() ;EP - Determine if the call was from an IHS application.
 I '$L($G(XQY0)) Q 1
 I "AB"[$E($G(XQY0)_" ") Q 1
 ; If required, add more checks, below.
 ; I "xxx"[$E($G(XQY0)_" ") Q
 Q 0
 ;

ZU
ZU ;SFISC/RWF - For MSM-NT and MSM-UNIX, TIE all User terminals to this routine!! ;12/21/98 10:07
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;8.0;KERNEL;**13,42,49,94,107**;Jul 10, 1995
 ;FOR MSM-NT and MSM-UNIX v4.3 or greater
EN N $ESTACK S $ECODE="",$ETRAP="D ERR^ZU Q:$QUIT 0 Q" ;,ZUGUI2=$$GUI()
 ;The next line keeps sign-on users from taking the last slot
 ;It can be commented out if not needed.
JOBCHK X ^%ZOSF("AVJ") I Y<3 W $C(7),!!,"** TROUBLE ** - ** CALL IRM NOW! **" G HALT
 D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGIN$")
 ;Bump up the partition size, Task partition size if file 14.7
 D GETENV^%ZOSV S Y=$P(Y,"^",4),%=$O(^%ZIS(14.7,"B",Y,0)),Y=$G(^%ZIS(14.7,+%,0)),%K=$P(Y,"^",5) I %K>0 D INT^%PARTSIZ
 G ^XUS ;G ^XUSG:$G(ZUGUI1),^XUS
 ;
G ;Entry point for GUI device.
 S ZUGUI1=1 G EN
 ;
ERR ;Come here on error.
 S $ETRAP="D UNWIND^ZU" L  B 0 ;Unlock, Turn off break
 Q:$ECODE["<PROG>"
 I $G(IO)]"",$D(IO(1,IO)),$E($G(IOST))="P" U IO W @$S($D(IOF):IOF,1:"#")
 I $G(IO(0))]"" U IO(0) W !!,"RECORDING THAT AN ERROR OCCURRED ---",!!?15,"Sorry 'bout that",!,*7,!?10,"$STACK=",$STACK,", $ECODE=",$ECODE,!?10,"$ZERROR=",$ZERROR
 D ^%ZTER
 I $EC'["<INRPT>" S XUERF="",$EC="" G ^XUSCLEAN
CTRLC I $D(IO)=11 U IO(0) C:IO'=IO(0) IO S IO=IO(0)
 W !,"--Interrupt Acknowledged",!
 D KILL1^XUSCLEAN ;Clean up symbol table
 S $ECODE=",U<<POP>>,"
 Q
 ;
UNWIND ;Unwind the stack
 Q:$ESTACK>1  G CONT:$ECODE["<<HALT>>",CTRLC2:$ECODE["<<POP>>"
 S $ECODE=""
 Q
 ;
CTRLC2 S $ECODE="" G:$G(^XUTL("XQ",$J,"T"))<2 ^XUSCLEAN
 S ^XUTL("XQ",$J,"T")=1,XQY=$G(^(1)),XQY0=$P(XQY,"^",2,99)
 G:$P(XQY0,"^",4)'="M" CTRLC2
 S XQPSM=$P(XQY,"^",1),XQY=+XQPSM,XQPSM=$P(XQPSM,XQY,2,3)
 G:'XQY ^XUSCLEAN
 S $ECODE="",$ETRAP="S %ZTER11S=$STACK D ERR^ZU Q:$QUIT 0 Q" G M1^XQ
 ;
HALT I $D(^XUTL("XQ",$J)) D:$D(DUZ)#2 BYE^XUSCLEAN
 D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$")
 I '$ESTACK G CONT
 S $ETRAP="D UNWIND^ZU" ;Set new trap
 S $ECODE=",U<<HALT>>," ;Cause error to unwind stack
 Q
CONT ;
 S $ECODE="",$ETRAP=""
 HALT
 ;
GUI() ;Test if under GUI
 Q "" ;Just say No.
 S $ZT="GUIX",X="" G:$PD'=1 GUIX
 S X=$G(^$DI($PD,"PLATFORM"))
GUIX Q X

ZUMSM
ZU ;SFISC/RWF - For MSM-NT and MSM-UNIX, TIE all User terminals to this routine!! ;12/21/98 10:07
 ;;8.0;KERNEL;**1006**;MAY 29, 1999
 ;;8.0;KERNEL;**13,42,49,94,107**;Jul 10, 1995
 ;FOR MSM-NT and MSM-UNIX v4.3 or greater
EN N $ESTACK S $ECODE="",$ETRAP="D ERR^ZU Q:$QUIT 0 Q" ;,ZUGUI2=$$GUI()
 ;The next line keeps sign-on users from taking the last slot
 ;It can be commented out if not needed.
JOBCHK X ^%ZOSF("AVJ") I Y<3 W $C(7),!!,"** TROUBLE ** - ** CALL IRM NOW! **" G HALT
 D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGIN$")
 ;Bump up the partition size, Task partition size if file 14.7
 D GETENV^%ZOSV S Y=$P(Y,"^",4),%=$O(^%ZIS(14.7,"B",Y,0)),Y=$G(^%ZIS(14.7,+%,0)),%K=$P(Y,"^",5) I %K>0 D INT^%PARTSIZ
 G ^XUS ;G ^XUSG:$G(ZUGUI1),^XUS
 ;
G ;Entry point for GUI device.
 S ZUGUI1=1 G EN
 ;
ERR ;Come here on error.
 S $ETRAP="D UNWIND^ZU" L  B 0 ;Unlock, Turn off break
 Q:$ECODE["<PROG>"
 I $G(IO)]"",$D(IO(1,IO)),$E($G(IOST))="P" U IO W @$S($D(IOF):IOF,1:"#")
 I $G(IO(0))]"" U IO(0) W !!,"RECORDING THAT AN ERROR OCCURRED ---",!!?15,"Sorry 'bout that",!,*7,!?10,"$STACK=",$STACK,", $ECODE=",$ECODE,!?10,"$ZERROR=",$ZERROR
 D ^%ZTER
 I $EC'["<INRPT>" S XUERF="",$EC="" G ^XUSCLEAN
CTRLC I $D(IO)=11 U IO(0) C:IO'=IO(0) IO S IO=IO(0)
 W !,"--Interrupt Acknowledged",!
 D KILL1^XUSCLEAN ;Clean up symbol table
 S $ECODE=",U<<POP>>,"
 Q
 ;
UNWIND ;Unwind the stack
 Q:$ESTACK>1  G CONT:$ECODE["<<HALT>>",CTRLC2:$ECODE["<<POP>>"
 S $ECODE=""
 Q
 ;
CTRLC2 S $ECODE="" G:$G(^XUTL("XQ",$J,"T"))<2 ^XUSCLEAN
 S ^XUTL("XQ",$J,"T")=1,XQY=$G(^(1)),XQY0=$P(XQY,"^",2,99)
 G:$P(XQY0,"^",4)'="M" CTRLC2
 S XQPSM=$P(XQY,"^",1),XQY=+XQPSM,XQPSM=$P(XQPSM,XQY,2,3)
 G:'XQY ^XUSCLEAN
 S $ECODE="",$ETRAP="S %ZTER11S=$STACK D ERR^ZU Q:$QUIT 0 Q" G M1^XQ
 ;
HALT I $D(^XUTL("XQ",$J)) D:$D(DUZ)#2 BYE^XUSCLEAN
 D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$")
 I '$ESTACK G CONT
 S $ETRAP="D UNWIND^ZU" ;Set new trap
 S $ECODE=",U<<HALT>>," ;Cause error to unwind stack
 Q
CONT ;
 S $ECODE="",$ETRAP=""
 HALT
 ;
GUI() ;Test if under GUI
 Q "" ;Just say No.
 S $ZT="GUIX",X="" G:$PD'=1 GUIX
 S X=$G(^$DI($PD,"PLATFORM"))
GUIX Q X