XUS1B ;ISF/RWF - Auto sign-on ;12/04/14 14:57
;;8.0;KERNEL;**59,337,395,469,543,594,638**;Jul 10, 1995;Build 15
;Per VA Directive 6402, this routine should not be modified.
Q
;
AUTOXUS() ;Do the check for XUS and Auto Sign-on
N %,FG,Y
I $G(XQXFLG("ASO")) Q 0 ;Already tried once.
G AUTO
;
AUTOXWB() ;Do the check for XWB and Auto Sign-on
N %,FG,Y,NUNOW
I $G(XQXFLG("ASO")) Q 0 ;Already tried so skip.
S XUNOW=$$NOW^XLFDT ;p543
AUTO ;Common code
I ($T(^XWBCAGNT)="")!($P(XOPT,U,18)="d") S XQXFLG("ZEBRA")=-1 Q 0 ;Disabled
S Y=$$CHKVIP(),%=0
I Y>0 S %=$$PREF($P(XOPT,U,18),$P($G(^VA(200,Y,200)),U,18))
I Y>0,'% S Y=0 ;No Auto signon
;check parameter, skip set if yes, default is no p594
I Y>0,'$$GET^XPAR("SYS","XU594",1,"Q") S DUZ(2)=+FG ;Set Division p543
Q Y
;
CHKVIP() ;Check for a Valid current IP
N REF,XREF,IEN,R0,ENV,JOB,HNDL,XTMP
;D SETUP ;To log data for debug
S IEN=0,ENV=$$ENV,REF=$G(IO("IP")) I $L(REF) D GETHNDL(.HNDL)
;p638 - Look thru the IPv6 X-ref
I $L(REF) D LKUP("AS4",$$FORCEIP6^XLFIPV(REF)) ;Will set IEN
Q IEN
;
LKUP(XREF,LK) ;Check one X-ref
N R0,R1,IX,D1,NM ;p543
S IX=0,IEN=0
F S IX=$O(^XUSEC(0,XREF,LK,IX)) Q:'$L(IX) D CHK Q:IEN>0
Q
CHK ;Could this be a good one.
N R0,R1,D1,XIPV6,REF6,XNM,REFNM
S R0=$G(^XUSEC(0,IX,0))
;Check that IP really matches (Q if IPv6<>REF6)
S XIPV6=$P($G(^XUSEC(0,IX,1)),U,1) ;Stored IPv6 address
S REF6=$$FORCEIP6^XLFIPV(REF) ;Reference address converted to IPv6
I XIPV6'=REF6 Q
;Check entry does not have sign-off D/T. p543
I $P(R0,U,4) Q
;Check that Client name matches
S XNM=$$LOW^XLFSTR($P(R0,U,12)) ;Stored client name
S REFNM=$$LOW^XLFSTR($P($G(IO("CLNM")),".")) ;Reference client name
I $L(XNM),$L(REFNM),XNM'=REFNM Q
;Check date within 8 hours p543
S D1=$$FMDIFF^XLFDT(XUNOW,IX,2) I (D1>28800)!(D1<-5) Q
;Check handle. Use timeout on Lock p543
S R1=$P(R0,U,13) I $L(R1),$D(HNDL(R1)) D
. L +^XWB("SESSION",IX_"~"_R1):DILOCKTM I $T L -^XWB("SESSION",IX_"~"_R1) Q
. ;Remove D LOG after debug.
. S IEN=+R0,FG=$P(R0,"^",17),XQXFLG("ASO")=IX ;D LOG Q ;Found a match
. Q
Q
;
ENV() N Y D GETENV^%ZOSV
Q Y
;
PREF(%1,%2) ;
Q $S($L(%2):%2,1:%1)
;
GETHNDL(RET) ;Get the Handles from the Client
N %,%1,X,XXX,TS
;Don't call Terminal servers/Proxy's
S TS=$G(IO("IP"))
I $L(TS),$O(^XTV(8989.3,1,405.2,"B",TS,0)) S XQXFLG("ZEBRA")=-1 Q ;Disable to TS and Proxy's
S %=$$CMD^XWBCAGNT(.XXX,"XWB GET HANDLES") I '% S XQXFLG("ZEBRA")=-1 Q ;Disable on Timeout p543
Q:'$O(XXX(0))
;build array
S RET=0,%1=1 F %=1:1:$L(XXX(%1),"^") S X=$P(XXX(%1),"^",%) S:X]"" RET(X)="",RET=RET+1
Q
;Temp for data collection
SETUP ;
N N1,N2
I '$D(^XTMP("XUSP543","CNT")) S ^XTMP("XUSP543",0)=$$HTFM^XLFDT($H+30)_"^"_XUNOW,^("CNT")=0
S N1="XUSP543",N2="CNT"
X "S XTMP=$INCREMENT(^XTMP(N1,N2))"
S ^XTMP("XUSP543",XTMP,0)=$G(IO("IP"))_U_$G(IO("ZIO"))_U_XUNOW
Q
;
LOG ;Log more data
M ^XTMP("XUSP543",XTMP,"HNDL")=HNDL
S ^XTMP("XUSP543",XTMP,"R0")=R0,^("R1")=R1,^("IX")=IX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS1B 3074 printed Oct 16, 2024@18:12:41 Page 2
XUS1B ;ISF/RWF - Auto sign-on ;12/04/14 14:57
+1 ;;8.0;KERNEL;**59,337,395,469,543,594,638**;Jul 10, 1995;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
AUTOXUS() ;Do the check for XUS and Auto Sign-on
+1 NEW %,FG,Y
+2 ;Already tried once.
IF $GET(XQXFLG("ASO"))
QUIT 0
+3 GOTO AUTO
+4 ;
AUTOXWB() ;Do the check for XWB and Auto Sign-on
+1 NEW %,FG,Y,NUNOW
+2 ;Already tried so skip.
IF $GET(XQXFLG("ASO"))
QUIT 0
+3 ;p543
SET XUNOW=$$NOW^XLFDT
AUTO ;Common code
+1 ;Disabled
IF ($TEXT(^XWBCAGNT)="")!($PIECE(XOPT,U,18)="d")
SET XQXFLG("ZEBRA")=-1
QUIT 0
+2 SET Y=$$CHKVIP()
SET %=0
+3 IF Y>0
SET %=$$PREF($PIECE(XOPT,U,18),$PIECE($GET(^VA(200,Y,200)),U,18))
+4 ;No Auto signon
IF Y>0
IF '%
SET Y=0
+5 ;check parameter, skip set if yes, default is no p594
+6 ;Set Division p543
IF Y>0
IF '$$GET^XPAR("SYS","XU594",1,"Q")
SET DUZ(2)=+FG
+7 QUIT Y
+8 ;
CHKVIP() ;Check for a Valid current IP
+1 NEW REF,XREF,IEN,R0,ENV,JOB,HNDL,XTMP
+2 ;D SETUP ;To log data for debug
+3 SET IEN=0
SET ENV=$$ENV
SET REF=$GET(IO("IP"))
IF $LENGTH(REF)
DO GETHNDL(.HNDL)
+4 ;p638 - Look thru the IPv6 X-ref
+5 ;Will set IEN
IF $LENGTH(REF)
DO LKUP("AS4",$$FORCEIP6^XLFIPV(REF))
+6 QUIT IEN
+7 ;
LKUP(XREF,LK) ;Check one X-ref
+1 ;p543
NEW R0,R1,IX,D1,NM
+2 SET IX=0
SET IEN=0
+3 FOR
SET IX=$ORDER(^XUSEC(0,XREF,LK,IX))
if '$LENGTH(IX)
QUIT
DO CHK
if IEN>0
QUIT
+4 QUIT
CHK ;Could this be a good one.
+1 NEW R0,R1,D1,XIPV6,REF6,XNM,REFNM
+2 SET R0=$GET(^XUSEC(0,IX,0))
+3 ;Check that IP really matches (Q if IPv6<>REF6)
+4 ;Stored IPv6 address
SET XIPV6=$PIECE($GET(^XUSEC(0,IX,1)),U,1)
+5 ;Reference address converted to IPv6
SET REF6=$$FORCEIP6^XLFIPV(REF)
+6 IF XIPV6'=REF6
QUIT
+7 ;Check entry does not have sign-off D/T. p543
+8 IF $PIECE(R0,U,4)
QUIT
+9 ;Check that Client name matches
+10 ;Stored client name
SET XNM=$$LOW^XLFSTR($PIECE(R0,U,12))
+11 ;Reference client name
SET REFNM=$$LOW^XLFSTR($PIECE($GET(IO("CLNM")),"."))
+12 IF $LENGTH(XNM)
IF $LENGTH(REFNM)
IF XNM'=REFNM
QUIT
+13 ;Check date within 8 hours p543
+14 SET D1=$$FMDIFF^XLFDT(XUNOW,IX,2)
IF (D1>28800)!(D1<-5)
QUIT
+15 ;Check handle. Use timeout on Lock p543
+16 SET R1=$PIECE(R0,U,13)
IF $LENGTH(R1)
IF $DATA(HNDL(R1))
Begin DoDot:1
+17 LOCK +^XWB("SESSION",IX_"~"_R1):DILOCKTM
IF $TEST
LOCK -^XWB("SESSION",IX_"~"_R1)
QUIT
+18 ;Remove D LOG after debug.
+19 ;D LOG Q ;Found a match
SET IEN=+R0
SET FG=$PIECE(R0,"^",17)
SET XQXFLG("ASO")=IX
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
ENV() NEW Y
DO GETENV^%ZOSV
+1 QUIT Y
+2 ;
PREF(%1,%2) ;
+1 QUIT $SELECT($LENGTH(%2):%2,1:%1)
+2 ;
GETHNDL(RET) ;Get the Handles from the Client
+1 NEW %,%1,X,XXX,TS
+2 ;Don't call Terminal servers/Proxy's
+3 SET TS=$GET(IO("IP"))
+4 ;Disable to TS and Proxy's
IF $LENGTH(TS)
IF $ORDER(^XTV(8989.3,1,405.2,"B",TS,0))
SET XQXFLG("ZEBRA")=-1
QUIT
+5 ;Disable on Timeout p543
SET %=$$CMD^XWBCAGNT(.XXX,"XWB GET HANDLES")
IF '%
SET XQXFLG("ZEBRA")=-1
QUIT
+6 if '$ORDER(XXX(0))
QUIT
+7 ;build array
+8 SET RET=0
SET %1=1
FOR %=1:1:$LENGTH(XXX(%1),"^")
SET X=$PIECE(XXX(%1),"^",%)
if X]""
SET RET(X)=""
SET RET=RET+1
+9 QUIT
+10 ;Temp for data collection
SETUP ;
+1 NEW N1,N2
+2 IF '$DATA(^XTMP("XUSP543","CNT"))
SET ^XTMP("XUSP543",0)=$$HTFM^XLFDT($HOROLOG+30)_"^"_XUNOW
SET ^("CNT")=0
+3 SET N1="XUSP543"
SET N2="CNT"
+4 XECUTE "S XTMP=$INCREMENT(^XTMP(N1,N2))"
+5 SET ^XTMP("XUSP543",XTMP,0)=$GET(IO("IP"))_U_$GET(IO("ZIO"))_U_XUNOW
+6 QUIT
+7 ;
LOG ;Log more data
+1 MERGE ^XTMP("XUSP543",XTMP,"HNDL")=HNDL
+2 SET ^XTMP("XUSP543",XTMP,"R0")=R0
SET ^("R1")=R1
SET ^("IX")=IX
+3 QUIT
