XUS3A ;SF-ISC/STAFF - CHANGE UCI'S ; 2/4/03 9:51am [ 07/29/2004 9:01 AM ]
;;8.0;KERNEL;**13,282**;Jul 10, 1995
Q
;PICK A UCI TO SWITCH TO
SWITCH ;Allow users that have the UCI field in there NP file to switch UCI's.
W !!,"Switch UCI's option.",!
I $$PROGMODE^%ZOSV() W !,$C(7),"No switching UCI's in Programmer Mode." Q
I $O(^VA(200,DUZ,.2,0))'>0 D Q
. W !,"Sorry but you do not have any UCI's that you are allowed to"
. W !,"switch to."
. Q
N DIR,X,Y,PGM,%UCI,DEF
S DEF="ZU" ;DEF is default routine to switch to.
UCI S DIR(0)="F",DIR("A")="Select UCI:ROUTINE",DIR("??")="^D SHOW^XUS3A"
S DIR("?")="Enter a UCI name (:Routine) to switch to."
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(X="^") Q
I Y?.N,$D(^VA(200,DUZ,.2,Y,0)) S UC=^(0),Y=$P(UC,U)_":"_$P($P(UC,U,2),":")
S X=$P(Y,":"),PGM=$P(Y,":",2,3) S:PGM[":" X=$P(Y,":",1,2),PGM=$P(Y,":",3) ;for M/vx
S:PGM="" PGM=DEF
SAME I X="" Q ;Didn't select anything.
D PM S %UCI=X X ^%ZOSF("UCICHECK") I 0[Y G BAD
F DA=0:0 S DA=$O(^VA(200,DUZ,.2,DA)) Q:DA'>0 S Y=^(DA,0) D G:GO NXT
. S GO=0,X=$P(Y,U),XUA=$P(Y,U,2) D PM Q:%UCI'=X
. I XUA="" S XUA=DEF
. F %=1:1:20 I $P(XUA,":",%)=PGM S GO=1 Q
. Q
BAD W !,"UCI not found!" D SHOW G UCI
;
NXT ;Here we go.
D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J)
;K DA S XQZ="^"_PGM_"["_%UCI_"]" D DO^%XUCI G ^XUSCLEAN
K DA G GO^%XUCI
;
;
SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0)
W !,"Enter ^ to return to your current menu, or select from:"
F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0 D
. W !,?5 S UC=$G(^VA(200,DUZ,.2,I,0)),X=$P(UC,U,1),UC=$P(UC,U,2,99)
. I UC'[":" W I
. D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valid UCI!",$C(7) Q
. W:UC]"" ":"_UC
. Q
Q
;
PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
Q
XUS3A ;SF-ISC/STAFF - CHANGE UCI'S ; 2/4/03 9:51am [ 07/29/2004 9:01 AM ]
+1 ;;8.0;KERNEL;**13,282**;Jul 10, 1995
+2 QUIT
+3 ;PICK A UCI TO SWITCH TO
SWITCH ;Allow users that have the UCI field in there NP file to switch UCI's.
+1 WRITE !!,"Switch UCI's option.",!
+2 IF $$PROGMODE^%ZOSV()
WRITE !,$CHAR(7),"No switching UCI's in Programmer Mode."
QUIT
+3 IF $ORDER(^VA(200,DUZ,.2,0))'>0
Begin DoDot:1
+4 WRITE !,"Sorry but you do not have any UCI's that you are allowed to"
+5 WRITE !,"switch to."
+6 QUIT
End DoDot:1
QUIT
+7 NEW DIR,X,Y,PGM,%UCI,DEF
+8 ;DEF is default routine to switch to.
SET DEF="ZU"
UCI SET DIR(0)="F"
SET DIR("A")="Select UCI:ROUTINE"
SET DIR("??")="^D SHOW^XUS3A"
+1 SET DIR("?")="Enter a UCI name (:Routine) to switch to."
+2 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!(X="^")
QUIT
+3 IF Y?.N
IF $DATA(^VA(200,DUZ,.2,Y,0))
SET UC=^(0)
SET Y=$PIECE(UC,U)_":"_$PIECE($PIECE(UC,U,2),":")
+4 ;for M/vx
SET X=$PIECE(Y,":")
SET PGM=$PIECE(Y,":",2,3)
IF PGM["
SET X=$PIECE(Y,":",1,2)
SET PGM=$PIECE(Y,":",3)
+5 IF PGM=""
SET PGM=DEF
SAME ;Didn't select anything.
IF X=""
QUIT
+1 DO PM
SET %UCI=X
XECUTE ^%ZOSF("UCICHECK")
IF 0[Y
GOTO BAD
+2 FOR DA=0:0
SET DA=$ORDER(^VA(200,DUZ,.2,DA))
IF DA'>0
QUIT
SET Y=^(DA,0)
Begin DoDot:1
+3 SET GO=0
SET X=$PIECE(Y,U)
SET XUA=$PIECE(Y,U,2)
DO PM
IF %UCI'=X
QUIT
+4 IF XUA=""
SET XUA=DEF
+5 FOR %=1:1:20
IF $PIECE(XUA,":",%)=PGM
SET GO=1
QUIT
+6 QUIT
End DoDot:1
IF GO
GOTO NXT
BAD WRITE !,"UCI not found!"
DO SHOW
GOTO UCI
+1 ;
NXT ;Here we go.
+1 DO C^XUSCLEAN
KILL ^XUTL("XQ",$JOB),^XUTL($JOB),^TMP($JOB),^UTILITY($JOB)
+2 ;K DA S XQZ="^"_PGM_"["_%UCI_"]" D DO^%XUCI G ^XUSCLEAN
+3 KILL DA
GOTO GO^%XUCI
+4 ;
+5 ;
SHOW WRITE !
SET I=0
SET UC=""
SET X=$SELECT($DATA(^VA(200,DUZ,201)):+^(201),1:0)
+1 WRITE !,"Enter ^ to return to your current menu, or select from:"
+2 FOR I=0:0
SET I=$ORDER(^VA(200,DUZ,.2,I))
IF I'>0
QUIT
Begin DoDot:1
+3 WRITE !,?5
SET UC=$GET(^VA(200,DUZ,.2,I,0))
SET X=$PIECE(UC,U,1)
SET UC=$PIECE(UC,U,2,99)
+4 IF UC'[":"
WRITE I
+5 DO PM
WRITE ?10,X
XECUTE ^%ZOSF("UCICHECK")
IF 0[Y
WRITE " -- Not currently a valid UCI!",$CHAR(7)
QUIT
+6 IF UC]""
WRITE ":"_UC
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
PM IF X="PROD"!(X="MGR")
SET X=^%ZOSF(X)
+1 QUIT
