Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUS

XUS.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;Sign-on message numbers are 30810.51 to 30810.99
  1. S U="^" D INTRO^XUS1A()
  1. K K ^XUTL("ZISPARAM",$I)
  1. S U="^",XQXFLG("GUI")="^"
  1. W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG")
  1. S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52)
  1. W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W !
  1. RESTART ;
  1. S XUM=$$SET2 G:XUM NO
  1. I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO
  1. A ;
  1. S (XUSER(0),XUSER(1),XQUR)=""
  1. ;Check for locked IP/device.
  1. I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO
  1. I $G(DUZ("LOA"))="" D
  1. . S DUZ("LOA")=2
  1. . S DUZ("AUTHENTICATION")="AVCODES"
  1. . S XAPP=+$$FIND1^DIC(8994.5,,"B","TERMINAL EMULATOR") I XAPP<1 S XAPP=""
  1. . S DUZ("REMAPP")=XAPP_"^TERMINAL EMULATOR" ;p702 Record application used to access VistA with A/V codes
  1. ;Auto Sign-on check
  1. 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
  1. ;End Auto Sign-on check
  1. X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out
  1. I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN
  1. S XQUR=$P(AV,";",3)
  1. S DUZ=$$CHECKAV(AV) K AV
  1. S XUM=$$UVALID() G:XUM NO
  1. B ;
  1. K XUF,%1 S XUF=0 X XUEON
  1. I DUZ D USER^XUS1 G:XUM NO
  1. I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO
  1. G NO:'DUZ
  1. S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X)
  1. D TT^XUS3:$G(XUTT)
  1. D CLRFAC^XUS3($G(IO("IP")))
  1. PGM ;
  1. S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK
  1. S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK
  1. I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403
  1. S XUM=16
  1. G NO
  1. ;
  1. OK ;
  1. D CHEK^XQ83
  1. S (XUA,PGM)="XQ"
  1. G NEXT^XUS1
  1. ;
  1. CHK() ;Check that option exists and LOCK
  1. I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1
  1. Q 0
  1. ;
  1. LC ;
  1. S X=$$UP(X)
  1. Q
  1. UP(%) ;
  1. Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;
  1. FAC ;Failed access
  1. S:'DUZ XUF(.1)=$E(%1)
  1. S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q
  1. Q
  1. NO ;Tell why didn't get on
  1. S X=$$NO^XUS3() G RESTART:'X ;fall into exit
  1. H ;Exit point for all applications
  1. C ;CLOSE
  1. G ^XUSCLEAN
  1. ;
  1. ON ;
  1. X ^%ZOSF("EON") Q
  1. ;
  1. ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling
  1. N X,Y S PRE=$G(PRE)
  1. F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X)
  1. I $E(X,1,13)="<?xml version" Q X ;p702 IAM SAML token
  1. S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI.
  1. I $P(X," ")="MAIL-BOX" S X=X_";XMR"
  1. I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token
  1. I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y
  1. Q X
  1. ;
  1. ;Timeout used by XUSTZ call.
  1. 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
  1. N A,B,C,E K DUOUT S A="",TO=$G(TO,60),E=0
  1. F D Q:E
  1. . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^"
  1. . I (A="^")!(C=13)!($L(A)>60) S E=1 Q
  1. . I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q
  1. . S A=A_$C(C) W *42
  1. . Q
  1. I $L(A)>60 D
  1. . S E=0 W !!,"Please wait. Authenticating user credentials."
  1. . F D Q:E
  1. . . R B#200:5 W "." S A=A_B
  1. . . I $L(B)<200 S E=1 W "." Q
  1. Q A
  1. ;
  1. CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB for A/V code sign-on)
  1. N %,%1,X,Y,IEN,DA,DIK
  1. S IEN=0
  1. ;Start CCOW
  1. I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN
  1. . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="ASHTOKEN"
  1. . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)),DUZ("AUTHENTICATION")="CCOWTOKEN"
  1. . Q
  1. ;End CCOW
  1. ;Start SSOi (p702)
  1. I $E(X1,1,13)="<?xml version" D Q:IEN>0 IEN
  1. . S IEN=$$SAML(X1)
  1. . I +IEN<0 S IEN=0 ;error with 2FA sign-on
  1. . I IEN>0 D USER(IEN)
  1. . Q
  1. ;End SSOi
  1. S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
  1. S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X
  1. Q:X'?1.20ANP 0
  1. S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0
  1. S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN)
  1. S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X)
  1. I $P(XUSER(1),"^",2)'=X D LBAV Q 0
  1. I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK
  1. I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="AVCODES"
  1. Q IEN
  1. LBAV ;Log Bad AV
  1. D:XUF FAC
  1. I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
  1. Q
  1. ;
  1. USER(IX) ;Build XUSER
  1. S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1))
  1. Q
  1. ;
  1. XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL,XUOSVER
  1. S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUOSVER=$$VERSION^%ZOSV
  1. 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")
  1. Q
  1. ;
  1. XOPT ;Setup initial XOPT
  1. S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
  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)
  1. Q
  1. ;
  1. SET1(FLAG) ;Setup parameters (also called from XUSRB)
  1. N %
  1. S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
  1. D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
  1. K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION=""
  1. I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP
  1. S XUDEV=IOS,XUIOP=ION
  1. D GETFAC^XUS3($G(IO("IP")))
  1. S %=$P(XOPT,U,14)
  1. I "N"'[% D
  1. . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0
  1. . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0
  1. S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909
  1. Q
  1. SET2() ;EF. Return error code (also called from XUSRB)
  1. N %,X
  1. S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".")
  1. K DUZ,XUSER
  1. S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)=""
  1. S %=$$INHIBIT^XUSRB() I %>0 Q %
  1. S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1))
  1. I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I)
  1. S DTIME=600
  1. I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
  1. Q 0
  1. ;
  1. UVALID() ;EF. Is it valid for this user to sign on?
  1. ;ZEXCEPT: XUM,XUNOW,XUSER ;global Kernel variables used during sign-on
  1. I DUZ'>0 Q 4
  1. 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
  1. I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated
  1. I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434
  1. I $P(XUSER(0),U,7) Q 5 ;Disuser flag set
  1. I '$L($P(XUSER(1),U,2)) Q 21 ;Null verify code not allowed p419
  1. Q 0
  1. ;
  1. DEVPAS() ;EF. Ask device password
  1. X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON
  1. 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
  1. Q 0
  1. ;
  1. SAML(X) ;IF. Validate SAML token. (p702)
  1. N I,IEND,ISTART,ISTOP
  1. K ^TMP("SAML_XUS",$J)
  1. S ISTOP=$P($L(X),".")
  1. S I=0
  1. F D Q:IEND>ISTOP
  1. . S ISTART=(I*200)+1
  1. . S IEND=ISTART+199
  1. . S I=I+1
  1. . S LINE=$E(X,ISTART,IEND)
  1. . I LINE[$C(9) S LINE=$REPLACE(LINE,$C(9),$C(13,10))
  1. . S ^TMP("SAML_XUS",$J,I)=LINE
  1. Q $$EN^XUSAML($NA(^TMP("SAML_XUS",$J)))
  1. ;