- 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 Jan 18, 2025@03:12:36 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