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

HLCSTCP.m

Go to the documentation of this file.
  1. HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;08/08/2011 14:29
  1. ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140,157**;Oct 13, 1995;Build 8
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; This is an implementation of the HL7 Minimal Lower Layer Protocol
  1. ; taskman entry/startup option, HLDP defined in menu entry.
  1. ;
  1. Q:'$D(HLDP)
  1. ; patch HL*1.6*122 start
  1. L +^HLCS("HLTCPLINK",HLDP):5 I '$T D Q
  1. . D MON^HLCSTCP("TskLcked")
  1. N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
  1. N HLZRULE
  1. ;HLCSOUT= 1-error
  1. I '$$INIT D EXITS("Init Error") Q
  1. S HLDP("$J")=$J
  1. S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
  1. ; Start the client
  1. I $G(HLTCPCS)="C" D Q
  1. . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
  1. . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
  1. . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  1. . ; identify process for ^%SY
  1. . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
  1. . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
  1. . K HLDP("$J",0)
  1. . D ST1
  1. . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
  1. . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
  1. . I $G(HLCSOUT)=1 D Q
  1. .. D MON("Error") H 1
  1. .. L -^HLCS("HLTCPLINK",HLDP)
  1. . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
  1. . D EXITS("Shutdown")
  1. ;
  1. S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
  1. I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
  1. S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  1. ; identify process for ^%SY
  1. ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
  1. D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
  1. K HLDP("$J",0)
  1. ; to stop the listener via updated Kernel API, need to pass the
  1. ; listener logical link (HLDP)
  1. S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
  1. ;single threaded listener
  1. I $G(HLTCPCS)="S" D Q
  1. . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
  1. . I $$STOP D EXITS("Shutdown") Q
  1. . D EXITS("Openfail")
  1. ;
  1. ; multi-threaded listener code (for OpenM/NT)
  1. I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D Q
  1. . L -^HLCS("HLTCPLINK",HLDP)
  1. ; patch HL*1.6*157
  1. ; I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
  1. I ($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX") L -^HLCS("HLTCPLINK",HLDP) Q
  1. D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
  1. ; update status of listener
  1. I $$STOP D EXITS("Shutdown") Q
  1. D EXITS("Openfail")
  1. ; HL*1.6*122 end
  1. Q
  1. ;
  1. SERVER(HLDP) ; single server using Taskman
  1. I '$$INIT D EXITS("Init error") Q
  1. D ^HLCSTCP1
  1. I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
  1. Q:$G(HLCSOUT)=1
  1. D MON("Idle")
  1. Q
  1. ;
  1. SERVERS(HLDP) ; Multi-threaded server using Taskman
  1. I '$$INIT D EXITS("Init error") Q
  1. G LISTEN
  1. ;
  1. ;multiple process servers, called from an external utility
  1. MSM ;MSM entry point, called from User-Defined Services
  1. ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
  1. ;HL7 Multi-Threaded SERVER
  1. S (IO,IO(0))=$P
  1. G LISTEN
  1. ;
  1. LISTEN ;
  1. N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
  1. I '$$INIT D ^%ZTER Q
  1. ; patch HL*1.6*122 start
  1. S HLDP("$J")=$J
  1. S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
  1. S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
  1. I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
  1. S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  1. ; identify process for ^%SY
  1. ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
  1. D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
  1. K HLDP("$J",0)
  1. ; patch HL*1.6*122 end
  1. ;HLLSTN used to identify a listener to tag MON
  1. S HLLSTN=1
  1. ;increment job count, run server
  1. D UPDT(1),^HLCSTCP1,EXITM
  1. Q
  1. ;
  1. DCOPEN(HLDP) ;open direct connect - called from HLMA2
  1. Q:'$$INIT 0
  1. Q:HLTCPADD=""!(HLTCPORT="") 0
  1. Q:'$$OPEN^HLCSTCP2 0
  1. Q 1
  1. ;
  1. INIT() ; Initialize Variables
  1. ; HLDP should be set to the IEN or name of Logical Link, file 870
  1. ; patch HL*1.6*157
  1. ; S HLOS=$P($G(^%ZOSF("OS")),"^")
  1. S HLOS=$$OS^%ZOSV
  1. N DA,DIQUIET,DR,TMP,X,Y
  1. ; patch HL*1.6*140
  1. ; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
  1. S HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP
  1. S DIQUIET=1
  1. D DT^DICRW
  1. I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
  1. S DA=HLDP
  1. ; patch HL*1.6*122 for field 400.09
  1. S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
  1. D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
  1. ;
  1. I $D(TMP("DIERR")) QUIT 0
  1. ; -- re-transmit attempts
  1. S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
  1. S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I"))
  1. ; -- exceed re-transmit action
  1. S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
  1. ; -- block size
  1. S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
  1. ; -- read timeout
  1. S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
  1. ; -- ack timeout
  1. S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
  1. ; -- uni-directional wait
  1. S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
  1. ; -- tcp address
  1. S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
  1. ; -- tcp port
  1. S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
  1. ; -- tcp/ip service type
  1. S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
  1. ; -- link persistence
  1. S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
  1. ; -- retention
  1. S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
  1. ;
  1. ; patch HL*1.6*140
  1. ; patch HL*1.6*122 for field 400.09
  1. ; -- tcp/ip openfail timeout
  1. ; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
  1. S HLTCPLNK("TIMEOUT")=+$G(TMP(870,DA_",",400.09,"I"))
  1. ;
  1. ; -- set defaults in case something's not set
  1. S:HLDREAD=0 HLDREAD=10
  1. S:HLDBACK=0 HLDBACK=60
  1. ; patch HL*1.6*122
  1. ; S:HLDBSIZE=0 HLDBSIZE=245
  1. S:HLDBSIZE<245 HLDBSIZE=245
  1. S:HLDRETR=0 HLDRETR=5
  1. S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
  1. ;
  1. ; patch HL*1.6*140, the defaut is 30
  1. ; patch HL*1.6*122 for field 400.09
  1. ; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
  1. S:(HLTCPLNK("TIMEOUT")<1) HLTCPLNK("TIMEOUT")=30
  1. ;
  1. Q 1
  1. ;
  1. ST1 ;record startup in 870 for single server
  1. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
  1. ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
  1. N HLJ,X
  1. ; HL*1.6*122 remove unnecessary locks
  1. ;F L +^HLCS(870,HLDP,0):2 Q:$T
  1. S X="HLJ(870,"""_HLDP_","")"
  1. S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
  1. I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
  1. E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
  1. I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
  1. S:$G(ZTSK) @X@(11)=ZTSK
  1. D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
  1. ;L -^HLCS(870,HLDP,0)
  1. Q
  1. ;
  1. MON(Y) ;Display current state & check for shutdown
  1. ;don't display for multiple server
  1. Q:$G(HLLSTN)
  1. ; HL*1.6*122 remove unnecessary locks
  1. ;F L +^HLCS(870,HLDP,0):2 Q:$T
  1. S $P(^HLCS(870,HLDP,0),U,5)=Y
  1. ;L -^HLCS(870,HLDP,0)
  1. Q:'$D(HLTRACE)
  1. N X U IO(0)
  1. W !,"IN State: ",Y
  1. I '$$STOP D
  1. . ; patch HL*1.6*122
  1. . ; R !,"Type Q to Quit: ",X#1:1
  1. . R !,"Type Q to Quit: ",X:1
  1. . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
  1. . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
  1. . ; patch HL*1.6*122 end
  1. U IO
  1. Q
  1. UPDT(Y) ;update job count for multiple servers,X=1 increment
  1. N HLJ,X
  1. ;
  1. ; HL*1.6*122 start
  1. ; F L +^HLCS(870,HLDP,0):2 Q:$T
  1. Q:'$G(HLDP)
  1. Q:'$D(^HLCS(870,"E","M",HLDP))
  1. F L +^HLCS(870,HLDP,0):10 Q:$T H 1
  1. ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
  1. S X=+$P(^HLCS(870,HLDP,0),U,5)
  1. I X<0 S X=0
  1. S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
  1. ;if incrementing, set the Device Type field to Multi-Server
  1. ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
  1. I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
  1. ; HL*1.6*122 end
  1. ;
  1. L -^HLCS(870,HLDP,0)
  1. Q
  1. STOP() ;stop flag set
  1. N X
  1. F L +^HLCS(870,HLDP,0):2 Q:$T
  1. S X=+$P(^HLCS(870,HLDP,0),U,15)
  1. L -^HLCS(870,HLDP,0)
  1. Q X
  1. ;
  1. LLCNT(DP,Y,Z) ;update Logical Link counters
  1. ;DP=ien of Logical Link in file 870
  1. ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
  1. ;Z: ""=add to counter, 1=subtract from counter
  1. Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
  1. N P,X
  1. S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
  1. ; patch HL*1.6*122 start
  1. ; F L +^HLCS(870,DP,P):2 Q:$T
  1. ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
  1. ; patch HL*1.6*157 start
  1. ; adds call $$OS^%ZOSV
  1. I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
  1. I '$L($G(HLOSYS)) N HLOSYS S HLOSYS=$$OS^%ZOSV
  1. ; I OS'["DSM",OS'["OpenM" D
  1. I OS'["DSM",OS'["OpenM",(OS["OpenM")&((HLOSYS'["VMS")&(HLOSYS'["UNIX")) D
  1. . ; patch HL*1.6*157 end
  1. . F L +^HLCS(870,DP,P):10 Q:$T H 1
  1. . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
  1. . L -^HLCS(870,DP,P)
  1. E D
  1. . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
  1. ; L -^HLCS(870,DP,P)
  1. ; patch HL*1.6*122 end
  1. Q
  1. SDFLD ; set Shutdown? field to yes
  1. Q:'$G(HLDP)
  1. ; HL*1.6*122 remove unnecessary lock and call to FM
  1. S $P(^HLCS(870,HLDP,0),U,15)=1
  1. ;N HLJ,X
  1. ;F L +^HLCS(870,HLDP,0):2 Q:$T
  1. ;14=Shutdown LLP?
  1. ;S HLJ(870,HLDP_",",14)=1
  1. ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
  1. ;L -^HLCS(870,HLDP,0)
  1. Q
  1. ;
  1. EXITS(Y) ; shutdown and clean up the listener process for either
  1. ; single-threaded or multi-threaded
  1. N HLJ,X
  1. F L +^HLCS(870,HLDP,0):2 Q:$T
  1. ;4=status,10=Time Stopped,9=Time Started,11=Task Number
  1. S X="HLJ(870,"""_HLDP_","")"
  1. S @X@(4)=Y,@X@(11)="@"
  1. S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
  1. D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
  1. L -^HLCS(870,HLDP,0)
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. ; HL*1.6*122
  1. L -^HLCS("HLTCPLINK",HLDP)
  1. Q
  1. ;
  1. EXITM ;Multiple service shutdown and clean up
  1. ; shutdown and clean up a connection spawned by the listener
  1. ; process for a multi-threaded listener
  1. D UPDT(0)
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q