- 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 Jan 18, 2025@03:13:01 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)