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

INHVCRV.m

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