- 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 Jan 18, 2025@03:14:08 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 ;