Changeset 636 for FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m (modified) (9 diffs)

FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m

@@ -1 @@
-HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/19/2007  10:21
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122**;Oct 13, 1995;Build 14
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ; 
  ; This is an implementation of the HL7 Minimal Lower Layer Protocol
- ; taskman entry/startup option, HLDP defined in menu entry.
- ;
+ ;
+ ;taskman entry/startup option, HLDP defined in menu entry,
  Q:'$D(HLDP)
- ; patch HL*1.6*122 start
- L +^HLCS("HLTCPLINK",HLDP):5 I '$T D  Q
- . D MON^HLCSTCP("TskLcked")
- N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
- N HLZRULE
+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
  ;HLCSOUT= 1-error
  I '$$INIT D EXITS("Init Error") Q
- S HLDP("$J")=$J
- S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
  ; Start the client
  I $G(HLTCPCS)="C" D  Q
- . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
- . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  . ; identify process for ^%SY
- . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
- . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
- . K HLDP("$J",0)
+ . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
  . D ST1
  . F  D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
- . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
- . I $G(HLCSOUT)=1 D  Q
- .. D MON("Error") H 1
- .. L -^HLCS("HLTCPLINK",HLDP)
+ . I $G(HLCSOUT)=1 D MON("Error") H 1 Q
  . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
  . D EXITS("Shutdown")
  ;
- S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
- I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  ; identify process for ^%SY
- ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
- D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
- K HLDP("$J",0)
- ; to stop the listener via updated Kernel API, need to pass the
- ; listener logical link (HLDP)
- S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+ ;HLCSFAIL=1 port failed to open
+ S HLCSFAIL=1
  ;single threaded listener
  I $G(HLTCPCS)="S" D  Q
- . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
- . I $$STOP D EXITS("Shutdown") Q
- . D EXITS("Openfail")
- ;
- ;multi-threaded listener (for OpenM/NT)
- I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D  Q
- . L -^HLCS("HLTCPLINK",HLDP)
- I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
- D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
- ; update status of listener
- I $$STOP D EXITS("Shutdown") Q
- D EXITS("Openfail")
- ; HL*1.6*122 end
+ . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")")
+ . ;couldn't open listener port
+ . I HLCSFAIL D EXITS("Openfail") Q
+ ;
+ ;multi-threaded listener (OpenM)
+ I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D  Q
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
  Q
  ;
 SERVER(HLDP) ; single server using Taskman
+ S HLCSFAIL=0
  I '$$INIT D EXITS("Init error") Q
  D ^HLCSTCP1
@@ -80 +55 @@
  G LISTEN
  ;
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",HLDP=%
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **Cache'/VMS specific code**
+ O IO::5 E  D MON("Openfail") Q
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+ D LISTEN C IO Q
+ ;
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = device^HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **VMS specific code, need to share device**
+ O IO:(TCPDEV):60 E  D MON("Openfail") Q
 LISTEN ;
- N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
  I '$$INIT D ^%ZTER Q
- ; patch HL*1.6*122 start
- S HLDP("$J")=$J
- S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
- S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
- I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  ; identify process for ^%SY
- ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
- D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
- K HLDP("$J",0)
- ; patch HL*1.6*122 end
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
  ;HLLSTN used to identify a listener to tag MON
  S HLLSTN=1
@@ -110 +93 @@
  S HLOS=$P($G(^%ZOSF("OS")),"^")
  N DA,DIQUIET,DR,TMP,X,Y
- S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
  S DIQUIET=1
  D DT^DICRW
  I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
  S DA=HLDP
- ; patch HL*1.6*122 for field 400.09
- 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"
+ 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"
  D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
  ;
@@ -144 +125 @@
  S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
  ;
- ; patch HL*1.6*122 for field 400.09
- ; -- tcp/ip openfail timeout
- S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
- ;
  ; -- set defaults in case something's not set
  S:HLDREAD=0 HLDREAD=10
  S:HLDBACK=0 HLDBACK=60
- ; patch HL*1.6*122
- ; S:HLDBSIZE=0 HLDBSIZE=245
- S:HLDBSIZE<245 HLDBSIZE=245
+ S:HLDBSIZE=0 HLDBSIZE=245
  S:HLDRETR=0 HLDRETR=5
  S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
- ;
- ; patch HL*1.6*122 for field 400.09
- S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
  ;
  Q 1
@@ -166 +138 @@
  ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
  N HLJ,X
- ; HL*1.6*122 remove unnecessary locks
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  S X="HLJ(870,"""_HLDP_","")"
  S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
@@ -175 +146 @@
  S:$G(ZTSK) @X@(11)=ZTSK
  D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
- ;L -^HLCS(870,HLDP,0)
+ L -^HLCS(870,HLDP,0)
  Q
  ;
@@ -181 +152 @@
  ;don't display for multiple server
  Q:$G(HLLSTN)
- ; HL*1.6*122 remove unnecessary locks
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  S $P(^HLCS(870,HLDP,0),U,5)=Y
- ;L -^HLCS(870,HLDP,0)
+ L -^HLCS(870,HLDP,0)
  Q:'$D(HLTRACE)
  N X U IO(0)
  W !,"IN State: ",Y
  I '$$STOP D
- . ; patch HL*1.6*122
- . ; R !,"Type Q to Quit: ",X#1:1
- . R !,"Type Q to Quit: ",X:1
- . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
- . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
- . ; patch HL*1.6*122 end
+ . R !,"Type Q to Quit: ",X#1:1
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
  U IO
  Q
 UPDT(Y) ;update job count for multiple servers,X=1 increment
  N HLJ,X
- ;
- ; HL*1.6*122 start
- ; F  L +^HLCS(870,HLDP,0):2 Q:$T
- Q:'$G(HLDP)
- Q:'$D(^HLCS(870,"E","M",HLDP))
- F  L +^HLCS(870,HLDP,0):10 Q:$T  H 1
- ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
- S X=+$P(^HLCS(870,HLDP,0),U,5)
- I X<0 S X=0
- S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
  ;if incrementing, set the Device Type field to Multi-Server
- ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
- I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
- ; HL*1.6*122 end
- ;
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
  L -^HLCS(870,HLDP,0)
  Q
@@ -230 +185 @@
  N P,X
  S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
- ; patch HL*1.6*122 start
- ; F  L +^HLCS(870,DP,P):2 Q:$T
- ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
- I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
- I OS'["DSM",OS'["OpenM" D
- . F  L +^HLCS(870,DP,P):10 Q:$T  H 1
- . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
- . L -^HLCS(870,DP,P)
- E  D
- . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
- ; L -^HLCS(870,DP,P)
- ; patch HL*1.6*122 end
+ F  L +^HLCS(870,DP,P):2 Q:$T
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+ L -^HLCS(870,DP,P)
  Q
 SDFLD ; set Shutdown? field to yes
  Q:'$G(HLDP)
- ; HL*1.6*122 remove unnecessary lock and call to FM
- S $P(^HLCS(870,HLDP,0),U,15)=1
- ;N HLJ,X
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  ;14=Shutdown LLP?
- ;S HLJ(870,HLDP_",",14)=1
- ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
- ;L -^HLCS(870,HLDP,0)
- Q
- ;
-EXITS(Y) ; shutdown and clean up the listener process for either
- ; single-threaded or multi-threaded
+ S HLJ(870,HLDP_",",14)=1
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ Q
+ ;
+EXITS(Y) ; Single service shutdown and cleans up
  N HLJ,X
  F  L +^HLCS(870,HLDP,0):2 Q:$T
@@ -266 +209 @@
  L -^HLCS(870,HLDP,0)
  I $D(ZTQUEUED) S ZTREQ="@"
- ; HL*1.6*122
- L -^HLCS("HLTCPLINK",HLDP)
  Q
  ;
 EXITM ;Multiple service shutdown and clean up
- ; shutdown and clean up a connection spawned by the listener
- ; process for a multi-threaded listener
  D UPDT(0)
  I $D(ZTQUEUED) S ZTREQ="@"