XUS ;SFISC/STAFF - SIGNON ; 3/6/19 5:15pm
;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,584,659,702**;Jul 10, 1995;Build 19
;Per VA Directive 6402, this routine should not be modified.
;
;Sign-on message numbers are 30810.51 to 30810.99
S U="^" D INTRO^XUS1A()
K K ^XUTL("ZISPARAM",$I)
S U="^",XQXFLG("GUI")="^"
W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG")
S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W !
RESTART ;
S XUM=$$SET2 G:XUM NO
I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO
A ;
S (XUSER(0),XUSER(1),XQUR)=""
;Check for locked IP/device.
I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO
I $G(DUZ("LOA"))="" D
. S DUZ("LOA")=2
. S DUZ("AUTHENTICATION")="AVCODES"
. S XAPP=+$$FIND1^DIC(8994.5,,"B","TERMINAL EMULATOR") I XAPP<1 S XAPP=""
. S DUZ("REMAPP")=XAPP_"^TERMINAL EMULATOR" ;p702 Record application used to access VistA with A/V codes
;Auto Sign-on check
S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X,DUZ("AUTHENTICATION")="ASHTOKEN" D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B
;End Auto Sign-on check
X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out
I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN
S XQUR=$P(AV,";",3)
S DUZ=$$CHECKAV(AV) K AV
S XUM=$$UVALID() G:XUM NO
B ;
K XUF,%1 S XUF=0 X XUEON
I DUZ D USER^XUS1 G:XUM NO
I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO
G NO:'DUZ
S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X)
D TT^XUS3:$G(XUTT)
D CLRFAC^XUS3($G(IO("IP")))
PGM ;
S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK
S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK
I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403
S XUM=16
G NO
;
OK ;
D CHEK^XQ83
S (XUA,PGM)="XQ"
G NEXT^XUS1
;
CHK() ;Check that option exists and LOCK
I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1
Q 0
;
LC ;
S X=$$UP(X)
Q
UP(%) ;
Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
FAC ;Failed access
S:'DUZ XUF(.1)=$E(%1)
S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q
Q
NO ;Tell why didn't get on
S X=$$NO^XUS3() G RESTART:'X ;fall into exit
H ;Exit point for all applications
C ;CLOSE
G ^XUSCLEAN
;
ON ;
X ^%ZOSF("EON") Q
;
ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling
N X,Y S PRE=$G(PRE)
F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X)
I $E(X,1,13)="<?xml version" Q X ;p702 IAM SAML token
S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI.
I $P(X," ")="MAIL-BOX" S X=X_";XMR"
I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token
I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y
Q X
;
;Timeout used by XUSTZ call.
ACCEPT(TO) ;Read A/V and echo '*' char. (p702 Modified to accept IAM STS token)
;Have the Read write to flush the buffer on some systems
N A,B,C,E K DUOUT S A="",TO=$G(TO,60),E=0
F D Q:E
. R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^"
. I (A="^")!(C=13)!($L(A)>60) S E=1 Q
. I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q
. S A=A_$C(C) W *42
. Q
I $L(A)>60 D
. S E=0 W !!,"Please wait. Authenticating user credentials."
. F D Q:E
. . R B#200:5 W "." S A=A_B
. . I $L(B)<200 S E=1 W "." Q
Q A
;
CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB for A/V code sign-on)
N %,%1,X,Y,IEN,DA,DIK
S IEN=0
;Start CCOW
I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN
. I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="ASHTOKEN"
. I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="CCOWTOKEN"
. Q
;End CCOW
;Start SSOi (p702)
I $E(X1,1,13)="<?xml version" D Q:IEN>0 IEN
. S IEN=$$SAML(X1)
. I +IEN<0 S IEN=0 ;error with 2FA sign-on
. I IEN>0 D USER(IEN)
. Q
;End SSOi
S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X
Q:X'?1.20ANP 0
S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0
S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN)
S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X)
I $P(XUSER(1),"^",2)'=X D LBAV Q 0
I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK
I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="AVCODES"
Q IEN
LBAV ;Log Bad AV
D:XUF FAC
I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
Q
;
USER(IX) ;Build XUSER
S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1))
Q
;
XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL,XUOSVER
S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUOSVER=$$VERSION^%ZOSV
S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
Q
;
XOPT ;Setup initial XOPT
S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
Q
;
SET1(FLAG) ;Setup parameters (also called from XUSRB)
N %
S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION=""
I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP
S XUDEV=IOS,XUIOP=ION
D GETFAC^XUS3($G(IO("IP")))
S %=$P(XOPT,U,14)
I "N"'[% D
. S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0
. I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0
S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909
Q
SET2() ;EF. Return error code (also called from XUSRB)
N %,X
S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".")
K DUZ,XUSER
S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
S %=$$INHIBIT^XUSRB() I %>0 Q %
S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1))
I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I)
S DTIME=600
I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
Q 0
;
UVALID() ;EF. Is it valid for this user to sign on?
;ZEXCEPT: XUM,XUNOW,XUSER ;global Kernel variables used during sign-on
I DUZ'>0 Q 4
I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until
I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated
I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434
I $P(XUSER(0),U,7) Q 5 ;Disuser flag set
I '$L($P(XUSER(1),U,2)) Q 21 ;Null verify code not allowed p419
Q 0
;
DEVPAS() ;EF. Ask device password
X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON
S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6
Q 0
;
SAML(X) ;IF. Validate SAML token. (p702)
N I,IEND,ISTART,ISTOP
K ^TMP("SAML_XUS",$J)
S ISTOP=$P($L(X),".")
S I=0
F D Q:IEND>ISTOP
. S ISTART=(I*200)+1
. S IEND=ISTART+199
. S I=I+1
. S LINE=$E(X,ISTART,IEND)
. I LINE[$C(9) S LINE=$REPLACE(LINE,$C(9),$C(13,10))
. S ^TMP("SAML_XUS",$J,I)=LINE
Q $$EN^XUSAML($NA(^TMP("SAML_XUS",$J)))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS 7232 printed Apr 09, 2024@21:05:54 Page 2
XUS ;SFISC/STAFF - SIGNON ; 3/6/19 5:15pm
+1 ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,584,659,702**;Jul 10, 1995;Build 19
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Sign-on message numbers are 30810.51 to 30810.99
+5 SET U="^"
DO INTRO^XUS1A()
+6 KILL
KILL ^XUTL("ZISPARAM",$IO)
+7 SET U="^"
SET XQXFLG("GUI")="^"
+8 ;Sets DUZ("LANG")
WRITE !
SET $Y=0
DO SET1(1)
IF POP
SET XUM=3
GOTO NO
+9 SET XUSTMP(51)=$$EZBLD^DIALOG(30810.51)
SET XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
+10 WRITE !!,"Volume set: ",$PIECE(XUENV,U,4)," UCI: ",XUCI," Device: ",$IO
if $SELECT('$DATA(IO("ZIO"))
WRITE " (",IO("ZIO"),")"
WRITE !
RESTART ;
+1 SET XUM=$$SET2
if XUM
GOTO NO
+2 IF $PIECE(XU1,U,2)]""
SET XUM=$$DEVPAS()
IF XUM
if XUM<0
GOTO H
GOTO NO
A ;
+1 SET (XUSER(0),XUSER(1),XQUR)=""
+2 ;Check for locked IP/device.
+3 IF $$LKCHECK^XUSTZIP()
SET XUM=7
SET XUFAC=$PIECE(XOPT,U,2)
SET XUHALT=1
GOTO NO
+4 IF $GET(DUZ("LOA"))=""
Begin DoDot:1
+5 SET DUZ("LOA")=2
+6 SET DUZ("AUTHENTICATION")="AVCODES"
+7 SET XAPP=+$$FIND1^DIC(8994.5,,"B","TERMINAL EMULATOR")
IF XAPP<1
SET XAPP=""
+8 ;p702 Record application used to access VistA with A/V codes
SET DUZ("REMAPP")=XAPP_"^TERMINAL EMULATOR"
End DoDot:1
+9 ;Auto Sign-on check
+10 SET X=$$AUTOXUS^XUS1B()
IF X>0
SET DUZ=X
SET DUZ("AUTHENTICATION")="ASHTOKEN"
DO USER(DUZ)
WRITE !!,">> Auto Sign-on: ",$PIECE(XUSER(0),U)," <<<",!
GOTO B
+11 ;End Auto Sign-on check
+12 ;Get out
XECUTE XUEOFF
SET AV=$$ASKAV()
XECUTE XUEON
IF AV="^;^"
GOTO H
+13 IF AV["MAIL-BOX"
IF AV[";XMR"
SET (XUA,PGM)="XMR"
SET XMCHAN=$PIECE($PIECE(AV,";")," ",2)
SET DUZ=.5
GOTO XMR^XUSCLEAN
+14 SET XQUR=$PIECE(AV,";",3)
+15 SET DUZ=$$CHECKAV(AV)
KILL AV
+16 SET XUM=$$UVALID()
if XUM
GOTO NO
B ;
+1 KILL XUF,%1
SET XUF=0
XECUTE XUEON
+2 IF DUZ
DO USER^XUS1
if XUM
GOTO NO
+3 IF DUZ
if ($DATA(^%ZIS(1,XUDEV,"TIME"))!$DATA(^(95)))
DO SEC^XUS3
if XUM
GOTO NO
+4 if 'DUZ
GOTO NO
+5 SET DTIME=$PIECE(XOPT,U,10)
SET X=$SELECT(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD"
if $DATA(^%ZOSF(X))
XECUTE ^(X)
+6 if $GET(XUTT)
DO TT^XUS3
+7 DO CLRFAC^XUS3($GET(IO("IP")))
PGM ;
+1 SET Y=+$GET(^%ZIS(1,XUDEV,201))
IF Y>0
IF $$CHK
SET XQY=Y
GOTO OK
+2 SET Y=+$GET(^VA(200,DUZ,201))
IF Y>0
IF $$CHK
SET XQY=Y
GOTO OK
+3 ;rwf 403
IF $DATA(DUZ("ASH"))
SET Y=$ORDER(^DIC(19,"B","XU NOP MENU",0))
IF Y>0
SET XQY=Y
GOTO OK
+4 SET XUM=16
+5 GOTO NO
+6 ;
OK ;
+1 DO CHEK^XQ83
+2 SET (XUA,PGM)="XQ"
+3 GOTO NEXT^XUS1
+4 ;
CHK() ;Check that option exists and LOCK
+1 IF $DATA(^DIC(19,Y,0))
IF $SELECT($PIECE(^(0),U,6)="":1,1:$DATA(^XUSEC($PIECE(^(0),U,6),DUZ)))
QUIT 1
+2 QUIT 0
+3 ;
LC ;
+1 SET X=$$UP(X)
+2 QUIT
UP(%) ;
+1 QUIT $TRANSLATE(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
FAC ;Failed access
+1 if 'DUZ
SET XUF(.1)=$EXTRACT(%1)
+2 if XUF=2
SET XUF(.2)=XUF(.2)+1
SET XUF(XUF(.2))=%1
SET %1=""
QUIT
+3 QUIT
NO ;Tell why didn't get on
+1 ;fall into exit
SET X=$$NO^XUS3()
if 'X
GOTO RESTART
H ;Exit point for all applications
C ;CLOSE
+1 GOTO ^XUSCLEAN
+2 ;
ON ;
+1 XECUTE ^%ZOSF("EON")
QUIT
+2 ;
ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling
+1 NEW X,Y
SET PRE=$GET(PRE)
+2 FOR
WRITE !,PRE,XUSTMP(51)
SET X=$$ACCEPT
if X="^"
SET X="^;^"
if $LENGTH(X)
QUIT
+3 ;p702 IAM SAML token
IF $EXTRACT(X,1,13)="<?xml version"
QUIT X
+4 ;Convert TAB to ; to match GUI.
SET X=$TRANSLATE(X,$CHAR(9),";")
+5 IF $PIECE(X," ")="MAIL-BOX"
SET X=X_";XMR"
+6 ;Use CCOW token
IF $EXTRACT(X,1,7)="~~TOK~~"
QUIT X
+7 IF '$LENGTH($PIECE(X,";",2))
WRITE !,PRE,XUSTMP(52)
SET Y=$$ACCEPT
if Y="^"
SET X="^;"
SET $PIECE(X,";",2)=Y
+8 QUIT X
+9 ;
+10 ;Timeout used by XUSTZ call.
ACCEPT(TO) ;Read A/V and echo '*' char. (p702 Modified to accept IAM STS token)
+1 ;Have the Read write to flush the buffer on some systems
+2 NEW A,B,C,E
KILL DUOUT
SET A=""
SET TO=$GET(TO,60)
SET E=0
+3 FOR
Begin DoDot:1
+4 READ "",*C:TO
if ('$TEST)
SET DUOUT=1
if ('$TEST)!(C=94)
SET A="^"
+5 IF (A="^")!(C=13)!($LENGTH(A)>60)
SET E=1
QUIT
+6 IF C=127
if '$LENGTH(A)
QUIT
SET A=$EXTRACT(A,1,$LENGTH(A)-1)
WRITE $CHAR(8,32,8)
QUIT
+7 SET A=A_$CHAR(C)
WRITE *42
+8 QUIT
End DoDot:1
if E
QUIT
+9 IF $LENGTH(A)>60
Begin DoDot:1
+10 SET E=0
WRITE !!,"Please wait. Authenticating user credentials."
+11 FOR
Begin DoDot:2
+12 READ B#200:5
WRITE "."
SET A=A_B
+13 IF $LENGTH(B)<200
SET E=1
WRITE "."
QUIT
End DoDot:2
if E
QUIT
End DoDot:1
+14 QUIT A
+15 ;
CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB for A/V code sign-on)
+1 NEW %,%1,X,Y,IEN,DA,DIK
+2 SET IEN=0
+3 ;Start CCOW
+4 IF $EXTRACT(X1,1,7)="~~TOK~~"
Begin DoDot:1
+5 IF $EXTRACT(X1,8,9)="~1"
SET IEN=$$CHKASH^XUSRB4($EXTRACT(X1,8,255))
SET DUZ("AUTHENTICATION")="ASHTOKEN"
+6 IF $EXTRACT(X1,8,9)="~2"
SET IEN=$$CHKCCOW^XUSRB4($EXTRACT(X1,8,255))
SET DUZ("AUTHENTICATION")="CCOWTOKEN"
+7 QUIT
End DoDot:1
if IEN>0
QUIT IEN
+8 ;End CCOW
+9 ;Start SSOi (p702)
+10 IF $EXTRACT(X1,1,13)="<?xml version"
Begin DoDot:1
+11 SET IEN=$$SAML(X1)
+12 ;error with 2FA sign-on
IF +IEN<0
SET IEN=0
+13 IF IEN>0
DO USER(IEN)
+14 QUIT
End DoDot:1
if IEN>0
QUIT IEN
+15 ;End SSOi
+16 SET X1=$$UP(X1)
if X1["
SET XUTT=1
SET X1=$TRANSLATE(X1,":")
+17 SET X=$PIECE(X1,";")
if X="^"
QUIT -1
if XUF
SET %1="Access: "_X
+18 if X'?1.20ANP
QUIT 0
+19 SET X=$$EN^XUSHSH(X)
IF '$DATA(^VA(200,"A",X))
DO LBAV
QUIT 0
+20 SET %1=""
SET IEN=$ORDER(^VA(200,"A",X,0))
SET XUF(.3)=IEN
DO USER(IEN)
+21 SET X=$PIECE(X1,";",2)
if XUF
SET %1="Verify: "_X
SET X=$$EN^XUSHSH(X)
+22 IF $PIECE(XUSER(1),"^",2)'=X
DO LBAV
QUIT 0
+23 IF $GET(XUFAC(1))
SET DIK="^XUSEC(4,"
SET DA=XUFAC(1)
DO ^DIK
+24 IF $GET(DUZ("AUTHENTICATION"))=""
SET DUZ("AUTHENTICATION")="AVCODES"
+25 QUIT IEN
LBAV ;Log Bad AV
+1 if XUF
DO FAC
+2 IF IEN
SET X=$PIECE($GET(^VA(200,IEN,1.1)),U,2)+1
SET $PIECE(^(1.1),"^",2)=X
+3 QUIT
+4 ;
USER(IX) ;Build XUSER
+1 SET XUSER(0)=$GET(^VA(200,+IX,0))
SET XUSER(1)=$GET(^(.1))
SET XUSER(1.1)=$GET(^(1.1))
+2 QUIT
+3 ;
XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL,XUOSVER
+1 SET U="^"
DO GETENV^%ZOSV
SET XUENV=Y
SET XUCI=$PIECE(Y,U,1)
SET XQVOL=$PIECE(Y,U,2)
SET XUOSVER=$$VERSION^%ZOSV
+2 SET X=$ORDER(^XTV(8989.3,1,4,"B",XQVOL,0))
SET XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
+3 QUIT
+4 ;
XOPT ;Setup initial XOPT
+1 SET XOPT=$SELECT($DATA(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
+2 FOR I=2:1:15
IF $PIECE(XOPT,U,I)=""
SET $PIECE(XOPT,U,I)=$PIECE("^5^900^1^1^^^^1^300^^^^N^90",U,I)
+3 QUIT
+4 ;
SET1(FLAG) ;Setup parameters (also called from XUSRB)
+1 NEW %
+2 SET U="^"
SET XUEON=^%ZOSF("EON")
SET XUEOFF=^("EOFF")
+3 ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
DO XUVOL
DO XOPT
SET DUZ("LANG")=$PIECE(XOPT,U,7)
+4 KILL ^XUTL("XQ",$JOB)
SET XUF=0
SET XUDEV=0
SET DUZ=0
SET DUZ(0)="@"
SET IOS=0
SET ION=""
+5 IF FLAG
SET %ZIS="L"
SET IOP="HOME"
DO ^%ZIS
if POP
QUIT
+6 SET XUDEV=IOS
SET XUIOP=ION
+7 DO GETFAC^XUS3($GET(IO("IP")))
+8 SET %=$PIECE(XOPT,U,14)
+9 IF "N"'[%
Begin DoDot:1
+10 SET XUF=(%["R")+1
SET XUF(.1)=""
SET XUF(.2)=0
SET XUF(.3)=0
+11 IF %["D"
if $DATA(^XTV(8989.3,1,4.33,"B",XUDEV))[0
SET XUF=0
End DoDot:1
+12 ;p434 IA#4909
SET DILOCKTM=+$GET(^DD("DILOCKTM"),1)
+13 QUIT
SET2() ;EF. Return error code (also called from XUSRB)
+1 NEW %,X
+2 SET XUNOW=$$HTFM^XLFDT($HOROLOG)
SET DT=$PIECE(XUNOW,".")
+3 KILL DUZ,XUSER
+4 SET (DUZ,DUZ(2))=0
SET (DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
+5 SET %=$$INHIBIT^XUSRB()
IF %>0
QUIT %
+6 SET X=$GET(^%ZIS(1,XUDEV,"XUS"))
SET XU1=$GET(^(1))
+7 IF $LENGTH(X)
FOR I=1:1:15
IF $LENGTH($PIECE(X,U,I))
SET $PIECE(XOPT,U,I)=$PIECE(X,U,I)
+8 SET DTIME=600
+9 IF '$PIECE(XOPT,U,11)
IF $DATA(^%ZIS(1,XUDEV,90))
IF ^(90)>2800000
IF ^(90)'>DT
QUIT 8
+10 QUIT 0
+11 ;
UVALID() ;EF. Is it valid for this user to sign on?
+1 ;ZEXCEPT: XUM,XUNOW,XUSER ;global Kernel variables used during sign-on
+2 IF DUZ'>0
QUIT 4
+3 ;User locked until
IF $PIECE(XUSER(1.1),U,5)
IF $PIECE(XUSER(1.1),U,5)>XUNOW
SET XUM(0)=$$FMTE^XLFDT($PIECE(XUSER(1.1),U,5),"2PM")
QUIT 18
+4 ;Access Terminated
IF $PIECE(XUSER(0),U,11)
IF $PIECE(XUSER(0),U,11)'>DT
QUIT 11
+5 ;If auto handle, Allow to sign-on p434
IF $DATA(DUZ("ASH"))
QUIT 0
+6 ;Disuser flag set
IF $PIECE(XUSER(0),U,7)
QUIT 5
+7 ;Null verify code not allowed p419
IF '$LENGTH($PIECE(XUSER(1),U,2))
QUIT 21
+8 QUIT 0
+9 ;
DEVPAS() ;EF. Ask device password
+1 XECUTE XUEOFF
WRITE !,"DEVICE PASSWORD: "
READ X:60
XECUTE XUEON
+2 SET X=$EXTRACT(X,1,30)
if '$TEST
SET X="^"
DO LC
if X["^"
QUIT -1
IF $PIECE(XU1,U,2)'=X
if XUF
SET %1="Device: "_X
if XUF
DO FAC
QUIT 6
+3 QUIT 0
+4 ;
SAML(X) ;IF. Validate SAML token. (p702)
+1 NEW I,IEND,ISTART,ISTOP
+2 KILL ^TMP("SAML_XUS",$JOB)
+3 SET ISTOP=$PIECE($LENGTH(X),".")
+4 SET I=0
+5 FOR
Begin DoDot:1
+6 SET ISTART=(I*200)+1
+7 SET IEND=ISTART+199
+8 SET I=I+1
+9 SET LINE=$EXTRACT(X,ISTART,IEND)
+10 IF LINE[$CHAR(9)
