XUSRB4 ;ISF/RWF - Build a temporary sign-on token ;01/29/14 14:56
;;8.0;KERNEL;**150,337,395,419,437,499,523,573,596,638,659**;Jul 10, 1995;Build 22
;Per VA Directive 6402, this routine should not be modified.
Q
;
ASH(RET) ;rpc. Auto Signon Handle
N HDL
;Do not give token to user with authentication Level Of Assurance = 1, as they then would
;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
S RET="NOT AUTHENTICATED"
I $G(DUZ)<1 Q ;Not an authenticated user
I $G(DUZ("LOA"))=1 Q ;Not an authenticated user
S HDL=$$HANDLE("XWBAS",1),RET="~1"_HDL
;Now place user info in it.
D TOK(HDL)
Q
;
CCOW(RET) ;rpc. CCOW Auto Signon Handle
N HDL,HDL2,X
S RET(0)="NO PROXY USER",RET(1)="ERROR"
I $$USERTYPE^XUSAP(DUZ,"APPLICATION PROXY") Q ;No Proxy
I $$USERTYPE^XUSAP(DUZ,"CONNECTOR PROXY") Q ;No Proxy
;Do not give token to user with authentication Level Of Assurance = 1, as they then would
;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
S RET(0)="NOT AUTHENTICATED",RET(1)="ERROR"
I $G(DUZ("LOA"))=1 Q ;Not an authenticated user
S X=$$ACTIVE^XUSER(DUZ) I 'X S RET(0)=X Q ;User must be active
S HDL=$$HANDLE("XWBCCW",1)
;Return RET(0) the CCOW token, RET(1) the domain name and the Station #
S RET(0)="~2"_$$LOW^XLFSTR(HDL),RET(1)=$G(^XMB("NETNAME"))_"^"_$$STA^XUAF4(DUZ(2))
;Now place user info in it.
D TOK(HDL)
S ^XUTL("XQ",$J,"HDL")=HDL ;Save handle with job
Q
;
HANDLE(NS,LT) ;Return a unique handle into ^XTMP (ef. sup)
;NS is the namespace, LT is the Handle Lifetime in days
N %H,A,J,HL
I $G(NS)="" Q "" ;Return null if no namespace
S LT=$G(LT,1) S:LT>7 LT=7 ;Default to 1
S %H=$H,J=NS_($J#2048)_"-"_(%H#7*86400+$P(%H,",",2))_"_",A=$R(10)
F S HL=J_A,A=A+1 L +^XTMP(HL):1 I $T Q:'$D(^XTMP(HL)) L -^XTMP(HL)
S ^XTMP(HL,0)=$$HTFM^XLFDT(%H+LT)_"^"_$$DT^XLFDT()
;L -^XTMP(HL) Leave the Unlock to the caller
Q HL
;
TOK(H) ;Store a Token
;H is handle into XTMP
N J,T,R,%
S T=$$H3^%ZTM($H)
S R=$J_"|"_T_"|"_$G(DUZ)_"|"_H
S ^XTMP(H,"D",0)="|"_$$ENCRYP^XUSRB1(R)_"|"
S ^XTMP(H,"D2")=$G(DUZ(2))
S %=$G(IO("IP")) I $L(%),'$$VALIDATE^XLFIPV(%) S %=$P($$ADDRESS^XLFNSLK(%),",") ;p638
S ^XTMP(H,"D3")=%
S ^XTMP(H,"CLNM")=$G(IO("CLNM"))
S ^XTMP(H,"JOB",$J)=$G(IO("IP"))
S ^XTMP(H,"STATUS")="0^New",^("CNT")=0
L -^XTMP(H) ;Clear Lock
Q
;
REMOVE(HL) ;Remove (kill) a Handle. p523
I $L($G(HL)) K ^XTMP(HL)
Q
;
CHKASH(HL) ;rpc. Check a Auto Signon Handle
N HDL,RET,FDA,IEN S HDL=$E(HL,3,999)
S RET=$$CHECK(HDL)
I RET>0 D
. S DUZ("ASH")=1,IEN=DUZ_","
. I $$GET1^DIQ(200,IEN,7,"I") S FDA(200,DUZ_",",7)=0 D FILE^DIE("K","FDA") ;p403
D REMOVE(HDL) ;Token only good for one try.
Q RET
;
CHKCCOW(HL) ;rpc. Check a CCOW Auto Signon Handle
N HDL,RET,T
S HDL=$$UP^XLFSTR($E(HL,3,999)),T=$P($G(^XTV(8989.3,1,30),5400),U)
S RET=$$CHECK(HDL,T)
I RET>0 D
. ;This CCOW Token good for more that one try.
. S ^XTMP(HDL,"JOB",$J)=$G(IO("IP"))
. S ^XTMP(HDL,"STATUS")=(^XTMP(HDL,"STATUS")+1)_"^Active"
. S ^XUTL("XQ",$J,"HDL")=HDL ;Save handle with job
. S DUZ("CCOW")=1 ;Flag a CCOW sign-on.
Q RET
;
CHECK(HL,TOUT) ;Check a Token
N %,J,D,L,M,S,T,CLNM
S S=$G(^XTMP(HL,0)) I '$L(S) Q "0^Bad Handle"
S S=$G(^XTMP(HL,"D",0)) I '$L(S) Q "0^Bad Handle" ;Now have real token
I $E(S)'="|" Q "0^Bad Token"
S S=$$DECRYP^XUSRB1($E(S,2,$L(S)-1)) I S="" Q "0^Bad Token"
S J=$P(S,"|"),T=$P(S,"|",2),D=$P(S,"|",3),M=$P(S,"|",4)
;Check token time
S %=$$H3^%ZTM($H),TOUT=$G(TOUT,90) ; P573 changed 20 to 90 JLI
I T+TOUT<% D REMOVE(HL) Q "0^Token Expired" ;Token good for TOUT or 90 seconds
;Check job
;Check that token has handle
I M'=HL Q "0^Bad Token"
;Check User
I $G(^VA(200,D,0))="" Q "0^Bad User"
;Do IP check
S %=$G(IO("IP")),T=0,CLNM=""
I $L(%),'$$VALIDATE^XLFIPV(%) S CLNM=%,%=$P($$ADDRESS^XLFNSLK(%),",") ;p638
S CLNM=$S($L($G(IO("CLNM"))):IO("CLNM"),$L(CLNM):CLNM,1:"") ;p499
I $L($G(^XTMP(HL,"D3"))),^XTMP(HL,"D3")=% S T=1
I 'T,$L(CLNM),$G(^XTMP(HL,"CLNM"))=IO("CLNM") S T=1
I 'T,$$LOW^XLFSTR($S($L($G(IO("ZIO"))):IO("ZIO"),1:$G(IO)))[$P($G(^XTMP(HL,"CLNM")),".") S T=1 ;ram p596
I 'T Q "0^Different IP" ;p499
I $D(^XTMP(HL,"D2")),D>0 S DUZ(2)=^XTMP(HL,"D2")
D USER^XUS(D)
Q D
;
;
CCOWPC(RET) ;Return ap
N I,XU4
S RET(0)="" I '$$BROKER^XWBLIB Q
D GETLST^XPAR(.XU4,"SYS","XUS CCOW VAULT PARAM","Q")
F I=0,1 S RET(I)=$P($G(XU4(I+1)),"^",2,99)
Q
;
;p500
CCOWIP(RET,CLIENTIP) ;rpc. CCOW Auto Signon Handle for middle tiered application servers
N %
S %=$G(IO("IP")) ; save original
; get actual ip address instead of localhost address if possible
S IO("IP")=$S($G(CLIENTIP)=$$CONVERT^XLFIPV("127.0.0.1"):%,$G(CLIENTIP)="":%,1:$G(CLIENTIP)) ;p638
D CCOW(.RET)
S IO("IP")=% ; revert to original
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSRB4 4877 printed Sep 23, 2025@19:49:11 Page 2
XUSRB4 ;ISF/RWF - Build a temporary sign-on token ;01/29/14 14:56
+1 ;;8.0;KERNEL;**150,337,395,419,437,499,523,573,596,638,659**;Jul 10, 1995;Build 22
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
ASH(RET) ;rpc. Auto Signon Handle
+1 NEW HDL
+2 ;Do not give token to user with authentication Level Of Assurance = 1, as they then would
+3 ;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
+4 SET RET="NOT AUTHENTICATED"
+5 ;Not an authenticated user
IF $GET(DUZ)<1
QUIT
+6 ;Not an authenticated user
IF $GET(DUZ("LOA"))=1
QUIT
+7 SET HDL=$$HANDLE("XWBAS",1)
SET RET="~1"_HDL
+8 ;Now place user info in it.
+9 DO TOK(HDL)
+10 QUIT
+11 ;
CCOW(RET) ;rpc. CCOW Auto Signon Handle
+1 NEW HDL,HDL2,X
+2 SET RET(0)="NO PROXY USER"
SET RET(1)="ERROR"
+3 ;No Proxy
IF $$USERTYPE^XUSAP(DUZ,"APPLICATION PROXY")
QUIT
+4 ;No Proxy
IF $$USERTYPE^XUSAP(DUZ,"CONNECTOR PROXY")
QUIT
+5 ;Do not give token to user with authentication Level Of Assurance = 1, as they then would
+6 ;have the ability to re-authenticate at a higher Level Of Assurance (spoofing).
+7 SET RET(0)="NOT AUTHENTICATED"
SET RET(1)="ERROR"
+8 ;Not an authenticated user
IF $GET(DUZ("LOA"))=1
QUIT
+9 ;User must be active
SET X=$$ACTIVE^XUSER(DUZ)
IF 'X
SET RET(0)=X
QUIT
+10 SET HDL=$$HANDLE("XWBCCW",1)
+11 ;Return RET(0) the CCOW token, RET(1) the domain name and the Station #
+12 SET RET(0)="~2"_$$LOW^XLFSTR(HDL)
SET RET(1)=$GET(^XMB("NETNAME"))_"^"_$$STA^XUAF4(DUZ(2))
+13 ;Now place user info in it.
+14 DO TOK(HDL)
+15 ;Save handle with job
SET ^XUTL("XQ",$JOB,"HDL")=HDL
+16 QUIT
+17 ;
HANDLE(NS,LT) ;Return a unique handle into ^XTMP (ef. sup)
+1 ;NS is the namespace, LT is the Handle Lifetime in days
+2 NEW %H,A,J,HL
+3 ;Return null if no namespace
IF $GET(NS)=""
QUIT ""
+4 ;Default to 1
SET LT=$GET(LT,1)
if LT>7
SET LT=7
+5 SET %H=$HOROLOG
SET J=NS_($JOB#2048)_"-"_(%H#7*86400+$PIECE(%H,",",2))_"_"
SET A=$RANDOM(10)
+6 FOR
SET HL=J_A
SET A=A+1
LOCK +^XTMP(HL):1
IF $TEST
if '$DATA(^XTMP(HL))
QUIT
LOCK -^XTMP(HL)
+7 SET ^XTMP(HL,0)=$$HTFM^XLFDT(%H+LT)_"^"_$$DT^XLFDT()
+8 ;L -^XTMP(HL) Leave the Unlock to the caller
+9 QUIT HL
+10 ;
TOK(H) ;Store a Token
+1 ;H is handle into XTMP
+2 NEW J,T,R,%
+3 SET T=$$H3^%ZTM($HOROLOG)
+4 SET R=$JOB_"|"_T_"|"_$GET(DUZ)_"|"_H
+5 SET ^XTMP(H,"D",0)="|"_$$ENCRYP^XUSRB1(R)_"|"
+6 SET ^XTMP(H,"D2")=$GET(DUZ(2))
+7 ;p638
SET %=$GET(IO("IP"))
IF $LENGTH(%)
IF '$$VALIDATE^XLFIPV(%)
SET %=$PIECE($$ADDRESS^XLFNSLK(%),",")
+8 SET ^XTMP(H,"D3")=%
+9 SET ^XTMP(H,"CLNM")=$GET(IO("CLNM"))
+10 SET ^XTMP(H,"JOB",$JOB)=$GET(IO("IP"))
+11 SET ^XTMP(H,"STATUS")="0^New"
SET ^("CNT")=0
+12 ;Clear Lock
LOCK -^XTMP(H)
+13 QUIT
+14 ;
REMOVE(HL) ;Remove (kill) a Handle. p523
+1 IF $LENGTH($GET(HL))
KILL ^XTMP(HL)
+2 QUIT
+3 ;
CHKASH(HL) ;rpc. Check a Auto Signon Handle
+1 NEW HDL,RET,FDA,IEN
SET HDL=$EXTRACT(HL,3,999)
+2 SET RET=$$CHECK(HDL)
+3 IF RET>0
Begin DoDot:1
+4 SET DUZ("ASH")=1
SET IEN=DUZ_","
+5 ;p403
IF $$GET1^DIQ(200,IEN,7,"I")
SET FDA(200,DUZ_",",7)=0
DO FILE^DIE("K","FDA")
End DoDot:1
+6 ;Token only good for one try.
DO REMOVE(HDL)
+7 QUIT RET
+8 ;
CHKCCOW(HL) ;rpc. Check a CCOW Auto Signon Handle
+1 NEW HDL,RET,T
+2 SET HDL=$$UP^XLFSTR($EXTRACT(HL,3,999))
SET T=$PIECE($GET(^XTV(8989.3,1,30),5400),U)
+3 SET RET=$$CHECK(HDL,T)
+4 IF RET>0
Begin DoDot:1
+5 ;This CCOW Token good for more that one try.
+6 SET ^XTMP(HDL,"JOB",$JOB)=$GET(IO("IP"))
+7 SET ^XTMP(HDL,"STATUS")=(^XTMP(HDL,"STATUS")+1)_"^Active"
+8 ;Save handle with job
SET ^XUTL("XQ",$JOB,"HDL")=HDL
+9 ;Flag a CCOW sign-on.
SET DUZ("CCOW")=1
End DoDot:1
+10 QUIT RET
+11 ;
CHECK(HL,TOUT) ;Check a Token
+1 NEW %,J,D,L,M,S,T,CLNM
+2 SET S=$GET(^XTMP(HL,0))
IF '$LENGTH(S)
QUIT "0^Bad Handle"
+3 ;Now have real token
SET S=$GET(^XTMP(HL,"D",0))
IF '$LENGTH(S)
QUIT "0^Bad Handle"
+4 IF $EXTRACT(S)'="|"
QUIT "0^Bad Token"
+5 SET S=$$DECRYP^XUSRB1($EXTRACT(S,2,$LENGTH(S)-1))
IF S=""
QUIT "0^Bad Token"
+6 SET J=$PIECE(S,"|")
SET T=$PIECE(S,"|",2)
SET D=$PIECE(S,"|",3)
SET M=$PIECE(S,"|",4)
+7 ;Check token time
+8 ; P573 changed 20 to 90 JLI
SET %=$$H3^%ZTM($HOROLOG)
SET TOUT=$GET(TOUT,90)
+9 ;Token good for TOUT or 90 seconds
IF T+TOUT<%
DO REMOVE(HL)
QUIT "0^Token Expired"
+10 ;Check job
+11 ;Check that token has handle
+12 IF M'=HL
QUIT "0^Bad Token"
+13 ;Check User
+14 IF $GET(^VA(200,D,0))=""
QUIT "0^Bad User"
+15 ;Do IP check
+16 SET %=$GET(IO("IP"))
SET T=0
SET CLNM=""
+17 ;p638
IF $LENGTH(%)
IF '$$VALIDATE^XLFIPV(%)
SET CLNM=%
SET %=$PIECE($$ADDRESS^XLFNSLK(%),",")
+18 ;p499
SET CLNM=$SELECT($LENGTH($GET(IO("CLNM"))):IO("CLNM"),$LENGTH(CLNM):CLNM,1:"")
+19 IF $LENGTH($GET(^XTMP(HL,"D3")))
IF ^XTMP(HL,"D3")=%
SET T=1
+20 IF 'T
IF $LENGTH(CLNM)
IF $GET(^XTMP(HL,"CLNM"))=IO("CLNM")
SET T=1
+21 ;ram p596
IF 'T
IF $$LOW^XLFSTR($SELECT($LENGTH($GET(IO("ZIO"))):IO("ZIO"),1:$GET(IO)))[$PIECE($GET(^XTMP(HL,"CLNM")),".")
SET T=1
+22 ;p499
IF 'T
QUIT "0^Different IP"
+23 IF $DATA(^XTMP(HL,"D2"))
IF D>0
SET DUZ(2)=^XTMP(HL,"D2")
+24 DO USER^XUS(D)
+25 QUIT D
+26 ;
+27 ;
CCOWPC(RET) ;Return ap
+1 NEW I,XU4
+2 SET RET(0)=""
IF '$$BROKER^XWBLIB
QUIT
+3 DO GETLST^XPAR(.XU4,"SYS","XUS CCOW VAULT PARAM","Q")
+4 FOR I=0,1
SET RET(I)=$PIECE($GET(XU4(I+1)),"^",2,99)
+5 QUIT
+6 ;
+7 ;p500
CCOWIP(RET,CLIENTIP) ;rpc. CCOW Auto Signon Handle for middle tiered application servers
+1 NEW %
+2 ; save original
SET %=$GET(IO("IP"))
+3 ; get actual ip address instead of localhost address if possible
+4 ;p638
SET IO("IP")=$SELECT($GET(CLIENTIP)=$$CONVERT^XLFIPV("127.0.0.1"):%,$GET(CLIENTIP)="":%,1:$GET(CLIENTIP))
+5 DO CCOW(.RET)
+6 ; revert to original
SET IO("IP")=%
+7 QUIT
+8 ;
