HLCSAS ;ISCSF/RWF - MPI direct connect server ;09/23/2005 14:36
;;1.6;HEALTH LEVEL SEVEN;**43,89,120,169**;Oct 13,1995;Build 2
;Per VA Directive 6402, this routine should not be modified.
Q
;HLCS is used to pass data around.
; 5500 is the standard VA port for the MPI_direct connect
LISTEN ;only for OpenM
S $ETRAP="D ^%ZTER H"
D LISTEN^%ZISTCPS(5500,"ONT^HLCSAS")
Q
DSM ;%=device^HLDP
S IO=$P(%,"^"),HLDP=$P(%,"^",2)
O IO:(SHARE) U IO ;Setup TCP port
S IO(0)="_NLA0:" O IO(0) ;Setup null device
D SVR
Q
CACHE ;%=device^HLDP
S (IO,IO(0))="SYS$NET"
S HLDP=$ZF("GETSYM","HLDP")
O IO U IO:(::"-M") ;Setup TCP port
S IO(0)="_NLA0:" O IO(0) ;Setup null device
D SVR
Q
MSM ;Entry point from MSERVER
;S HLDP=ien
S IO=56,IO(0)=46
O 46 ;Null device
D SVR C IO
Q
ONT ;Cache/OpenM
;S HLDP=ien
S IO=$I,IO(0)="//./nul"
O IO(0)
D SVR
Q
;
LINUX ;RRA HL*169 add entry point for LINUX
S HLDP=$O(^HLCS(870,"B","MPIVA DIR",0))
S IO=$P
O IO U IO:(::"-M")
S IO(0)="/dev/null" O IO(0) ;Setup null device
D SVR
Q
;
SVR ;Entry point when we have a connect
;See that IO=TCP device, and IO(0) is Null device and Open.
;HLDP=ien of Logical Link
N HCSA1,HCSER,HCSEXIT,HCSCMD,HCSDAT
D SETUP Q:HCSER
N $ESTACK,$ETRAP S $ETRAP="D ^%ZTER H"
D UPDT^HLCSTCP(1)
F D CREAD Q:HCSEXIT D Q:HCSEXIT
. I HCSCMD="" S HCSA1("TCNT")=$G(HCSA1("TCNT"))+1 S:$$STOP^HLCSTCP!(HCSA1("TCNT")>10) HCSEXIT=1 Q
. I HCSCMD'?4A D SEND("500 Bad CMD: "_$E(HCSCMD,1,20)) Q
. I $T(@HCSCMD)="" D SEND("500 ") Q
. S HCSA1("TCNT")=0
. D @HCSCMD I $G(HCSER) D TRACE("ERROR: "_HCSER)
. Q
S:HCSEXIT IO("C")=1
D TRACE("Exit"),UPDT^HLCSTCP(0)
Q
HELO ;Process HELO
S HCSA1("SITE")=$P(HCSDAT," ")
;Do any check on who is sending
D SEND("220 "_$$KSP^XUPARAM("WHERE")_" Ready for "_HCSDAT)
Q
;
NOOP ;
D SEND("250 OK")
Q
;
DATA ;Process DATA
; The DATA cmd can pass some parameters as well, this could be passed
; to the processing routine also.
N P,I,DUZ,HLMID,HLTIEN,HLDT
;S DUZ=0,DUZ(0)="@"
D TRACE("Get Data")
S HCSA1("DATA")=HCSDAT,HCSIN=$NA(TMP("HCSI",$J)),HCSOUT=$NA(^TMP("HCSO",$J))
K @HCSOUT
D DATA^HLCSAS1(HCSIN,.HCSA1) QUIT:$G(HCSER)
S P="" F I=1:1 Q:'$D(HCSA1("P"_I)) S P=P_"P"_I_"="_HCSA1("P"_I)_", "
D TRACE("PARAM "_P)
;Use the Null Device
U IO(0)
;Now call soneone to process the data
I HCSA1("P1")="MPI" D ^MPIDIRQ(HCSIN,HCSOUT)
I HCSA1("P1")="PING" M @HCSOUT=@HCSIN
U IO ;Back to the TCP device
D LLCNT^HLCSTCP(HLDP,2)
Q
TURN ;Turn and send responce
D SEND("220 OK")
D SDATA^HLCSAS1(HCSOUT,HCSA1("P1"))
D CREAD,TRACE("Data Sent ") ;Look for 220 ok
Q
QUIT ;Process QUIT
D TRACE("QUIT")
S HCSMSG="",HCSEXIT=1
Q
;
CREAD ;Read a string
N $ETRAP S $ETRAP="S $EC="""" G CREX"
N I S (Y,HCSDAT,HCSCMD)="",HCSER=0
F I=0:1:255 R X#1:HLDREAD S:'$T HCSER=1 Q:X=$C(10)!HCSER S Y=Y_X
S Y=$TR(Y,$C(13,10)),HCSCMD=$P(Y," "),HCSDAT=$P(Y," ",2,99)
D TRACE("Cmd Read "_Y)
Q
CREX S HCSEXIT=1,HCSER="1 Error"
Q
;
SEND(MSG) ;Send a cmd MSG
N $ETRAP S $ETRAP="S $EC="""" D CREX"
D TRACE("Cmd Send "_MSG)
W MSG,$C(13,10),!
Q
;
SETUP ;Setup needed variables
K IO("C")
S X=$$INIT^HLCSTCP
I 'X D ^%ZTER S HCSER=1 Q
S (HCSER,HCSEXIT)=0,HCSTRACE="S: ",HCSA1("P1")="TEXT"
D TRACE(-1),TRACE("Server Setup")
Q
;
TRACE(S1) ;
Q
N H,%
I S1=-1 K ^TMP("HCSA",$J) Q
S H=$P($H,",",2),H=(H\3600)_":"_(H#3600\60)_":"_(H#60)_" "
L +^TMP("HCSA",$J):$G(DILOCKTM,3) S %=$G(^TMP("HCSA",$J,0))+1,^(0)=%,^(%)=H_$G(HCSTRACE)_S1 L -^TMP("HCSA",$J)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSAS 3601 printed Sep 23, 2025@19:32:25 Page 2
HLCSAS ;ISCSF/RWF - MPI direct connect server ;09/23/2005 14:36
+1 ;;1.6;HEALTH LEVEL SEVEN;**43,89,120,169**;Oct 13,1995;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;HLCS is used to pass data around.
+5 ; 5500 is the standard VA port for the MPI_direct connect
LISTEN ;only for OpenM
+1 SET $ETRAP="D ^%ZTER H"
+2 DO LISTEN^%ZISTCPS(5500,"ONT^HLCSAS")
+3 QUIT
DSM ;%=device^HLDP
+1 SET IO=$PIECE(%,"^")
SET HLDP=$PIECE(%,"^",2)
+2 ;Setup TCP port
OPEN IO:(SHARE)
USE IO
+3 ;Setup null device
SET IO(0)="_NLA0:"
OPEN IO(0)
+4 DO SVR
+5 QUIT
CACHE ;%=device^HLDP
+1 SET (IO,IO(0))="SYS$NET"
+2 SET HLDP=$ZF("GETSYM","HLDP")
+3 ;Setup TCP port
OPEN IO
USE IO:(::"-M")
+4 ;Setup null device
SET IO(0)="_NLA0:"
OPEN IO(0)
+5 DO SVR
+6 QUIT
MSM ;Entry point from MSERVER
+1 ;S HLDP=ien
+2 SET IO=56
SET IO(0)=46
+3 ;Null device
OPEN 46
+4 DO SVR
CLOSE IO
+5 QUIT
ONT ;Cache/OpenM
+1 ;S HLDP=ien
+2 SET IO=$IO
SET IO(0)="//./nul"
+3 OPEN IO(0)
+4 DO SVR
+5 QUIT
+6 ;
LINUX ;RRA HL*169 add entry point for LINUX
+1 SET HLDP=$ORDER(^HLCS(870,"B","MPIVA DIR",0))
+2 SET IO=$PRINCIPAL
+3 OPEN IO
USE IO:(::"-M")
+4 ;Setup null device
SET IO(0)="/dev/null"
OPEN IO(0)
+5 DO SVR
+6 QUIT
+7 ;
SVR ;Entry point when we have a connect
+1 ;See that IO=TCP device, and IO(0) is Null device and Open.
+2 ;HLDP=ien of Logical Link
+3 NEW HCSA1,HCSER,HCSEXIT,HCSCMD,HCSDAT
+4 DO SETUP
if HCSER
QUIT
+5 NEW $ESTACK,$ETRAP
SET $ETRAP="D ^%ZTER H"
+6 DO UPDT^HLCSTCP(1)
+7 FOR
DO CREAD
if HCSEXIT
QUIT
Begin DoDot:1
+8 IF HCSCMD=""
SET HCSA1("TCNT")=$GET(HCSA1("TCNT"))+1
if $$STOP^HLCSTCP!(HCSA1("TCNT")>10)
SET HCSEXIT=1
QUIT
+9 IF HCSCMD'?4A
DO SEND("500 Bad CMD: "_$EXTRACT(HCSCMD,1,20))
QUIT
+10 IF $TEXT(@HCSCMD)=""
DO SEND("500 ")
QUIT
+11 SET HCSA1("TCNT")=0
+12 DO @HCSCMD
IF $GET(HCSER)
DO TRACE("ERROR: "_HCSER)
+13 QUIT
End DoDot:1
if HCSEXIT
QUIT
+14 if HCSEXIT
SET IO("C")=1
+15 DO TRACE("Exit")
DO UPDT^HLCSTCP(0)
+16 QUIT
HELO ;Process HELO
+1 SET HCSA1("SITE")=$PIECE(HCSDAT," ")
+2 ;Do any check on who is sending
+3 DO SEND("220 "_$$KSP^XUPARAM("WHERE")_" Ready for "_HCSDAT)
+4 QUIT
+5 ;
NOOP ;
+1 DO SEND("250 OK")
+2 QUIT
+3 ;
DATA ;Process DATA
+1 ; The DATA cmd can pass some parameters as well, this could be passed
+2 ; to the processing routine also.
+3 NEW P,I,DUZ,HLMID,HLTIEN,HLDT
+4 ;S DUZ=0,DUZ(0)="@"
+5 DO TRACE("Get Data")
+6 SET HCSA1("DATA")=HCSDAT
SET HCSIN=$NAME(TMP("HCSI",$JOB))
SET HCSOUT=$NAME(^TMP("HCSO",$JOB))
+7 KILL @HCSOUT
+8 DO DATA^HLCSAS1(HCSIN,.HCSA1)
if $GET(HCSER)
QUIT
+9 SET P=""
FOR I=1:1
if '$DATA(HCSA1("P"_I))
QUIT
SET P=P_"P"_I_"="_HCSA1("P"_I)_", "
+10 DO TRACE("PARAM "_P)
+11 ;Use the Null Device
+12 USE IO(0)
+13 ;Now call soneone to process the data
+14 IF HCSA1("P1")="MPI"
DO ^MPIDIRQ(HCSIN,HCSOUT)
+15 IF HCSA1("P1")="PING"
MERGE @HCSOUT=@HCSIN
+16 ;Back to the TCP device
USE IO
+17 DO LLCNT^HLCSTCP(HLDP,2)
+18 QUIT
TURN ;Turn and send responce
+1 DO SEND("220 OK")
+2 DO SDATA^HLCSAS1(HCSOUT,HCSA1("P1"))
+3 ;Look for 220 ok
DO CREAD
DO TRACE("Data Sent ")
+4 QUIT
QUIT ;Process QUIT
+1 DO TRACE("QUIT")
+2 SET HCSMSG=""
SET HCSEXIT=1
+3 QUIT
+4 ;
CREAD ;Read a string
+1 NEW $ETRAP
SET $ETRAP="S $EC="""" G CREX"
+2 NEW I
SET (Y,HCSDAT,HCSCMD)=""
SET HCSER=0
+3 FOR I=0:1:255
READ X#1:HLDREAD
if '$TEST
SET HCSER=1
if X=$CHAR(10)!HCSER
QUIT
SET Y=Y_X
+4 SET Y=$TRANSLATE(Y,$CHAR(13,10))
SET HCSCMD=$PIECE(Y," ")
SET HCSDAT=$PIECE(Y," ",2,99)
+5 DO TRACE("Cmd Read "_Y)
+6 QUIT
CREX SET HCSEXIT=1
SET HCSER="1 Error"
+1 QUIT
+2 ;
SEND(MSG) ;Send a cmd MSG
+1 NEW $ETRAP
SET $ETRAP="S $EC="""" D CREX"
+2 DO TRACE("Cmd Send "_MSG)
+3 WRITE MSG,$CHAR(13,10),!
+4 QUIT
+5 ;
SETUP ;Setup needed variables
+1 KILL IO("C")
+2 SET X=$$INIT^HLCSTCP
+3 IF 'X
DO ^%ZTER
SET HCSER=1
QUIT
+4 SET (HCSER,HCSEXIT)=0
SET HCSTRACE="S: "
SET HCSA1("P1")="TEXT"
+5 DO TRACE(-1)
DO TRACE("Server Setup")
+6 QUIT
+7 ;
TRACE(S1) ;
+1 QUIT
+2 NEW H,%
+3 IF S1=-1
KILL ^TMP("HCSA",$JOB)
QUIT
+4 SET H=$PIECE($HOROLOG,",",2)
SET H=(H\3600)_":"_(H#3600\60)_":"_(H#60)_" "
+5 LOCK +^TMP("HCSA",$JOB):$GET(DILOCKTM,3)
SET %=$GET(^TMP("HCSA",$JOB,0))+1
SET ^(0)=%
SET ^(%)=H_$GET(HCSTRACE)_S1
LOCK -^TMP("HCSA",$JOB)
+6 QUIT
+7 ;
