INHVCRV ; JC Hrubovcak ; 22 Oct 1999 15:49 ;
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
; HL7/PWS logon utilities
Q
;
VALID(INV,INUIF,INOA,INODA) ; subroutine, VALIDate LoS logon request
; Input:
; INV array - (req) ZIL1=REQ, ZIL2=IP address, ZIL3=port, ZIL7=requested
; division, ZIL8=access code, ZIL9=verify code
; INUIF - (req) UNIVERSAL INTERFACE IEN
;
; Output:
; INOA array - (pbr) ZIL1=REQ, ZIL4=user, ZIL5=provider, ZIL6=timeout,
; ZIL10=ticket/key. These values are returned to
; the remote system.
; INODA array - (pbr) 1st subscript file#, 2nd subscript IEN. Not used.
;
N B,INBPNAPS,INDSTP,INERR
; Initialization
D RTNINIT S INOA("ZIL1")="REQ"
S B=$$INPARMS^INHVCRL2(.INDSTP,.INPARMS,.INERR,INUIF) I B D LOGERR(.INERR),NACK Q
S INBPNAPS=+$P($G(^INRHT(INPARMS(INDSTP,"TTIN"),0)),U,17) I INBPNAPS'>0 D LOGERR("Missing Application Process pointer for INTERFACE TRANSACTION TYPE, '"_INPARMS(INDSTP,"TTIN01")_"'"),NACK Q
; validate IP address
S B=$$VALIDIP^INHULOG(INBPNAPS,@INV@("ZIL2")) I B D LOGERR("Invalid remote IP address '"_@INV@("ZIL2")_"': "_$P(B,U,2)),NACK Q
; validate user
S B=$$LOGON(.INV,.INOA,.INODA) I B'>0 D LOGERR("Invalid LOGON: "_$P(B,U,2)),NACK Q
; create Application server (ApS)
S B=$$NEWSVR^INHVCRV1(INBPNAPS,.INV,.INOA) I B D LOGERR("'Application Server creation' failed: "_B),NACK Q
;
; any additional validation would follow here
;
D ACCEPT,CLEANUP ; successful logon
Q
;
REVALID(INV,INOA) ; subroutine, Validate ApS logon request
; Input:
; INV array - (req) ZIL1=ON, ZIL2=IP address, ZIL3=port, ZIL7=requested
; division, ZIL8=access code, ZIL9=verify code,
; ZIL11=scrambled,seeded key/ticket from remote sys
;
; Input passed from ApS (all required):
; INADDR = IP address of remote server to connect to as a TCP client,
; or null to open as a TCP server
; INBPN = BACKGROUND PROCESS CONTROL IEN for ApS
; INDUZ = USER IEN
; INPORT = IP port to open (client or server)
; INTICK = security ticket
;
; Output:
; INOA array - (pbr) No ZIL segment values are returned to the remote
; system (in the ApS Ack).
; INODA array - 1st subscript file#, 2nd subscript IEN. Not used.
;
N B,INUSER
; Initialization
D RTNINIT
S INOA("~NOZIL")=1 ; boolean flag, no ZIL segments returned
; validate scrambled,seeded key/ticket from remote system
S INTICK=$G(INTICK) I '$L(INTICK) D LOGERR("Logon ticket missing") Q
S B=$P($G(^INTHPC(INBPN,7)),U,4) I '$L(B) D LOGERR("Missing Key Frame") Q
I $$FRHASH(INTICK,B)'=@INV@("ZIL11") D LOGERR("Invalid framed ticket sent by remote system") Q
; validate remote IP address/port against values received from LoS
I $G(INADDR)'=@INV@("ZIL2") D LOGERR("Remote IP address does not match IP address validated by CHCS Logon Server") Q
I $G(INPORT)'=@INV@("ZIL3") D LOGERR("Remote port does not match port validated by CHCS Logon Server") Q
; validate user
S INUSER=$$LOGON(.INV,.INOA,.INODA) K INOA("~NOZIL") I INUSER'>0 D LOGERR("Invalid LOGON: "_$P(INUSER,U,2)) Q
; validate remote user against values received from LoS
I $G(INDUZ)'=INUSER D LOGERR("Remote user does not match user validated by CHCS Logon Server") Q
;
; any additional validation would follow here
;
D ACCEPT,CLEANUP,LGNLOG^INHULOG(INUSER) ; successful logon
Q
;
LOGON(INV,INOA,INODA) ; $$function - Validate user, based on information sent
; by remote system (INV). Get information to return to remote system
; (INOA).
;
; Input:
; INV array - (req) ZIL7=requested division, ZIL8=access code,
; ZIL9=verify code. Note that validating a
; "requested" division is NOT currently implemented.
;
; Output:
; INOA array - (pbr) ZIL4=user, ZIL5=provider, ZIL6=timeout,
; ZIL10=ticket/key if LoS logon (not ApS logon).
; INODA array - (pbr) 1st subscript file#, 2nd subscript IEN.
;
; Function returns: USER IEN = successful user validation
; "0^Error msg" = failure
;
; Symbol table Input: - INANYONE 1 - Anyone can access,
; 0 - Provider access only
;
N INH9,X,Y,Z,INHZERO
D SETDT^UTDT
; access & verify code
S INH9("AC")=$G(@INV@("ZIL8")),INH9("VC")=$G(@INV@("ZIL9"))
; requested divison
S INH9("REQDIV")=$G(@INV@("ZIL7"))
; User's zero node is returned in Z
S INH9("USER")=$$GETDUZ^INHULOG(INH9("AC"),INH9("VC"),.Z)
;
I INH9("USER")'>0 Q "0^Invalid Access/Verify code"
S X=$$DIVCHK^INHULOG(INH9("USER")) Q:'X "0^"_X ; validate division
; Determine if user is an authorized HCP
S INH9("HCP")=$P($G(^DIC(3,INH9("USER"),8000)),"^") ; get provider
;;Folloing logic is specific to CHCS. Must be revised if used for IHS
;I '$G(INANYONE) S X=$$PWSPRO^ORGISPRO(INH9("USER")) Q:X "0^User '"_INH9("USER")_"' is not an authorized HCP"
; get remote system timeout value (used to determine if remote has
; disconnected w/out notifying connected system)
S INH9("DTIME")=$$DTIME^INHULOG(INH9("USER"),900)
S INHZERO=$G(^DIC(3,INH9("USER"),0))
S INH9("FMACC")=$P(INHZERO,"^",4)
S INH9("DEFDIV")=$P(INHZERO,"^",16)
S INH9("MSIGN")=$P($G(^DIC(3,INH9("USER"),200)),"^",4)
S INODA(3,INH9("USER"))="" S:'$G(INANYONE) INODA(6,INH9("HCP"))=""
; ZIL segment is returned in LoS Ack (not in ApS Ack)
S:'$G(INOA("~NOZIL")) INOA("ZIL4")=INH9("USER"),INOA("ZIL5")=INH9("HCP"),INOA("ZIL6")=INH9("DTIME"),INOA("ZIL10")=$$TICKET^INHULOG,INOA("ZIL12")=INH9("FMACC"),INOA("ZIL13")=INH9("DEFDIV"),INOA("ZIL14")=INH9("MSIGN")
;
Q INH9("USER") ; successful validation
;
LOGOFF(INV,INOA) ; Lookup/Store call for ApS logoff msg
S INOA("INACKTXT")="CHCS Logoff Error",INOA("INSTAT")="AE" ; in case of error
; note: logic derived from H^XUS, except no device calls are made
S DUZ=+$G(DUZ) N A S A=$G(^ZUTL("XQ",$J,0)) I A,$D(^XUSEC(0,A,0)) L +^XUSEC(0,A,0):1 I D SETDT^UTDT S %=$P($H,",",2),$P(^XUSEC(0,A,0),U,4)=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) L -^XUSEC(0,A,0)
K:$L($G(DUZ)) ^XMB7(DUZ,100,$$DEVID^%ZTOS),^($I),^($P) ; indicates where currently logged on
D CLRSTOR^INHULOG ; clear scratch storage
; the application cleanup (see APPERR^ZU) would go here, if needed
D ACCEPT ; Application Accept
Q
;
RTNINIT ; init return values, INOA & INODA array, error message into INOA
K INOA,INODA S INODA="",INOA("INSTAT")="AE",INOA("INACKTXT")="Invalid CHCS Logon Attempt",INOA("INORIGID")=@INV@("MSH10")
Q
;
ACCEPT ; set "INSTAT" to Application Accept, KILL the error text
K INOA("INACKTXT") S INOA("INSTAT")="AA"
Q
;
CLEANUP ; Cleanup following "successful" validation of logon message.
; Input: INUIF=UIF IEN of inbound msg
; Output: None.
;
; Delete information from ZIL segment(s) in inbound msg (security).
L +^INTHU(INUIF,0):0 I D
. N A,B,J M A=^INTHU(INUIF,3) S (B,J)=0 F S J=$O(A(J)) Q:'J I $E($G(A(J,0)),1,3)="ZIL" S A(J,0)="ZIL^<SEGMENT CLEARED>|CR|",B=1
. I B K ^INTHU(INUIF,3) M ^INTHU(INUIF,3)=A
. L -^INTHU(INUIF,0)
Q
;
FRHASH(INTICKET,INFRAME) ; $$function - frame the ticket, encrypt, return
N H,L,X S L=$L(INFRAME),H=L+1\2,X=$E(INFRAME,1,H)_INTICKET_$E(INFRAME,H+1,L)
D ^XUSHSH Q X
;
NACK ; negative acknowledgement
N % F %="ZIL4","ZIL5","ZIL6","ZIL10" S INOA(%)=""
Q
;
LOGERR(E) ; log error message E
S INSTERR=$G(INSTERR) D ERROR^INHS(E,2)
Q
;
INHVCRV ; JC Hrubovcak ; 22 Oct 1999 15:49 ;
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ; HL7/PWS logon utilities
+4 QUIT
+5 ;
VALID(INV,INUIF,INOA,INODA) ; subroutine, VALIDate LoS logon request
+1 ; Input:
+2 ; INV array - (req) ZIL1=REQ, ZIL2=IP address, ZIL3=port, ZIL7=requested
+3 ; division, ZIL8=access code, ZIL9=verify code
+4 ; INUIF - (req) UNIVERSAL INTERFACE IEN
+5 ;
+6 ; Output:
+7 ; INOA array - (pbr) ZIL1=REQ, ZIL4=user, ZIL5=provider, ZIL6=timeout,
+8 ; ZIL10=ticket/key. These values are returned to
+9 ; the remote system.
+10 ; INODA array - (pbr) 1st subscript file#, 2nd subscript IEN. Not used.
+11 ;
+12 NEW B,INBPNAPS,INDSTP,INERR
+13 ; Initialization
+14 DO RTNINIT
SET INOA("ZIL1")="REQ"
+15 SET B=$$INPARMS^INHVCRL2(.INDSTP,.INPARMS,.INERR,INUIF)
IF B
DO LOGERR(.INERR)
DO NACK
QUIT
+16 SET INBPNAPS=+$PIECE($GET(^INRHT(INPARMS(INDSTP,"TTIN"),0)),U,17)
IF INBPNAPS'>0
DO LOGERR("Missing Application Process pointer for INTERFACE TRANSACTION TYPE, '"_INPARMS(INDSTP,"TTIN01")_"'")
DO NACK
QUIT
+17 ; validate IP address
+18 SET B=$$VALIDIP^INHULOG(INBPNAPS,@INV@("ZIL2"))
IF B
DO LOGERR("Invalid remote IP address '"_@INV@("ZIL2")_"': "_$PIECE(B,U,2))
DO NACK
QUIT
+19 ; validate user
+20 SET B=$$LOGON(.INV,.INOA,.INODA)
IF B'>0
DO LOGERR("Invalid LOGON: "_$PIECE(B,U,2))
DO NACK
QUIT
+21 ; create Application server (ApS)
+22 SET B=$$NEWSVR^INHVCRV1(INBPNAPS,.INV,.INOA)
IF B
DO LOGERR("'Application Server creation' failed: "_B)
DO NACK
QUIT
+23 ;
+24 ; any additional validation would follow here
+25 ;
+26 ; successful logon
DO ACCEPT
DO CLEANUP
+27 QUIT
+28 ;
REVALID(INV,INOA) ; subroutine, Validate ApS logon request
+1 ; Input:
+2 ; INV array - (req) ZIL1=ON, ZIL2=IP address, ZIL3=port, ZIL7=requested
+3 ; division, ZIL8=access code, ZIL9=verify code,
+4 ; ZIL11=scrambled,seeded key/ticket from remote sys
+5 ;
+6 ; Input passed from ApS (all required):
+7 ; INADDR = IP address of remote server to connect to as a TCP client,
+8 ; or null to open as a TCP server
+9 ; INBPN = BACKGROUND PROCESS CONTROL IEN for ApS
+10 ; INDUZ = USER IEN
+11 ; INPORT = IP port to open (client or server)
+12 ; INTICK = security ticket
+13 ;
+14 ; Output:
+15 ; INOA array - (pbr) No ZIL segment values are returned to the remote
+16 ; system (in the ApS Ack).
+17 ; INODA array - 1st subscript file#, 2nd subscript IEN. Not used.
+18 ;
+19 NEW B,INUSER
+20 ; Initialization
+21 DO RTNINIT
+22 ; boolean flag, no ZIL segments returned
SET INOA("~NOZIL")=1
+23 ; validate scrambled,seeded key/ticket from remote system
+24 SET INTICK=$GET(INTICK)
IF '$LENGTH(INTICK)
DO LOGERR("Logon ticket missing")
QUIT
+25 SET B=$PIECE($GET(^INTHPC(INBPN,7)),U,4)
IF '$LENGTH(B)
DO LOGERR("Missing Key Frame")
QUIT
+26 IF $$FRHASH(INTICK,B)'=@INV@("ZIL11")
DO LOGERR("Invalid framed ticket sent by remote system")
QUIT
+27 ; validate remote IP address/port against values received from LoS
+28 IF $GET(INADDR)'=@INV@("ZIL2")
DO LOGERR("Remote IP address does not match IP address validated by CHCS Logon Server")
QUIT
+29 IF $GET(INPORT)'=@INV@("ZIL3")
DO LOGERR("Remote port does not match port validated by CHCS Logon Server")
QUIT
+30 ; validate user
+31 SET INUSER=$$LOGON(.INV,.INOA,.INODA)
KILL INOA("~NOZIL")
IF INUSER'>0
DO LOGERR("Invalid LOGON: "_$PIECE(INUSER,U,2))
QUIT
+32 ; validate remote user against values received from LoS
+33 IF $GET(INDUZ)'=INUSER
DO LOGERR("Remote user does not match user validated by CHCS Logon Server")
QUIT
+34 ;
+35 ; any additional validation would follow here
+36 ;
+37 ; successful logon
DO ACCEPT
DO CLEANUP
DO LGNLOG^INHULOG(INUSER)
+38 QUIT
+39 ;
LOGON(INV,INOA,INODA) ; $$function - Validate user, based on information sent
+1 ; by remote system (INV). Get information to return to remote system
+2 ; (INOA).
+3 ;
+4 ; Input:
+5 ; INV array - (req) ZIL7=requested division, ZIL8=access code,
+6 ; ZIL9=verify code. Note that validating a
+7 ; "requested" division is NOT currently implemented.
+8 ;
+9 ; Output:
+10 ; INOA array - (pbr) ZIL4=user, ZIL5=provider, ZIL6=timeout,
+11 ; ZIL10=ticket/key if LoS logon (not ApS logon).
+12 ; INODA array - (pbr) 1st subscript file#, 2nd subscript IEN.
+13 ;
+14 ; Function returns: USER IEN = successful user validation
+15 ; "0^Error msg" = failure
+16 ;
+17 ; Symbol table Input: - INANYONE 1 - Anyone can access,
+18 ; 0 - Provider access only
+19 ;
+20 NEW INH9,X,Y,Z,INHZERO
+21 DO SETDT^UTDT
+22 ; access & verify code
+23 SET INH9("AC")=$GET(@INV@("ZIL8"))
SET INH9("VC")=$GET(@INV@("ZIL9"))
+24 ; requested divison
+25 SET INH9("REQDIV")=$GET(@INV@("ZIL7"))
+26 ; User's zero node is returned in Z
+27 SET INH9("USER")=$$GETDUZ^INHULOG(INH9("AC"),INH9("VC"),.Z)
+28 ;
+29 IF INH9("USER")'>0
QUIT "0^Invalid Access/Verify code"
+30 ; validate division
SET X=$$DIVCHK^INHULOG(INH9("USER"))
IF 'X
QUIT "0^"_X
+31 ; Determine if user is an authorized HCP
+32 ; get provider
SET INH9("HCP")=$PIECE($GET(^DIC(3,INH9("USER"),8000)),"^")
+33 ;;Folloing logic is specific to CHCS. Must be revised if used for IHS
+34 ;I '$G(INANYONE) S X=$$PWSPRO^ORGISPRO(INH9("USER")) Q:X "0^User '"_INH9("USER")_"' is not an authorized HCP"
+35 ; get remote system timeout value (used to determine if remote has
+36 ; disconnected w/out notifying connected system)
+37 SET INH9("DTIME")=$$DTIME^INHULOG(INH9("USER"),900)
+38 SET INHZERO=$GET(^DIC(3,INH9("USER"),0))
+39 SET INH9("FMACC")=$PIECE(INHZERO,"^",4)
+40 SET INH9("DEFDIV")=$PIECE(INHZERO,"^",16)
+41 SET INH9("MSIGN")=$PIECE($GET(^DIC(3,INH9("USER"),200)),"^",4)
+42 SET INODA(3,INH9("USER"))=""
IF '$GET(INANYONE)
SET INODA(6,INH9("HCP"))=""
+43 ; ZIL segment is returned in LoS Ack (not in ApS Ack)
+44 IF '$GET(INOA("~NOZIL"))
SET INOA("ZIL4")=INH9("USER")
SET INOA("ZIL5")=INH9("HCP")
SET INOA("ZIL6")=INH9("DTIME")
SET INOA("ZIL10")=$$TICKET^INHULOG
SET INOA("ZIL12")=INH9("FMACC")
SET INOA("ZIL13")=INH9("DEFDIV")
SET INOA("ZIL14")=INH9("MSIGN")
+45 ;
+46 ; successful validation
QUIT INH9("USER")
+47 ;
LOGOFF(INV,INOA) ; Lookup/Store call for ApS logoff msg
+1 ; in case of error
SET INOA("INACKTXT")="CHCS Logoff Error"
SET INOA("INSTAT")="AE"
+2 ; note: logic derived from H^XUS, except no device calls are made
+3 SET DUZ=+$GET(DUZ)
NEW A
SET A=$GET(^ZUTL("XQ",$JOB,0))
IF A
IF $DATA(^XUSEC(0,A,0))
LOCK +^XUSEC(0,A,0):1
IF $TEST
DO SETDT^UTDT
SET %=$PIECE($HOROLOG,",",2)
SET $PIECE(^XUSEC(0,A,0),U,4)=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100)
LOCK -^XUSEC(0,A,0)
+4 ; indicates where currently logged on
IF $LENGTH($GET(DUZ))
KILL ^XMB7(DUZ,100,$$DEVID^%ZTOS),^($IO),^($PRINCIPAL)
+5 ; clear scratch storage
DO CLRSTOR^INHULOG
+6 ; the application cleanup (see APPERR^ZU) would go here, if needed
+7 ; Application Accept
DO ACCEPT
+8 QUIT
+9 ;
RTNINIT ; init return values, INOA & INODA array, error message into INOA
+1 KILL INOA,INODA
SET INODA=""
SET INOA("INSTAT")="AE"
SET INOA("INACKTXT")="Invalid CHCS Logon Attempt"
SET INOA("INORIGID")=@INV@("MSH10")
+2 QUIT
+3 ;
ACCEPT ; set "INSTAT" to Application Accept, KILL the error text
+1 KILL INOA("INACKTXT")
SET INOA("INSTAT")="AA"
+2 QUIT
+3 ;
CLEANUP ; Cleanup following "successful" validation of logon message.
+1 ; Input: INUIF=UIF IEN of inbound msg
+2 ; Output: None.
+3 ;
+4 ; Delete information from ZIL segment(s) in inbound msg (security).
+5 LOCK +^INTHU(INUIF,0):0
IF $TEST
Begin DoDot:1
+6 NEW A,B,J
MERGE A=^INTHU(INUIF,3)
SET (B,J)=0
FOR
SET J=$ORDER(A(J))
IF 'J
QUIT
IF $EXTRACT($GET(A(J,0)),1,3)="ZIL"
SET A(J,0)="ZIL^<SEGMENT CLEARED>|CR|"
SET B=1
+7 IF B
KILL ^INTHU(INUIF,3)
MERGE ^INTHU(INUIF,3)=A
+8 LOCK -^INTHU(INUIF,0)
End DoDot:1
+9 QUIT
+10 ;
FRHASH(INTICKET,INFRAME) ; $$function - frame the ticket, encrypt, return
+1 NEW H,L,X
SET L=$LENGTH(INFRAME)
SET H=L+1\2
SET X=$EXTRACT(INFRAME,1,H)_INTICKET_$EXTRACT(INFRAME,H+1,L)
+2 DO ^XUSHSH
QUIT X
+3 ;
NACK ; negative acknowledgement
+1 NEW %
FOR %="ZIL4","ZIL5","ZIL6","ZIL10"
SET INOA(%)=""
+2 QUIT
+3 ;
LOGERR(E) ; log error message E
+1 SET INSTERR=$GET(INSTERR)
DO ERROR^INHS(E,2)
+2 QUIT
+3 ;
