XUP ;SFISC/RWF - Setup environment for programmers ;09/02/15 06:36
;;8.0;KERNEL;**208,258,284,432,469,659**;Jul 10, 1995;Build 22
;Per VA Directive 6402, this routine should not be modified.
W !,"Setting up programmer environment"
S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap
X ^%ZOSF("TYPE-AHEAD")
;Check if Production and report
W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",!
;
K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN
S U="^",DT=$$DT^XLFDT
S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP=""
D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1)
;Reset DUZ if user "Switched Identities".
I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV")
;Get user info
I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432
I $G(DUZ)>0 D DUZ(DUZ)
I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT
I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk")
S DTIME=600 ;Set a temp DTIME
S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432
S DUZ("LOA")=2 ;p659
S DUZ("AUTHENTICATION")="XUP"
;Getting Terminal Type
ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2
S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT
S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y
ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,!
S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS
S %=+$G(^VA(200,DUZ,.1)) I %>0 S %=$P(^XTV(8989.3,1,"XUS"),U,15)-($H-%) I %<14,%>0 W !!,"Your VERIFY code will expire in "_%_" days",!!
;Save info, Set last sign-on
D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT
;Check Mail
S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"."
;Setup error trap
I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP"
D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1
EXIT ;Clean-up and exit
D KILL1^XUSCLEAN K XQY,XQY0
I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
Q
;
ASKDUZ ;Ask for Access Code
N X
;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON
I X["^"!('$L(X)) S Y=-1 Q
S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2)
D ^XUSHSH S Y=$O(^VA(200,"A",X,0))
K DUZ D DUZ(+Y)
Q
;
DUZ(DA) ;Build DUZ for a user. Used by Mailman.
;(p284) Make the setting of several DUZ parts conditional.
N Y
S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
S DUZ=DA
S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4)
S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8)
S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0))
S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17)
S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7)
Q
;
DTIME(E,D) ;Return DTIME value for user E, device D.
N P
S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
Q $S(P]"":P,1:300)
;
ERR ;
N %XUP U $P
W !,"$ECODE=",$ECODE," $STACK=",$STACK
W !,"Location: ",$STACK($STACK-1,"PLACE")
R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER
D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUP 3461 printed Sep 23, 2025@19:47:38 Page 2
XUP ;SFISC/RWF - Setup environment for programmers ;09/02/15 06:36
+1 ;;8.0;KERNEL;**208,258,284,432,469,659**;Jul 10, 1995;Build 22
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 WRITE !,"Setting up programmer environment"
+4 ;Clear error and error trap
SET U="^"
SET $ECODE=""
SET $ETRAP=""
+5 XECUTE ^%ZOSF("TYPE-AHEAD")
+6 ;Check if Production and report
+7 WRITE !,"This is a "_$SELECT($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",!
+8 ;
+9 KILL ^UTILITY($JOB),^XUTL("XQ",$JOB)
DO KILL1^XUSCLEAN
+10 SET U="^"
SET DT=$$DT^XLFDT
+11 SET XUEOFF=^%ZOSF("EOFF")
SET XUEON=^%ZOSF("EON")
SET U="^"
SET XUTT=0
SET XUIOP=""
+12 DO GETENV^%ZOSV
SET XUENV=Y
SET XUVOL=$PIECE(Y,U,2)
SET XUCI=$PIECE(Y,U,1)
+13 ;Reset DUZ if user "Switched Identities".
+14 IF $DATA(DUZ("SAV"))
SET DUZ=+DUZ("SAV")
SET DUZ(0)=$PIECE(DUZ("SAV"),U,2)
KILL DUZ("SAV")
+15 ;Get user info
+16 ;p432
IF $GET(DUZ)>.5
IF $DATA(^VA(200,DUZ,0))[0
KILL DUZ
WRITE !,"DUZ Must point to a real user."
GOTO EXIT
+17 IF $GET(DUZ)>0
DO DUZ(DUZ)
+18 IF $GET(DUZ)'>0!('$DATA(DUZ(0)))
DO ASKDUZ
if Y'>0
GOTO EXIT
+19 IF '$DATA(XQUSER)
SET XQUSER=$SELECT($DATA(^VA(200,DUZ,20)):$PIECE(^(20),"^",2),1:"Unk")
+20 ;Set a temp DTIME
SET DTIME=600
+21 ;p432
SET DILOCKTM=+$GET(^DD("DILOCKTM"),1)
+22 ;p659
SET DUZ("LOA")=2
+23 SET DUZ("AUTHENTICATION")="XUP"
+24 ;Getting Terminal Type
ZIS IF XUTT
DO ENQ^XUS1
if $DATA(XUIOP(1))
GOTO ZIS2
SET Y=0
DO TT^XUS3
IF Y>0
SET XUIOP(1)=$PIECE(XUIOP,";",2)
GOTO ZIS2
+1 SET X="`"_+$GET(^VA(200,DUZ,1.2))
SET DIC="^%ZIS(2,"
SET DIC(0)="MQ"_$SELECT(X]"`0":"",1:"AE")
DO ^DIC
if Y'>0
GOTO EXIT
+2 SET XUIOP(1)=$PIECE(Y,U,2)
IF DIC(0)["A"
IF $GET(^VA(200,+DUZ,0))]""
SET $PIECE(^VA(200,DUZ,1.2),U,1)=+Y
ZIS2 SET %ZIS="L"
SET IOP="HOME;"_XUIOP(1)
DO ^%ZIS
if POP
GOTO EXIT
WRITE !,"Terminal Type set to: ",IOST,!
+1 SET DTIME=$$DTIME(DUZ,IOS)
SET DUZ("BUF")=1
SET XUDEV=IOS
+2 SET %=+$GET(^VA(200,DUZ,.1))
IF %>0
SET %=$PIECE(^XTV(8989.3,1,"XUS"),U,15)-($HOROLOG-%)
IF %<14
IF %>0
WRITE !!,"Your VERIFY code will expire in "_%_" days",!!
+3 ;Save info, Set last sign-on
+4 DO SAVE^XUS1
SET $PIECE(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT
+5 ;Check Mail
+6 SET Y=$PIECE($GET(^XMB(3.7,DUZ,0)),U,6)
IF Y
WRITE !,"You have "_Y_" new message"_$SELECT(Y=1:"",1:"s")_"."
+7 ;Setup error trap
+8 IF $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q")
SET $ETRAP="D ERR^XUP"
+9 DO KILL1^XUSCLEAN
SET $PIECE(XQXFLG,U,3)="XUP"
DO ^XQ1
EXIT ;Clean-up and exit
+1 DO KILL1^XUSCLEAN
KILL XQY,XQY0
+2 ;Run VPE
IF $GET(DUZ)>0
IF $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q")
IF $DATA(^%ZVEMS)
XECUTE ^%ZVEMS
+3 QUIT
+4 ;
ASKDUZ ;Ask for Access Code
+1 NEW X
+2 ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
+3 XECUTE XUEOFF
WRITE !,"Access Code: "
SET X=$$ACCEPT^XUS()
XECUTE XUEON
+4 IF X["^"!('$LENGTH(X))
SET Y=-1
QUIT
+5 SET X=$$UP^XLFSTR(X)
if X["
SET XUTT=1
SET X=$PIECE(X,":",1)_$PIECE(X,":",2)
+6 DO ^XUSHSH
SET Y=$ORDER(^VA(200,"A",X,0))
+7 KILL DUZ
DO DUZ(+Y)
+8 QUIT
+9 ;
DUZ(DA) ;Build DUZ for a user. Used by Mailman.
+1 ;(p284) Make the setting of several DUZ parts conditional.
+2 NEW Y
+3 SET Y(0)=$GET(^VA(200,+DA,0))
SET Y("XUS")=$GET(^XTV(8989.3,1,"XUS"))
+4 SET DUZ=DA
+5 if $GET(DUZ(0))'="@"
SET DUZ(0)=$PIECE(Y(0),"^",4)
+6 SET DUZ(1)=""
SET DUZ("AG")=$PIECE($GET(^XTV(8989.3,1,0)),"^",8)
+7 if '$GET(DUZ(2))
SET DUZ(2)=$ORDER(^VA(200,DUZ,2,0))
+8 if 'DUZ(2)
SET DUZ(2)=+$PIECE(Y("XUS"),"^",17)
+9 if '$LENGTH($GET(DUZ("LANG")))
SET DUZ("LANG")=$PIECE(Y("XUS"),"^",7)
+10 QUIT
+11 ;
DTIME(E,D) ;Return DTIME value for user E, device D.
+1 NEW P
+2 SET P=$PIECE($GET(^VA(200,+$GET(E),200)),"^",10)
if P=""
SET P=$PIECE($GET(^%ZIS(1,+$GET(D),"XUS")),"^",10)
if P=""
SET P=$PIECE($GET(^XTV(8989.3,1,"XUS")),"^",10)
+3 QUIT $SELECT(P]"":P,1:300)
+4 ;
ERR ;
+1 NEW %XUP
USE $PRINCIPAL
+2 WRITE !,"$ECODE=",$ECODE," $STACK=",$STACK
+3 WRITE !,"Location: ",$STACK($STACK-1,"PLACE")
+4 READ !!,"Want to record the error: No// ",%XUP:600
IF "Yy"[$EXTRACT(%XUP_"N")
DO ^%ZTER
+5 ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q
DO UNWIND^%ZTER
