%ZTF ; JSH,GFT,ESS,Hrubovcak ; 14 Jan 98 07:52; Function Library for MSM/Windows NT
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;CHCS TLS_4603; GEN 1; 21-MAY-1999
;COPYRIGHT 1998 SAIC
;This version is for MICRONETICS MUMPS.
N %,N,R,L,T
W !,"Available functions in library ^"_$T(+0)
S N=0 F %=2:1 S R=$T(+%) Q:R="" D
.S L=$P(R," "),T=$E(R,$F(R," "),999)
.I L]"",$E(T)=";" W !!,$P(L,"("),?10,"(",$P(L,"(",2,99) S N=1
.I N,$E(T)=";" W !,?5,T Q
Q
ABS(X) ;Returns the absolute value of X.
Q $S(X<0:-X,1:X)
;
ACTIVE(XJB,XNOD) ;Return true if job number active, false if inactive (logged off)
; Input: XJB = $J for the process to check
; XNOD = Node name of the job to check
;
N XACT,XALLNODS,XCNT,XCURNOD,XRES,XUCI,XVOL
; If no node name is passed check only the current node
S XNOD=$G(XNOD) Q:'$L(XNOD) $$ACTIVE^%ACTJOB(XJB)
S XCURNOD=$$NODENAME^%ZTF ; get the name of the current node
; If XNOD is the same as the current node, do not need to job remotely
Q:XCURNOD=XNOD $$ACTIVE^%ACTJOB(XJB)
K ^%ZTSCH("ACTIVE",XJB,0) ; this node is being used to pass the result
; grab all node names, and production UCI,VOL
S XALLNODS=$$NODES^%ZTOS,XUCI=$G(^%ZOSF("PROD")),XVOL=$P(XUCI,",",2)
S XUCI=$P(XUCI,",")
; If the node to job to is not a valid node quit false
Q:'$F(XALLNODS,XNOD)!('$L(XUCI))!('$L(XVOL)) ""
; job the check to prevent the DDP hang if remote node is not up
J ACTIVJ^%ZTF(XJB,XUCI,XVOL,XNOD)
; now wait for the remote job to finish and pass the result back
S XCNT=0 F D Q:XRES!(XCNT>10)
.L +^%ZTSCH("ACTIVE",XJB,0)
.S XRES=$D(^%ZTSCH("ACTIVE",XJB,0))
.L -^%ZTSCH("ACTIVE",XJB,0)
.S XCNT=XCNT+1 H 1
; get the result, cleanup and return the result
S XACT=$G(^%ZTSCH("ACTIVE",XJB,0)) K ^%ZTSCH("ACTIVE",XJB,0)
Q XACT
;
ACTIVJ(XJB,XUCI,XVOL,XNOD) ; Start ACTIV^%ZTF on a remote node
;
; Input: XJB = $J for the process to check
; XUCI = UCI name of the Production UCI
; XVOL = Volume name of the Production UCI
; XNOD = Node name of the job to check
;
; job the check on the remote node XNOD
N X
S X="ACTERR^%ZTF",@^%ZOSF("TRAP")
X "J ACTIV^%ZTF(XJB)|XUCI,XVOL,XNOD|::10" ;***
Q
ACTIV(XJB) ;Return true if job number active, false if inactive (logged off)
; pass the result to the remote process in the ^%ZTSCH("ACTIVE" global
; Input: XJB = $J for the process to check
;
S ^%ZTSCH("ACTIVE",XJB,0)=$$ACTIVE^%ACTJOB(XJB)
Q
ACTERR ; Trap error if not able to job on remote node
; assume job being not active
S ^%ZTSCH("ACTIVE",XJB,0)=0
D ET^%ZTF
Q
;
BREAK(X) ;Enable/Disable Control-C. 1 = Enable, 0 = Disable ;***
X "B $S(X:1,1:0)" Q X
CRC(X,Y) ;
N % X "S %=$ZCRC(X,6,+$G(Y))" Q % ;****** MSM VERSION 4.1
DIR(X) ; return proper directory
; input: 0 = common user directory (default)
; 1 = application exe directory
S X=+$G(X),X=$S('X:$G(^%ZOSF("DIR_USER")),X=1:$G(^%ZOSF("DIR_APPL")),1:"")
Q (X_$S($L(X)&($E(X,$L(X))'="\"):"\",1:""))
DIRCHK(X) ; validate directory - return 1 if it exists, else 0
Q '$$TERMINAL^%HOSTCMD("cd "_X_">nul")
DIRE ; external call to DIR function in DVX, this tag is a placeholder
Q
DNCASE(X) ;
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
DUP(X,N) ;
N % S $P(%,X,N+$L(X)-1/$L(X))=X Q $E(%,1,N)
EDIT(S,N) ;Edit a string based on the value of N
N % I N\256#2 D Q S
.F %=1:2:$L(S,"""") D I %+1=$L(S,"""") S %=%+1 D
..S $P(S,"""",%)=$$EDIT($P(S,"""",%),N-256)
I N\2#2 S S=$TR(S,$C(9,32))
I N\4#2 S S=$TR(S,$C(0,10,12,13,127))
I N\8#2 F Q:$C(9,32)'[$E(S) Q:S="" S S=$E(S,2,999)
I N\16#2 S S=$TR(S,$C(9)," ") F %=0:0 S %=$F(S," ",%) Q:'% I $E(S,%)=" " S S=$E(S,1,%-1)_$E(S,%+1,999),%=%-1
I N\32#2 S S=$$UPCASE(S)
I N\64#2 S S=$TR(S,"[]","()")
I N\128#2 F %=$L(S):-1:1 Q:$C(9,32)'[$E(S,%) S S=$E(S,1,%-1)
I N#2 F %=1:1:$L(S) S S=$E(S,1,%-1)_$C($A(S,%)#128)_$E(S,%+1,999)
Q S
EOFF(X) ;Turn off echo on device X
X "S:$G(X)="""" X=$I U X:(::::1)" Q "" ;***
EON(X) ;Turn on echo on device X
X "S:$G(X)="""" X=$I U X:(:::::1)" Q "" ;***
ESCAPE(X) ;Enable or disable escape sequence processing
S X=+$G(X) X "U:X $I:(::::8388608) U:'X $I:(:::::8388608)" Q "" ;***
ET ; log error in error trap
G INT^%ZET
ETYPE(X) ;check for certain error conditions
; input: X = "C" checks for ^C error
; = "A" checks for memory allocation error
; output: TRUE if specified error accured, FALSE otherwise
N % S X=$G(X),%=0
I X="C",$ZE["INRPT" S %=1
I X="A",$ZE["PGMOV" S %=1
Q %
FDEL(NAME) ;delete spool file from current directory
N X
S:$L(NAME) X=$$JOBWAIT^%HOSTCMD("delete "_NAME) ; Delete file
Q
FOLLOWS(X,Y) ;Returns truth value 'X follows Y', whether string or numeric
Q $S(+X=X&(+Y=Y):X>Y,1:X]Y)
MAX(X,Y) ;Returns the maximum of X and Y, or of all values in array .X
I $D(Y) Q $S(X>Y:X,1:Y)
N %,%0 S %="X",%0=$G(X) F S %=$Q(@%) Q:%="" I @%>%0 S %0=@%
Q %0
MIN(X,Y) ;Returns the minimum of X and Y, or of all values in array .X
I $D(Y) Q $S(X<Y:X,1:Y)
N %,%0 S %="X",%0=$G(X) F S %=$Q(@%) Q:%="" I @%<%0 S %0=@%
Q %0
NODENAME(E) ;Returns the current node name
Q $$DDPNODES^%MSMOPS(0) ;***
OS() ;Return the current M Version
Q $ZV
;
POWER(B,E) ;Returns B raised to E
Q B**E ;MDC type A extention
;
PRG() ;Return 1 if in program mode, 0 if not.
Q $$PRG^%SAICOPS()
;
PRIINQ(J) ;Return base priority of job X
Q $$PRIINQ^%SAICOPS(J) ;Q $V(20,$J,2)
;
READ(FLAG,LEN,PROMPT,DEFAULT,TERM,FUNC,X,Y) ; general reader utility
G READ^%ZTF1
RMARGIN(X,I) ;Set the right margin of device I to X, return current setting.
S X=+$G(X),I=$G(I,$I)
Q $$RMARGIN^%SAICOPS(X,I)
ROUSIZE(X) ;Returns the size of a routine X's executable code
Q $$ROUSIZE^%SAICOPS(X)
ROUTEST(X) ;Returns true if routine X exists in current UCI
Q:'$L($G(X)) 0 Q ''$D(^$R(X))
SETPRI(X,J) ;Set job J (defaults to our job) to priority X ;***
Q:'$G(X) "" D:X>4 HIGH^%HL D:X<5 LOW^%HL
Q ""
SETPRIN(JOB) ;Resets the $Principal to the bit-bucket
D SETPRIN^%SAICOPS(JOB,46)
Q
SETXY(X,Y,C) ;Set $X=X, $Y=Y. Unless C is present and true, move cursor.
I '$G(C) I (X<0)!(X>80)!(Y<0)!(Y>24) Q "" ;sir 7661
W:'$G(C) /CUP(Y+1,X+1) S $X=X,$Y=Y Q ""
SQRT(X) ;Return the square-root of X. Returns zero for an illegal X.
N %X,%RES S %X=X D ^%SQRT
Q %RES
TYPAHEAD(X) ;Enable or disable type-ahead on the current device. ;***
;X=1 Enable, X=0 Disable
X "U:X=1 $I:(::::67108864:33554432) U:X=0 $I:(::::33554432:67108864)"
Q ""
UCI(X) ;Returns UCI, Volume if X is true
Q $P($ZU(0),",",1,1+$G(X)) ;***
UCICHECK(W) ;Returns true if the specified UCI [,volume set] is valid ;***
S $ZT="UCICHK1" N V
S:W?1.2N!(W?1.2N1","1.2N) W=$ZU(+W,$S(W[",":$P(W,",",2),1:$P($ZU(0),",",2)))
I W'?3U,W'?3U1","3U Q 0
S V=$S(W[",":$P(W,",",2),1:$P($ZU(0),",",2)),V=$ZU($P(W,","),V)
Q ''V
UCICHK1 Q 0
;
UPCASE(X) ;Convert all lowercase letters in X to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
XORB(X) ;Return the exclusive-or of all the bytes in X. (Returned as a number, not a single byte.)
N % X "S %=$ZCRC(X,0)" Q %
YN(YN,S) ;Return True for yes, false for no. YN=1 for yes default, 0=no
;If '^' is entered, it will be returned as the result.
;If the read times-out DTOUT will be set to 1.
;S is a flag used by the window processor
N %,%X S S=$G(S) I S N BS S $P(BS,$C(8),80)=$C(8)
YN1 W "? "_$S(YN:"Yes",1:"No")_"// " S %X=$X
R %#5:$S($D(DTIME):DTIME,1:300) S:%="" %=$E("YN",'YN+1) E S DTOUT=1 Q 0
S %=$E(%),%=$S("Yy"[%:1,"Nn"[%:0,%="^":%,1:"?")
I %="?" D G YN1
.W:'S ! W " Answer 'Y', 'N', or '^' to quit" Q:'S
.W $E(BS,1,$X-%X+7+YN)
W:%?1N $E($C(8,8,8,8,8),1,$X-%X)_$P("No ^Yes ","^",%+1)
Q %
ZE(C) ;Return the last error code
; If C is TRUE, add on explanation
N EC S EC="" I $G(C) S EC=$TR($P($ZE,":",4,5),":") S:EC EC=$P($T(@EC^%ERRCODE),";",2)
Q $ZE_EC
ZH() ; return DSM $ZH or OS equivilent
N H S H=$H,H=$E(H,3,5)*86400+$P(H,",",2)
Q $TR($$ZH^%SAICOPS,"^",",")_","_H
ERR Q $ZE ;ERROR RETURN
ERRNL Q "" ;RETURN NULL STRING ON ERROR
ERR0 Q 0 ;RETURN 0 ON ERROR
Q
%ZTF ; JSH,GFT,ESS,Hrubovcak ; 14 Jan 98 07:52; Function Library for MSM/Windows NT
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;CHCS TLS_4603; GEN 1; 21-MAY-1999
+3 ;COPYRIGHT 1998 SAIC
+4 ;This version is for MICRONETICS MUMPS.
+5 NEW %,N,R,L,T
+6 WRITE !,"Available functions in library ^"_$TEXT(+0)
+7 SET N=0
FOR %=2:1
SET R=$TEXT(+%)
IF R=""
QUIT
Begin DoDot:1
+8 SET L=$PIECE(R," ")
SET T=$EXTRACT(R,$FIND(R," "),999)
+9 IF L]""
IF $EXTRACT(T)=";"
WRITE !!,$PIECE(L,"("),?10,"(",$PIECE(L,"(",2,99)
SET N=1
+10 IF N
IF $EXTRACT(T)=";"
WRITE !,?5,T
QUIT
End DoDot:1
+11 QUIT
ABS(X) ;Returns the absolute value of X.
+1 QUIT $SELECT(X<0:-X,1:X)
+2 ;
ACTIVE(XJB,XNOD) ;Return true if job number active, false if inactive (logged off)
+1 ; Input: XJB = $J for the process to check
+2 ; XNOD = Node name of the job to check
+3 ;
+4 NEW XACT,XALLNODS,XCNT,XCURNOD,XRES,XUCI,XVOL
+5 ; If no node name is passed check only the current node
+6 SET XNOD=$GET(XNOD)
IF '$LENGTH(XNOD)
QUIT $$ACTIVE^%ACTJOB(XJB)
+7 ; get the name of the current node
SET XCURNOD=$$NODENAME^%ZTF
+8 ; If XNOD is the same as the current node, do not need to job remotely
+9 IF XCURNOD=XNOD
QUIT $$ACTIVE^%ACTJOB(XJB)
+10 ; this node is being used to pass the result
KILL ^%ZTSCH("ACTIVE",XJB,0)
+11 ; grab all node names, and production UCI,VOL
+12 SET XALLNODS=$$NODES^%ZTOS
SET XUCI=$GET(^%ZOSF("PROD"))
SET XVOL=$PIECE(XUCI,",",2)
+13 SET XUCI=$PIECE(XUCI,",")
+14 ; If the node to job to is not a valid node quit false
+15 IF '$FIND(XALLNODS,XNOD)!('$LENGTH(XUCI))!('$LENGTH(XVOL))
QUIT ""
+16 ; job the check to prevent the DDP hang if remote node is not up
+17 JOB ACTIVJ^%ZTF(XJB,XUCI,XVOL,XNOD)
+18 ; now wait for the remote job to finish and pass the result back
+19 SET XCNT=0
FOR
Begin DoDot:1
+20 LOCK +^%ZTSCH("ACTIVE",XJB,0)
+21 SET XRES=$DATA(^%ZTSCH("ACTIVE",XJB,0))
+22 LOCK -^%ZTSCH("ACTIVE",XJB,0)
+23 SET XCNT=XCNT+1
HANG 1
End DoDot:1
IF XRES!(XCNT>10)
QUIT
+24 ; get the result, cleanup and return the result
+25 SET XACT=$GET(^%ZTSCH("ACTIVE",XJB,0))
KILL ^%ZTSCH("ACTIVE",XJB,0)
+26 QUIT XACT
+27 ;
ACTIVJ(XJB,XUCI,XVOL,XNOD) ; Start ACTIV^%ZTF on a remote node
+1 ;
+2 ; Input: XJB = $J for the process to check
+3 ; XUCI = UCI name of the Production UCI
+4 ; XVOL = Volume name of the Production UCI
+5 ; XNOD = Node name of the job to check
+6 ;
+7 ; job the check on the remote node XNOD
+8 NEW X
+9 SET X="ACTERR^%ZTF"
SET @^%ZOSF("TRAP")
+10 ;***
XECUTE "J ACTIV^%ZTF(XJB)|XUCI,XVOL,XNOD|::10"
+11 QUIT
ACTIV(XJB) ;Return true if job number active, false if inactive (logged off)
+1 ; pass the result to the remote process in the ^%ZTSCH("ACTIVE" global
+2 ; Input: XJB = $J for the process to check
+3 ;
+4 SET ^%ZTSCH("ACTIVE",XJB,0)=$$ACTIVE^%ACTJOB(XJB)
+5 QUIT
ACTERR ; Trap error if not able to job on remote node
+1 ; assume job being not active
+2 SET ^%ZTSCH("ACTIVE",XJB,0)=0
+3 DO ET^%ZTF
+4 QUIT
+5 ;
BREAK(X) ;Enable/Disable Control-C. 1 = Enable, 0 = Disable ;***
+1 XECUTE "B $S(X:1,1:0)"
QUIT X
CRC(X,Y) ;
+1 ;****** MSM VERSION 4.1
NEW %
XECUTE "S %=$ZCRC(X,6,+$G(Y))"
QUIT %
DIR(X) ; return proper directory
+1 ; input: 0 = common user directory (default)
+2 ; 1 = application exe directory
+3 SET X=+$GET(X)
SET X=$SELECT('X:$GET(^%ZOSF("DIR_USER")),X=1:$GET(^%ZOSF("DIR_APPL")),1:"")
+4 QUIT (X_$SELECT($LENGTH(X)&($EXTRACT(X,$LENGTH(X))'="\"):"\",1:""))
DIRCHK(X) ; validate directory - return 1 if it exists, else 0
+1 QUIT '$$TERMINAL^%HOSTCMD("cd "_X_">nul")
DIRE ; external call to DIR function in DVX, this tag is a placeholder
+1 QUIT
DNCASE(X) ;
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
DUP(X,N) ;
+1 NEW %
SET $PIECE(%,X,N+$LENGTH(X)-1/$LENGTH(X))=X
QUIT $EXTRACT(%,1,N)
EDIT(S,N) ;Edit a string based on the value of N
+1 NEW %
IF N\256#2
Begin DoDot:1
+2 FOR %=1:2:$LENGTH(S,"""")
Begin DoDot:2
+3 SET $PIECE(S,"""",%)=$$EDIT($PIECE(S,"""",%),N-256)
End DoDot:2
IF %+1=$LENGTH(S,"""")
SET %=%+1
Begin DoDot:2
End DoDot:2
End DoDot:1
QUIT S
+4 IF N\2#2
SET S=$TRANSLATE(S,$CHAR(9,32))
+5 IF N\4#2
SET S=$TRANSLATE(S,$CHAR(0,10,12,13,127))
+6 IF N\8#2
FOR
IF $CHAR(9,32)'[$EXTRACT(S)
QUIT
IF S=""
QUIT
SET S=$EXTRACT(S,2,999)
+7 IF N\16#2
SET S=$TRANSLATE(S,$CHAR(9)," ")
FOR %=0:0
SET %=$FIND(S," ",%)
IF '%
QUIT
IF $EXTRACT(S,%)=" "
SET S=$EXTRACT(S,1,%-1)_$EXTRACT(S,%+1,999)
SET %=%-1
+8 IF N\32#2
SET S=$$UPCASE(S)
+9 IF N\64#2
SET S=$TRANSLATE(S,"[]","()")
+10 IF N\128#2
FOR %=$LENGTH(S):-1:1
IF $CHAR(9,32)'[$EXTRACT(S,%)
QUIT
SET S=$EXTRACT(S,1,%-1)
+11 IF N#2
FOR %=1:1:$LENGTH(S)
SET S=$EXTRACT(S,1,%-1)_$CHAR($ASCII(S,%)#128)_$EXTRACT(S,%+1,999)
+12 QUIT S
EOFF(X) ;Turn off echo on device X
+1 ;***
XECUTE "S:$G(X)="""" X=$I U X:(::::1)"
QUIT ""
EON(X) ;Turn on echo on device X
+1 ;***
XECUTE "S:$G(X)="""" X=$I U X:(:::::1)"
QUIT ""
ESCAPE(X) ;Enable or disable escape sequence processing
+1 ;***
SET X=+$GET(X)
XECUTE "U:X $I:(::::8388608) U:'X $I:(:::::8388608)"
QUIT ""
ET ; log error in error trap
+1 GOTO INT^%ZET
ETYPE(X) ;check for certain error conditions
+1 ; input: X = "C" checks for ^C error
+2 ; = "A" checks for memory allocation error
+3 ; output: TRUE if specified error accured, FALSE otherwise
+4 NEW %
SET X=$GET(X)
SET %=0
+5 IF X="C"
IF $ZE["INRPT"
SET %=1
+6 IF X="A"
IF $ZE["PGMOV"
SET %=1
+7 QUIT %
FDEL(NAME) ;delete spool file from current directory
+1 NEW X
+2 ; Delete file
IF $LENGTH(NAME)
SET X=$$JOBWAIT^%HOSTCMD("delete "_NAME)
+3 QUIT
FOLLOWS(X,Y) ;Returns truth value 'X follows Y', whether string or numeric
+1 QUIT $SELECT(+X=X&(+Y=Y):X>Y,1:X]Y)
MAX(X,Y) ;Returns the maximum of X and Y, or of all values in array .X
+1 IF $DATA(Y)
QUIT $SELECT(X>Y:X,1:Y)
+2 NEW %,%0
SET %="X"
SET %0=$GET(X)
FOR
SET %=$QUERY(@%)
IF %=""
QUIT
IF @%>%0
SET %0=@%
+3 QUIT %0
MIN(X,Y) ;Returns the minimum of X and Y, or of all values in array .X
+1 IF $DATA(Y)
QUIT $SELECT(X<Y:X,1:Y)
+2 NEW %,%0
SET %="X"
SET %0=$GET(X)
FOR
SET %=$QUERY(@%)
IF %=""
QUIT
IF @%<%0
SET %0=@%
+3 QUIT %0
NODENAME(E) ;Returns the current node name
+1 ;***
QUIT $$DDPNODES^%MSMOPS(0)
OS() ;Return the current M Version
+1 QUIT $ZV
+2 ;
POWER(B,E) ;Returns B raised to E
+1 ;MDC type A extention
QUIT B**E
+2 ;
PRG() ;Return 1 if in program mode, 0 if not.
+1 QUIT $$PRG^%SAICOPS()
+2 ;
PRIINQ(J) ;Return base priority of job X
+1 ;Q $V(20,$J,2)
QUIT $$PRIINQ^%SAICOPS(J)
+2 ;
READ(FLAG,LEN,PROMPT,DEFAULT,TERM,FUNC,X,Y) ; general reader utility
+1 GOTO READ^%ZTF1
RMARGIN(X,I) ;Set the right margin of device I to X, return current setting.
+1 SET X=+$GET(X)
SET I=$GET(I,$IO)
+2 QUIT $$RMARGIN^%SAICOPS(X,I)
ROUSIZE(X) ;Returns the size of a routine X's executable code
+1 QUIT $$ROUSIZE^%SAICOPS(X)
ROUTEST(X) ;Returns true if routine X exists in current UCI
+1 IF '$LENGTH($GET(X))
QUIT 0
QUIT ''$DATA(^$RANDOM(X))
SETPRI(X,J) ;Set job J (defaults to our job) to priority X ;***
+1 IF '$GET(X)
QUIT ""
IF X>4
DO HIGH^%HL
IF X<5
DO LOW^%HL
+2 QUIT ""
SETPRIN(JOB) ;Resets the $Principal to the bit-bucket
+1 DO SETPRIN^%SAICOPS(JOB,46)
+2 QUIT
SETXY(X,Y,C) ;Set $X=X, $Y=Y. Unless C is present and true, move cursor.
+1 ;sir 7661
IF '$GET(C)
IF (X<0)!(X>80)!(Y<0)!(Y>24)
QUIT ""
+2 IF '$GET(C)
WRITE /CUP(Y+1,X+1)
SET $X=X
SET $Y=Y
QUIT ""
SQRT(X) ;Return the square-root of X. Returns zero for an illegal X.
+1 NEW %X,%RES
SET %X=X
DO ^%SQRT
+2 QUIT %RES
TYPAHEAD(X) ;Enable or disable type-ahead on the current device. ;***
+1 ;X=1 Enable, X=0 Disable
+2 XECUTE "U:X=1 $I:(::::67108864:33554432) U:X=0 $I:(::::33554432:67108864)"
+3 QUIT ""
UCI(X) ;Returns UCI, Volume if X is true
+1 ;***
QUIT $PIECE($ZU(0),",",1,1+$GET(X))
UCICHECK(W) ;Returns true if the specified UCI [,volume set] is valid ;***
+1 SET $ZT="UCICHK1"
NEW V
+2 IF W?1.2N!(W?1.2N1","1.2N)
SET W=$ZU(+W,$SELECT(W[",":$PIECE(W,",",2),1:$PIECE($ZU(0),",",2)))
+3 IF W'?3U
IF W'?3U1","3U
QUIT 0
+4 SET V=$SELECT(W[",":$PIECE(W,",",2),1:$PIECE($ZU(0),",",2))
SET V=$ZU($PIECE(W,","),V)
+5 QUIT ''V
UCICHK1 QUIT 0
+1 ;
UPCASE(X) ;Convert all lowercase letters in X to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
XORB(X) ;Return the exclusive-or of all the bytes in X. (Returned as a number, not a single byte.)
+1 NEW %
XECUTE "S %=$ZCRC(X,0)"
QUIT %
YN(YN,S) ;Return True for yes, false for no. YN=1 for yes default, 0=no
+1 ;If '^' is entered, it will be returned as the result.
+2 ;If the read times-out DTOUT will be set to 1.
+3 ;S is a flag used by the window processor
+4 NEW %,%X
SET S=$GET(S)
IF S
NEW BS
SET $PIECE(BS,$CHAR(8),80)=$CHAR(8)
YN1 WRITE "? "_$SELECT(YN:"Yes",1:"No")_"// "
SET %X=$X
+1 READ %#5:$SELECT($DATA(DTIME):DTIME,1:300)
IF %=""
SET %=$EXTRACT("YN",'YN+1)
IF '$TEST
SET DTOUT=1
QUIT 0
+2 SET %=$EXTRACT(%)
SET %=$SELECT("Yy"[%:1,"Nn"[%:0,%="^":%,1:"?")
+3 IF %="?"
Begin DoDot:1
+4 IF 'S
WRITE !
WRITE " Answer 'Y', 'N', or '^' to quit"
IF 'S
QUIT
+5 WRITE $EXTRACT(BS,1,$X-%X+7+YN)
End DoDot:1
GOTO YN1
+6 IF %?1N
WRITE $EXTRACT($CHAR(8,8,8,8,8),1,$X-%X)_$PIECE("No ^Yes ","^",%+1)
+7 QUIT %
ZE(C) ;Return the last error code
+1 ; If C is TRUE, add on explanation
+2 NEW EC
SET EC=""
IF $GET(C)
SET EC=$TRANSLATE($PIECE($ZE,":",4,5),":")
IF EC
SET EC=$PIECE($TEXT(@EC^%ERRCODE),";",2)
+3 QUIT $ZE_EC
ZH() ; return DSM $ZH or OS equivilent
+1 NEW H
SET H=$HOROLOG
SET H=$EXTRACT(H,3,5)*86400+$PIECE(H,",",2)
+2 QUIT $TRANSLATE($$ZH^%SAICOPS,"^",",")_","_H
ERR ;ERROR RETURN
QUIT $ZE
ERRNL ;RETURN NULL STRING ON ERROR
QUIT ""
ERR0 ;RETURN 0 ON ERROR
QUIT 0
+1 QUIT
