Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/04/2007  14:34
- ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132,122**;Oct 13, 1995;Build 14
+HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -48,14 +48,5 @@
  .N I,EXCLUDE
  .S (EXCLUDE,I)=0
- . ;
- . ; patch HL*1.6*122
- . ; F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
- . F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  D  Q:EXCLUDE
- .. N TEMP
- .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
- .. I TEMP=HLEIDS S EXCLUDE=1
- . ; patch HL*1.6*122
- . ;
+ .F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
  .Q:EXCLUDE
  .;** 132 end **
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCS2 ;SF/JC - More Communication Server utilities ; 10/04/2007  14:31
- ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/2003  17:50
+ ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109**;Oct 13, 1995
 FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array
  ;This enhancement also supports distribution of a message to
@@ -10,22 +9,8 @@
  . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2)
  . Q:PTR=""  I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1
- . ;
- . ; patch HL*1.6*122: excluding subscribers defined in
- . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber
- . N I,EXCLUDE
- . S (EXCLUDE,I)=0
- . F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  D  Q:EXCLUDE
- .. N TEMP
- .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
- .. I TEMP=PTR S EXCLUDE=1
- . Q:EXCLUDE
- . ; 
  . Q:LNK=""  I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1
  . Q:'$D(^HLCS(870,LNK))
  . S CLIAP=$$PTR^HLUTIL2(PTR)
- . ; patch HL*1.6*122: add the 3rd component as receiving facility
- . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
- . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3))
+ . S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
  Q
 ADD ;Deliver message to supplemental client list.
@@ -39,13 +24,5 @@
  ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
  ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q
- .. ; patch HL*1.6*122 start
- .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
- .. S HLOGLINK=ZLOGLINK
- .. ; 3rd component for receiving facility
- .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3)
- .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK)
- .. D STATUS^HLTF0(+ZMTIENS,1)
- .. ; patch HL*1.6*122 end
- .. ;
+ ..S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
  K HLL("LINKS"),HLSUP
  Q
@@ -95,22 +72,17 @@
  . I 'ALL&('$P(HLDP0,U,6)) Q
  . S HLPARM4=$G(^HLCS(870,HLDP,400))
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
+ . ;TCP Multi listener for non-Cache uses UCX
  . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
- . ;
  . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
- . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
- . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting"
+ . S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
  . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown"
  . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109
+ . ;Cache system, need to open TCP port to release job
  . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
- .. ; pass task number to stop listener
+ .. ;pass task number to stop listener
  .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12))
- ; patch HL*1.6*122 start
- ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- ; .. I POP D HOME^%ZIS Q
- ; .. D CLOSE^%ZISTCP
- ; patch HL*1.6*122 end
+ .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ .. I POP D HOME^%ZIS Q
+ .. D CLOSE^%ZISTCP
  Q
 STRT ;Start Links
@@ -126,9 +98,6 @@
  . Q:'HLTYPTR!(HLBGR="")
  . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
+ . ;TCP Multi listener for non-Cache uses UCX
  . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
- . ;
  . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  Q
  .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m	(revision 636)
@@ -1,4 +1,4 @@
 HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007
- ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
+ ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 4;WorldVistA 30-Jan-08
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -7,4 +7,21 @@
  ;    number.
  ; 2. find the ien of #870(logical link file) for the multi-listener
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
+HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
 HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment
@@ -147,11 +147,4 @@
  S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
  S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
- ;
- ; patch HL*1.6*122
- ; setting the MSH-15 and MSH-16 from subscriber protocol
- I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
- . S ACCACK=$P(PROTS,U,7)
- . S APPACK=$P(PROTS,U,8)
- ;
 PID ;Processing ID
  ;I PID not 'debug' get from site params
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05
- ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified
+HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;3/24/2004 14:27
+ ;;1.6;HEALTH LEVEL SEVEN;**93,108**;Oct 13, 1995
  ;
 DEBUG(STORE) ; If HLP set up for debugging, capture VIEW...
@@ -112,7 +111,4 @@
  ; Change was made, but not by M code.  Must be by array...
  S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A"
- ;
- ; patch HL*1.6*122: for "^" as component separater
- S $P(HLMSH91,U,PCE+2,999)=""
  ;
  ; Upgrade ^HLMA(#,0)...
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m	(revision 636)
@@ -1,23 +1,13 @@
-HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;10/17/2007  14:58
- ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;11/15/2000  09:37
+ ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oct 13, 1995
 STARTIN ;Main entry point for incoming background filer
  ;Create/find entry denoting this filer in the INCOMING FILER TASK
  ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER
  ; file (#869.3)
+ ;N HLOGLINK,HLNODE,HLPARENT,HLST1,TMP ; These vbls aren't used!
  N HLFLG,HLEXIT,HLPTRFLR
- ;
- ; patch HL*1.6*122
- ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
- N HLDUZ
- S HLDUZ=+$G(DUZ)
- ;
  S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN")
  ;Loop through Logical Links and check for incoming messages
  S HLEXIT=0
- ; patch HL*1.6*122 TEST v2: DUZ code removed
- ; patch HL*1.6*122, set DUZ for application proxy user
- ;; D PROXY^HLCSTCP4
- S HLPTRFLR("$J")=$J
  F  D  Q:HLEXIT
  . S HLFLG=0
@@ -28,7 +18,5 @@
  . . S HLPTRFLR("LASTDEL")=$H    ; maintain queue sizes
  . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour.
- . ; patch HL*1.6*122
- . ; H 5
- . H 1
+ . H 5
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
  S ZTSTOP=1 ;Asked to stop
@@ -40,10 +28,7 @@
  S HLXX=0
  F  S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX  D  Q:HLEXIT
- . ; HL*1.6*122, check the in-queue stop flag
- . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; patch HL*1.6*109: Does another filer have this?
- . ; L +^HLMA("AC","I",HLXX):0 Q:'$T
- . L +^HLMA("AC","I",HLXX):2 Q:'$T  ; patch HL*1.6*122
+ . ; HL*1.6*109
+ . L +^HLMA("AC","I",HLXX):0 Q:'$T  ;*109*Does another filer have this?
  . S HLD0=0,HLFLG=1
  . ; HL*1.6*109 changes in for loop below, and post-quit code placed
@@ -53,20 +38,11 @@
  . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q
  . F  S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT)  D
- .. ; patch HL*1.6*122 start
- .. ; patch HL*1.6*122 TEST v2: DUZ code removed
- .. ; DUZ comparison/reset for application proxy user
- .. ;; D HLDUZ^HLCSTCP4
- .. D HLDUZ2^HLCSTCP4
- .. ; protect HLDUZ
- .. N HLDUZ
- .. S HLPCT=HLPCT+1
- .. I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- .. ; L +^HLMA(HLD0):0 Q:'$T
- .. F  L +^HLMA(HLD0):30 Q:$T  H 1
- .. I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
- .. D DEFACK^HLTP3(HLXX,HLD0)
- .. D DEQUE^HLCSREP(HLXX,"I",HLD0)
- .. L -^HLMA(HLD0)
- . ; patch HL*1.6*122 end
+ . . S HLPCT=HLPCT+1
+ . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ . . L +^HLMA(HLD0):0 Q:'$T
+ . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
+ . . D DEFACK^HLTP3(HLXX,HLD0)
+ . . D DEQUE^HLCSREP(HLXX,"I",HLD0)
+ . . L -^HLMA(HLD0)
  . ;**109 -add dt/tm stamp to time queue last processed
  . S ^XTMP("HL7-AC","I",HLXX)=$H
@@ -89,37 +65,16 @@
  S HLXX=0
  F  S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX  D  Q:HLEXIT
- . ; HL*1.6*122, check the in-queue stop flag
- . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; HL*1.6*109: Does another filer have this?
- . ; L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T
- . L +^HLCS(870,HLXX,"INFILER"):2 Q:'$T  ; patch HL*1.6*122
+ .; HL*1.6*109
+ . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T  ;Does another filer have this?
  . F  D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT  S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0  D
- .. ;
- .. ; patch HL*1.6*122 start
- .. ; clean variables except Kernel related variables
- .. D
- ... ; protect variables defined in STARTIN^HLCSIN
- ... N HLFLG,HLEXIT,HLPTRFLR
- ... N HLDUZ
- ... ; protect variables defined in ACKNOW^HLCSIN
- ... N HLXX,HLD0,HLD1
- ... D KILL^XUSCLEAN
- .. ;
- .. ; patch HL*1.6*122 TEST v2: DUZ code removed
- .. ; DUZ comparison/reset for application proxy user
- .. ;; D HLDUZ^HLCSTCP4
- .. D HLDUZ2^HLCSTCP4
- .. ; protect HLDUZ
- .. N HLDUZ
- .. ;Make sure message is ready to be received
- .. S HLFLG=1
- .. S HLD1=$P(HLD0,"^",2)
- .. S HLD0=+HLD0 ; At this point, HLD0=HLXX
- .. I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
- ... D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
- .. D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
- .. D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
- . ; patch HL*1.6*122 end
+ . . ;Make sure message is ready to be received
+ . . S HLFLG=1
+ . . S HLD1=$P(HLD0,"^",2)
+ . . S HLD0=+HLD0 ; At this point, HLD0=HLXX
+ . . I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
+ . . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+ . . D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
+ . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
  . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D
  . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around.
@@ -134,9 +89,7 @@
  F  S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX  D  Q:HLEXIT
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; patch HL*1.6*122, comment out, no need to lock
- . ; L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
+ . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
  . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
- . ; patch HL*1.6*122, comment out
- . ; L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+ . L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
  . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT)
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;07/26/2007  17:10
- ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2003  17:37
+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**;Oct 13, 1995
  ;
  ;This program is callable from a menu
@@ -24,11 +23,9 @@
  W !,"appropriate device.  Please select the node with which you want"
  W !,"to communicate",!
- ; patch HL*1.6*122
- S POP=0
  S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
  S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
  ;-- check if parameter have been setup
  ;-- check for LLP type
- I 'HLTYPTR W !!,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
  ;-- get TCP information
  S HLPARM4=$G(^HLCS(870,HLDP,400))
@@ -38,40 +35,23 @@
  S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
  ;
- I HLBGR="" W !!,$C(7),"No routine has been specified for this LLP." G STARTQ
+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
  ;
  ;-- execute environment check routine if HLQUIT is defined then terminate
  I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
- ; patch HL*1.6*122 start
- ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
- ; by the external service
+ ;Multi-Servers, only enable the link if not OpenM
  I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  G STARTQ
  . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
  . Q
- ; patch HL*1.6*122 end
  ;
  I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
  I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
- ; patch HL*1.6*122 start
- ; comment out-should be taken care of by the code 2 line above
- ; I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
- ; I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
- ; . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
- N HLTEMP
- S HLTEMP=0
- I $P(HLPARM0,U,12) D  G:HLTEMP STARTQ
- . N ZTSK
- . S ZTSK=$P(HLPARM0,U,12)
- . D STAT^%ZTLOAD
- . I "12"[ZTSK(1) D
- .. W !,$C(7),"NOTE: The lower level protocol for this application is already running."
- .. I '$P(^HLCS(870,HLDP,0),"^",10) S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- .. S HLTEMP=1
- ; patch HL*1.6*122 end
+ I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
  I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
- .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
  .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
  .N HLJ,X
- . ; patch HL*1.6*122-comment out
- . ; I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
  .L +^HLCS(870,HLDP,0):2
  .E  W !,$C(7),"Unable to enable this LLP !" Q
@@ -84,10 +64,4 @@
  I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
  ;
- ; patch HL*1.6*122 start, for tcp link
- I HLTYPTR=4 D  Q
- . S Y="B"
- . D STARTJOB
- ; patch HL*1.6*122 end
- ;
  W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
  S DIR("A")="Method for running the receiver"
@@ -99,10 +73,7 @@
  Q:(Y=U)!(Y="Q")
  ;
-STARTJOB ;
  S HLX=$G(^HLCS(870,HLDP,0))
  ;-- foreground
  I Y="F" S HLTRACE=1 D  G STARTQ
- . S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- . D MON^HLCSTCP("Start")
  . X HLBGR
  ;-- background
@@ -111,13 +82,8 @@
  . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
  . D ^%ZTLOAD
- . ; patch HL*1.6*122 start
- . I $D(ZTSK) D
- .. K HLTRACE
- .. D MON^HLCSTCP("Tasked")
- .. S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- . ; patch HL*1.6*122 end
  . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
  ;
  Q
+ ;
  ;
 STARTQ ;
@@ -132,9 +98,6 @@
  S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
  S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
- ; patch HL*1.6*122
- ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
- ; by the external service
  I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  Q
- . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to disable this LLP."
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
  . Q
  ;
@@ -150,16 +113,12 @@
  I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
  D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
- ; patch HL*1.6*122 start
- ; I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
- ; I ^%ZOSF("OS")'["DSM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
- I ($P(HLPARM4,U,3)="S")!(($P(HLPARM4,U,3)="M")&($S(^%ZOSF("OS")'["OpenM":0,1:$$OS^%ZOSV'["VMS"))) D
+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
  . ;pass task number to stop listener
  . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
- . ; D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- . ; I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
- . ; U IO W "**STOP**"
- . ; W !
- . ; D CLOSE^%ZISTCP
- . ; patch HL*1.6*122 end
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+ . U IO W "**STOP**"
+ . W !
+ . D CLOSE^%ZISTCP
  L -^HLCS(870,HLDP,0)
  W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;12/11/2007  17:07
- ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;07/10/2000  12:18
+ ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109**;Oct 13, 1995
  ;
  ;This Program drives a real-time display monitor for the HL7
@@ -18,9 +17,4 @@
  N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE
  N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY
- ;
- ; patch HL*1.6*122 start
- D HOME^%ZIS
- W @IOF
- ; patch HL*1.6*122 end
  ;
  D ^HLCSTERM ;Sets up variables to control display attributes
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSMON1 ;SF-Utilities for Driver Program  ;07/17/2007  17:05
- ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSMON1 ;SF-Utilities for Driver Program  ;02/04/2004  10:25
+ ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, 1995
  ;
  ;This routine contains several entry points called from HLCSMON
@@ -12,9 +11,5 @@
  F  S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0)  D WLINE(HLXX)
  ;DISPLAY INCOMING FILER STATUS
- ; patch HL*1.6*122
- S HLXX=$P(HLRUNCNT,"^",1)
- ; S HLXX=$$CNTFLR^HLCSUTL2("IN")
- I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("IN")
- ;
+ S HLXX=$$CNTFLR^HLCSUTL2("IN")
  ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
  I (HLXX'=+HLRUNCNT) D
@@ -24,9 +19,5 @@
  .S $P(HLRUNCNT,"^",1)=HLXX
  ;DISPLAY OUTGOING FILER STATUS
- ; patch HL*1.6*122
- S HLXX=$P(HLRUNCNT,"^",2)
- ; S HLXX=$$CNTFLR^HLCSUTL2("OUT") 
- I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("OUT")
- ;
+ S HLXX=$$CNTFLR^HLCSUTL2("OUT")
  ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
  I (HLXX'=+$P(HLRUNCNT,"^",2)) D
@@ -56,18 +47,11 @@
  I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q
  S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1
- ; patch HL*1.6*122
- ; F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
- F X=1,7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,10)
- F X=2:1:5 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
- S X=6,@$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,7)
- ;
+ F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
  ;if link is in error, write node in rev. video
  I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14
  ;Turn off terminal line wrap & inform O/S where cursor is located
  S DY=HLXX X IOXY,^%ZOSF("XY")
- ; patch HL*1.6*122
- W:HLERR="" ?4,HLNODE
- W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?63,HLSTAT
- ;
+ W:HLERR="" ?5,HLNODE
+ W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?64,HLSTAT
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m	(revision 636)
@@ -1,6 +1,4 @@
-HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT ;10/17/2007  08:56
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT - 10/4/94 1pm
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
 REPMSG ;Duplicate messages on a queue
  ; INPUT:  MSG   - Array which contains the queue and the
@@ -36,10 +34,5 @@
  I DIR'="I",DIR'="O" Q
  Q:'$G(IEN773)
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
  S ^HLMA("AC",DIR,LINK,IEN773)=""
- L -^HLMA("AC",DIR,LINK,IEN773)
- ;
  S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja
  I DIR="O" D LLCNT^HLCSTCP(LINK,3)
@@ -56,9 +49,4 @@
  I DIR'="I",DIR'="O" Q
  Q:'$G(IEN773)
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
  K ^HLMA("AC",DIR,LINK,IEN773)
- L -^HLMA("AC",DIR,LINK,IEN773)
- ;
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m	(revision 636)
@@ -1,65 +1,40 @@
-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,18 +55,26 @@
  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,11 +93,9 @@
  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,19 +125,10 @@
  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,6 +138,5 @@
  ;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,5 +146,5 @@
  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,37 +152,21 @@
  ;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,31 +185,19 @@
  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,11 +209,7 @@
  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="@"
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/17/2007  12:59
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 14
+HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07  08:58
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;Receiver
@@ -12,18 +12,11 @@
  ; variable to replace ^TMP
  N HLTMBUF
- ;
  ; for HL7 application proxy user
- ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
- N HLDUZ
- S HLDUZ=+$G(DUZ)
- ;
+ N HLDUZ,DUZ
  D MON^HLCSTCP("Open")
  ; K ^TMP("HLCSTCP",$J,0)
  S HLMIEN=0,HLASTMSG=""
- ;
- ; patch HL*1.6*122 TEST v2: DUZ code removed
  ; set DUZ for application proxy user
- ;; D PROXY^HLCSTCP4
- ;
+ D PROXY^HLCSTCP4
  F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
  . ; clean variables
@@ -31,9 +24,6 @@
  . S HLMIEN=$$READ
  . Q:'HLMIEN
- . ;
- . ; patch HL*1.6*122 TEST v2: DUZ code removed
  . ; DUZ comparison/reset for application proxy user
- . ;; D HLDUZ^HLCSTCP4
- . D HLDUZ2^HLCSTCP4
+ . D HLDUZ^HLCSTCP4
  . ; protect HLDUZ 
  . N HLDUZ
@@ -112,5 +102,5 @@
  . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
  ; detect disconnect for GT.M
- I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
+ I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=""
  ; timedout, <clean up>, quit
  ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
@@ -244,17 +234,6 @@
 SAVE(SRC,DEST) ;save into global & set top node
  ;SRC=source array (passed by ref.), DEST=destination global
- ;
- ; patch HL*1.6*122: MPI-client/server
- I DEST["HLMA" D
- . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
- E  D
- . F  L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T  H 1
- ;
  M @DEST=SRC
  S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
- ;
- I DEST["HLMA" L -^HLMA(+HLIND1)
- E  L -^HL(772,+$P(HLIND1,U,2))
- ;
  Q
  ;
@@ -277,7 +256,11 @@
  ;
 ERROR ; Error trap for disconnect error and return back to the read loop.
- ; patch HL*1.6*122
- ; move to routine HLCSTCP4 (splitted-size over 10000)
- D ERROR1^HLCSTCP4
+ S $ETRAP="D UNWIND^%ZTER"
+ I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q  ;VOE change for GT.M
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+ I $ECODE["UREAD" D UNWIND^%ZTER Q  ; HL*1.6*122 GT.M
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+ D UNWIND^%ZTER
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/17/2007  09:37
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122**;Oct 13,1995;Build 14
+HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133**;Oct 13,1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;Sender 
@@ -11,10 +11,7 @@
  S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
  ;
- ; patch 122
- ; patch 133
- ; set IO(0) to the null device
- I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D
- . S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
- . O IO(0) U IO(0)
+ ;set IO(0) to the null device
+ S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
+ O IO(0) U IO(0)
  ;
  ;persistent conection, open connection first, HLPORT=open port
@@ -39,21 +36,16 @@
  ; and then check the link if it open or not
  N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
- N HLTMBUF
- D MON^HLCSTCP("CheckOut")
+ D MON^HLCSTCP("Check out")
  ;HLMSG=next msg, set at tag DONE
  I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
  ;
+ ;**109**
+ ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete
+ ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q
+ ;L -^HLMA(HLMSG)
+ ;
  S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
  ;don't have message text or MSH, kill x-ref and decrement 'to send'
- ;
- ; patch HL*1.6*122: MPI-client/server
- ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
- I 'HLI!'HLJ D  Q
- . F  L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T  H 1
- . K ^HLMA("AC","O",HLDP,HLMSG)
- . L -^HLMA("AC","O",HLDP,HLMSG)
- . D LLCNT^HLCSTCP(HLDP,3,1)
- . S HLMSG=0
- ;
+ I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
  ;update msg status to 'being transmitted'; if cancelled decrement link and quit
  I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
@@ -153,6 +145,4 @@
  ; Set up error trap
  N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
- ; patch HL*1.6*122
- N HLTMBUF
  ;override ack timeout
  I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
@@ -179,4 +169,5 @@
  D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
  ;
+ ;**109**
  D DEQUE^HLCSREP(HLDP,"O",HLMSG)
  ;
@@ -189,4 +180,8 @@
  ;returns 1=msg was updated, 0=msg has been canceled
  N X
+ ;
+ ;**109**
+ ;F  L +^HLMA(HLMSG,"P"):1 Q:$T  H 1
+ ;
  ;
  ; New HL*1.6*77 code starting here...
@@ -195,14 +190,22 @@
  .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
  .;
+ .;**109**
  . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
- ;
- ; End of HL*1.6*77
+ .;L -^HLMA(HLMSG,"P")
+ ;**end 109**
+ ;
+ ; End of HL*1.6*77 modifications
  ;
  ;get status, quit if msg was cancelled
  ;
+ ;**109**
+ ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0
  S X=+^HLMA(HLMSG,"P") Q:X=3 0
  ;
  ;update status if it is different
  I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
+ ;
+ ;**109**
+ ;L -^HLMA(HLMSG,"P")
  ;
  Q 1
@@ -216,6 +219,5 @@
  ;           -1 - Unsuccessful
  ;
- N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
- S CRCOUNT=0
+ N HLDA2,HLAR,HLI,LINENO,X
  ;set error trap, used when called from HLTP3
  ;
@@ -235,29 +237,12 @@
  .. ;first line, need start block char.
  .. S:LINENO=1 X=$C(11)_X
- .. ; HL*1.6*122
- .. ; I X]"" W X,!
- .. N LENGTH
- .. S LENGTH=$L(X)
- .. ; buffer should be limited to 512
- .. I LENGTH>512 D
- ... N X1
- ... F  Q:LENGTH<512  D
- .... S X1=$E(X,1,512),X=$E(X,513,999999)
- .... S LENGTH=$L(X)
- .... W X1,@IOF
- .. ;
- .. ; @IOF (! or #) for flush character
- .. I X]"" W X,@IOF S CRCOUNT=0
- .. ;send CR
- .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1
- .. ; prevent from maxstring error
- .. I CRCOUNT>200 W @IOF S CRCOUNT=0
+ .. I X]"" W X,!
+ .. ;send CR for blank lines
+ .. I X="" W $C(13)
  .. S LINENO=LINENO+1
  ; Sends end block for this message
  S X=$C(28)_$C(13)
- ; U IO W X,!
- U IO W X,@IOF
- ;switch to null device
- I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
+ U IO W X,!
+ I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage'
  Q 1
  ;
@@ -271,6 +256,6 @@
  G OPENA^HLCSTCP3
  ;
-RDERR D RDERR^HLCSTCP4 Q
-ERROR D ERROR^HLCSTCP4 Q
+RDERR D RDERR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+ERROR D ERROR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
  ;
 CC(X) ;cleanup and close
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m	(revision 636)
@@ -1,54 +1,16 @@
-HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 09/13/2006  15:36
- ;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122**;OCT 13, 1995;Build 14
+HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**76,77,133**;OCT 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
-OPENA ;
- ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA
- ;
- I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+ D MON^HLCSTCP("Open")
  S POP=1
- ;
- ; patch HL*1.6*122 start
- ; variable HLDRETR=re-transmit attemps (#870,200.02)
- ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()
- ; defined in HLCSTCP routine
- ;
- I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=1
- I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=5
- S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR
- ; patch 133
- ; I $G(HLDIRECT("OPEN TIMEOUT")) D
- ; .S HLI=1
- ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
- ; E  D
- ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
  I $G(HLDIRECT("OPEN TIMEOUT")) D
- . D MON^HLCSTCP("Open")
- . D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
- . ; give site one more chance to override the application setup
- . I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D
- .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
+ .S HLI=1
+ .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
  E  D
- . N COUNT
- . ; try to connect HLDRETR times
- . F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D  Q:('POP)!($$STOP^HLCSTCP)
- .. D MON^HLCSTCP("Open")
- .. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT)
- .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
- .. ;open error
- .. I POP D
- ... D CC^HLCSTCP2("Openfail")
- ... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8)
- ... I '$D(^XTMP("HL7-Openfail",$J)) D
- .... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT
- .... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT
- ... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1
- ... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT
- ;
+ .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
  ;set # of opens back in msg
- ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
- I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT")
- ; patch HL*1.6*122 end
- ;
+ I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
  ;device open
  I 'POP S HLPORT=IO D  Q $S($G(HLERROR)]"":0,1:1)
@@ -61,26 +23,14 @@
  . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
  ;openfail-try DNS lookup
- ;
- ; patch HL*1.6*122 start
- ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
- I '$D(HLDOM) D
- . S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U)
- . S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
- . D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS
- ;
- Q:$$STOP^HLCSTCP 0
+ I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
  ;HLIP=ip add. from DNS call, get first one and try open again
  I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
- ; open error
- ;cleanup and close
- ; patch 133
+ ;open error
  I $G(HLDIRECT("OPEN TIMEOUT")) D
- . D MON^HLCSTCP("Openfail")
- . I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+ .D MON^HLCSTCP("Openfail")
+ .I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
  E  D
- . D CC^HLCSTCP2("Openfail")
+ .D CC^HLCSTCP2("Openfail") H 3
  Q 0
- ; patch HL*1.6*122 end
- ;
  ;
  ;following code was removed, site's complained of to many alerts
@@ -107,10 +57,4 @@
  I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
  I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
- ;
- ; patch HL*1.6*122 start
- I $L($G(HLDOM("DNS")),".")>2 D
- . S HLDOM=HLDOM("DNS")
- ; patch HL*1.6*122 end
- ;
  S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
  K:HLIP="" HLIP
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/18/2007  09:56
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
+HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006  13:31
+ ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -15,69 +15,35 @@
  ;I $G(HLMSG) L -^HLMA(HLMSG)
  ;
- ; patch HL*1.6*122 start
- N STOP
- S STOP=0
- I $G(HLDP) S STOP=$$STOP^HLCSTCP
  S $ETRAP="D UNWIND^%ZTER"
- S HLTCP("$ZA\8192#2")=""
- I (^%ZOSF("OS")["OpenM") D
- . S HLTCP("$ZA")=$ZA
- . ; For TCP devices $ZA\8192#2: the device is currently in the
- . ; Connected state talking to a remote host.
- . S HLTCP("$ZA\8192#2")=$ZA\8192#2
- ;
+ ; patch HL*1.6*122
+ S HLTCPERR("$P")=$P
  S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
  ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
- I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  G:STOP H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Op-err") H 1
+ I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
+ . D CC^HLCSTCP2("Op-err")
  . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
- . I 'STOP D UNWIND^%ZTER
- I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Wr-err") H 1
- . S:$G(HLPRIO)="I" HLERROR="108^Write Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
- . I HLTCP("$ZA\8192#2")=0 D  Q
- .. D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
- . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER
+ . D UNWIND^%ZTER
+ I $$EC^%ZOSV["WRITE" D  Q  ;HL*1.6*77 modifications start here
+ .  D CC^HLCSTCP2("Wr-err")
+ .  S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+ .  D UNWIND^%ZTER ;HL*1.6*77 modifications end here
  ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
- I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Rd-err") H 1
+ I $$EC^%ZOSV["READ" D  Q
+ . D CC^HLCSTCP2("Rd-err")
  . S:$G(HLPRIO)="I" HLERROR="108^Read Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
- . I HLTCP("$ZA\8192#2")=0 D  Q
- .. D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
- . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER
+ . D UNWIND^%ZTER
  S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
  S:$G(HLPRIO)="I" HLERROR="9^Error"
- I STOP D CC^HLCSTCP2("Shutdown: (with 'Error')")
- I HLTCP("$ZA\8192#2")=0 D
- . D CC^HLCSTCP2("Halt (Er): (Disconnected with 'Error')")
- G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN
- ; patch HL*1.6*122 end
  D UNWIND^%ZTER
  Q
  ;
 PROXY ; set DUZ for application proxy user
- ;
- ; removed the execcution: patch 122 TEST v2
+ S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
+ S DUZ=HLDUZ
+ D DUZ^XUP(DUZ)
  Q
  ;
- ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
- ;; S DUZ=HLDUZ
- ;; D DUZ^XUP(DUZ)
- ;; Q
- ;
 HLDUZ ; compare DUZ and set DUZ to application proxy user
- ;
- ; removed the execcution: patch 122 TEST v2
- Q
- ;
- ;; I '$G(HLDUZ) D PROXY
- ;
-HLDUZ2 ; compare DUZ and HLDUZ
+ I '$G(HLDUZ) D PROXY
  I $G(DUZ)'=HLDUZ D
  . S DUZ=HLDUZ
@@ -121,10 +87,5 @@
  I HLIND1 D  Q
  . ;get pointer to 772, kill header
- . ;
- . ; patch HL*1.6*122: MPI-client/server
- . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
  . K ^HLMA(+HLIND1,"MSH")
- . L -^HLMA(+HLIND1)
- . ;
  . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
  . S X=$$MAID^HLTF(+HLIND1,HLMID)
@@ -155,64 +116,2 @@
  Q X
  ;
-ERROR1 ;
- ; moved from ERROR^HLCSTCP1
- ; Error trap for disconnect error and return back to the read loop.
- ; patch HL*1.6*122 start
- I (^%ZOSF("OS")["OpenM") D
- . S HLTCP("$ZA")=$ZA
- . ; For TCP devices $ZA\8192#2: the device is currently in the
- . ; Connected state talking to a remote host.
- . S HLTCP("$ZA\8192#2")=$ZA\8192#2
- . I HLTCP("$ZA\8192#2")=0 D
- .. ; decrement counter of multi-listener
- .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
- .. ; process terminated
- .. D H2^XUSCLEAN
- S $ETRAP="D UNWIND^%ZTER"
- ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
- I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
- . D UNWIND^%ZTER
- I $$EC^%ZOSV["READ" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
- . D UNWIND^%ZTER
- ;
- ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
- I $$EC^%ZOSV["WRITE" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
- . D UNWIND^%ZTER
- ;
- ; for GT.M
- I $ECODE["UREAD" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
- . D UNWIND^%ZTER
- ;
- ; S HLCSOUT=1 D ^%ZTER,CC("Error")
- S HLCSOUT=1
- D ^%ZTER
- ; if it is not a multi-listener
- I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
- ; patch HL*1.6*122 end
- ;
- D UNWIND^%ZTER
- Q
- ;
-CLRMCNTR ;
- ; clear the counter to set as "0 server" for multi-listener
- ; HL*1.6*122 start
- Q:'$G(HLDP)
- Q:'$D(^HLCS(870,"E","M",HLDP))
- S $P(^HLCS(870,HLDP,0),"^",4)="MS"
- S $P(^HLCS(870,HLDP,0),U,5)="0 server"
- Q
- ;
-CREATUSR ;
- ; patch HL*1.6*122 TEST v2: DUZ code removed
- ; create application proxy users for listeners and incoming filer
- ;; N HLTEMP
- ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m	(revision 636)
@@ -1,37 +1,23 @@
-HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/26/2007  10:29
- ;;1.6;HEALTH LEVEL SEVEN;**84,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/10/2003  10:12
+ ;;1.6;HEALTH LEVEL SEVEN;**84**;Oct 13, 1995
  ;
- ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM,
- ;    HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port
- ;    number.
- ; 2. find the ien of #870(logical link file) for the multi-listener
+ ; 1. port number is input from VMS HLSxxxxDSM.COM or HLSxxxxCACHE.COM
+ ;    file, where xxxx is port number.
+ ; 2. find the ien of #870(logical link file) for the HL7 multi-listener
+ ; 3. call the appropriate entry:
+ ;    for Cache: CACHEVMS^HLCSTCP(ien of #870)
+ ;    for DSM:   EN^HLCSTCP
  Q
+PORT ;
+ ;HLIEN870: ien in #870 (logical link file)
+ ;HLPORT: port number of multi-listener
+ ;HLPRTS: port number in entry to be tested
+ ;input of DSM: % = device^port number of multi-listener
+ ;input of Cache: port number of TCPIP
  ;
-GTMPORT(%) ; From tcpip ZFOO for GT.M
- ; %: device^port number
- N HLPORT
- S HLPORT=$P($G(%),"^",2)
- I $G(^%ZOSF("OS"))'["GT.M" D ^%ZTER Q
- D IEN
- Q
- ;
-PORT ;
- ; HLPORT: port number of multi-listener
- ; input of DSM: % = device^port number of multi-listener
- ; input of Cache: port number of TCPIP
- ;
- N HLPORT
- S HLPORT=0
  I ^%ZOSF("OS")["OpenM" D
  . S HLPORT=$ZF("GETSYM","PORT")
  I ^%ZOSF("OS")["DSM" D
  . S HLPORT=$P(%,"^",2)
- ;
-IEN ;
- ; HLIEN870: ien in #870 (logical link file)
- ; HLPRTS: port number in entry to be tested
- ;
- N HLIEN870
  I 'HLPORT D ^%ZTER Q
  S HLIEN870=0
@@ -41,10 +27,8 @@
  ;
  K HLPORT,HLPRTS
- ; patch 122
- S U="^"
  ;
  ;for Cache/VMS
  I ^%ZOSF("OS")["OpenM" D  Q
- . D CACHEVMS(HLIEN870)
+ .D CACHEVMS^HLCSTCP(HLIEN870)
  ;
  ;for DSM
@@ -52,62 +36,6 @@
  . S $P(%,"^",2)=HLIEN870   ;set % = device^ien of #870
  . K HLIEN870
- . D EN
- ;
- ;for GT.M
- I ^%ZOSF("OS")["GT.M" D  Q
- . S HLDP=HLIEN870   ;set HLDP = ien of #870
- . K HLIEN870
- . D GTMUCX
+ . D EN^HLCSTCP
  ;
  D ^%ZTER
  Q
-GTMUCX ; GT.M /VMS tcpip
- ;listener,  % = device^port
- S U="^",IO=$P(%,U)
- ; S IO(0)=$P O IO(0) ;Setup null device
- ; GTM specific code
- S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- X "O IO:(RECORDSIZE=512)"
- D LISTEN^HLCSTCP
- C IO
- Q
- ;
- ; $ x=f$trnlnm("sys$net")  !This is our MBX device
- ; $!
- ; $! for GT.M
- ; $ assign 'f$trnlnm("SYS$NET")' SYS$NET
- ; $! Depending on how your command files are set up, you may need to
- ; $! run the GT.M profile file.
- ; $ @<user$:[gtmmgr]>gtmprofile.com
- ; $ forfoo="$" + f$parse("user$:[gtmmgr.r]ZFOO.exe")
- ; $ PORT=5000
- ; $ data="''x'^''PORT'"
- ; $ forfoo GTMPORT^HLCSTCPA("''data'")
- ;
-CACHEVMS(%) ;Cache'/VMS tcpip
- ;listener,  % = HLDP
- I $G(%)="" D ^%ZTER Q
- ; patch 133
- S IO="SYS$NET",U="^",HLDP=%
- S IO(0)="_NLA0:" O IO(0) ;Setup null device
- ; **Cache'/VMS specific code**
- O IO::5 E  D MON^HLCSTCP("Openfail") Q
- X "U IO:(::""-M"")" ;Packet mode like DSM
- D LISTEN^HLCSTCP
- C IO
- Q
- ;
-EN ; DSM/VMS tcpip
- ;listener,  % = device^HLDP
- I $G(%)="" D ^%ZTER Q
- ; patch 122
- ; S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
- S U="^",IO=$P(%,U),HLDP=$P(%,U,2)
- ; patch 133
- S IO(0)="_NLA0:" O IO(0) ;Setup null device
- ; **VMS specific code, need to share device**
- O IO:(TCPDEV):60 E  D MON^HLCSTCP("Openfail") Q
- ; patch 122
- D LISTEN^HLCSTCP
- C IO
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m	(revision 636)
@@ -1,6 +1,4 @@
-HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES ;06/27/2007  17:04
- ;;1.6;HEALTH LEVEL SEVEN;**40,49,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES - 8/1/94 ;07/28/98  09:43
+ ;;1.6;HEALTH LEVEL SEVEN;**40,49**;Oct 13, 1995
 TERM ; -- set up term characteristics
  N X
@@ -25,8 +23,5 @@
  D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8)
  D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT    ",8)
- ; patch HL*1.6*122
- ; D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
- D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",6)
- ;
+ D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
  D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8)
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 636)
@@ -1,6 +1,4 @@
-HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
+HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995
  ;
  ; Rules: if any of these rules is broken, FILE^DIE is called instead
@@ -75,12 +73,6 @@
  .I FILE=772 D DEL772^HLUOPT3(+IEN)
  ;
- ; patch HL*1.6*122: MPI-client/server
  ; If no data in record passed in, log an error and quit...
- ; I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
- N HLDGBL
- F  L +@GBL:10 Q:$T  H 1
- S HLDGBL=$D(@GBL)
- L -@GBL
- I 'HLDGBL D  Q  ; Remember.  GBL contains IEN...
+ I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
  .  S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
  .  S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
@@ -118,10 +110,4 @@
  QUIT:'$D(NODE("CHG"))  ;->
  ;
- ; patch HL*1.6*122: MPI-client/server
- I FILE=773 D
- . F  L +^HLMA(IEN):10 Q:$T  H 1
- E  D
- . F  L +^HL(772,IEN):10 Q:$T  H 1
- ;
  ; Store changes in the global now...
  D STORE(FILE,IEN,.NODE)
@@ -131,8 +117,4 @@
  F  S XRF=$O(XRF(XRF)) Q:XRF']""  D
  .  D @("XRF"_XRF_U_ROUTINE)
- ;
- ; patch HL*1.6*122: MPI-client/server
- I FILE=773 L -^HLMA(IEN)
- E  L -^HL(772,IEN)
  ;
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m	(revision 636)
@@ -1,6 +1,4 @@
-HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages  ;03/26/2008  11:34
- ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;08/03/2000  15:45
+ ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66**;Oct 13, 1995
 HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
  ; INPUT: X - Name in DHCP format
@@ -55,5 +53,5 @@
  Q $S(Y="DT":$E(%,1,8),1:%)
  ;
-FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format
+FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format
  I X="" Q ""
  N %
@@ -160,20 +158,5 @@
  Q:'$D(X) ""  Q:$L(X)<7 ""
  N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
- ;
- ; patch HL*1.6*141 start
- ; S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
- N CH
- S Y=""
- F I=1:1:$L(X) D
- . S CH=$E(X,I)
- . ; Next line modified by RBN
- . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
- . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"")
- . I "Xx"[CH S Z=""
- ;
- ; the number, following "X" character, should be greater than 0
- I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X")
- ; patch HL*1.6*141 end
- ;
+ S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
  I $L(Y)<7 Q ""
  S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m	(revision 636)
@@ -1,4 +1,4 @@
-HLMA ;AISC/SAW-Message Administration Module ;10/24/2007  10:15
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122**;Oct 13, 1995;Build 14
+HLMA ;AISC/SAW-Message Administration Module ;10/25/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
 GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ;
@@ -35,7 +35,5 @@
  ;   HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
  ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
- ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or
- ;   <subscriber protocol name> - A list of protocols to dynamically
- ;   drop from the event protocol's subscriber multiple.
+ ; HLP("EXLCLUDE SUBSCRIBER",<n=1,2,3...>)=<subsciber protocol ien> - A list of protocols to dynamically drop from the event protocol's subscriber multiple.
  ;
  ;can't have link open when generating new message
@@ -44,7 +42,5 @@
  S HLRESLT=""
  ;Check for required parameters
-CONT ;
- I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D  G EXIT
- . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point"
+CONT I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" G EXIT
  I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT
  N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)=""
@@ -82,9 +78,4 @@
  I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR
  S HLRESLT=HLRESLT_"^"_HLRESLT1
- ;
- ; patch HL*1.6*122
- S HLRESLT("HLMID")=$G(HLMIDAR("HLMID"))
- S HLRESLT("IEN773")=$G(HLMIDAR("IEN773"))
- ;
  ;Execute exit action for event driver protocol
  I HLEXROU]"" X HLEXROU
@@ -97,11 +88,9 @@
  ;Entry point to generate an immediate message, must be TCP Logical Link
  ;Input:
- ;  The same as GENERATE,with one additional subscript to the HLP input 
- ;  array:
+ ;  The same as GENERATE,with one additional subscript to the HLP input array:
  ; 
  ;  HLP("OPEN TIMEOUT") (optional, pass by reference) a number between 
  ;    1 and 120 that specifies how many seconds the DIRECT CONNECT should
- ;    try to open a connection before failing.  It is killed upon 
- ;    completion.
+ ;    try to open a connection before failing.  It is killed upon completion.
  ; 
  N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
@@ -137,6 +126,4 @@
  ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
  D SETUP^HLCSAC G:HLCS PINGQ
- ; patch HL*1.6*122
- G:$$DONTPING^HLMA4 PINGQ
  ;PING header=MSH^PING^domain^PING^logical link^datetime
  S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H)
@@ -147,11 +134,5 @@
  . ;non-standard HL7 header; start block,header,end block
  . S HLX1=$H
- . ;
- . ; HL*1.6*122 start
- . ; replace flush character '!' with @IOF (! or #)
- . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
- . W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF
- . ; HL*1.6*122 end
- . ;
+ . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
  . ;read response
  . R X:HLDREAD
@@ -179,20 +160,10 @@
  N HLDOM,HLIP S HLCS=""
  S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
- ; patch HL*1.6*122 start
- S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
- ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
- I 'HLDOM,($L(HLDOM("DNS"),".")<3) D  Q
- . I 'HLQUIET W !,"Domain Unknown"
- . S HLCS="-1^Connection Fail"
- ; patch HL*1.6*122 end
+ I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
  I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
- ; patch HL*1.6*122
- ; I HLDOM]"" D  Q:'POP
- I HLDOM]""!($L(HLDOM("DNS"),".")>2) D  Q:'POP
+ I HLDOM]"" D  Q:'POP
  . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
  . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
  . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
- . ; patch HL*1.6*122
- . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS")
  . I 'HLQUIET W !,"Domain, "_HLDOM
  . I 'HLQUIET W !,"Port: ",HLTCPORT
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;07/18/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;02/06/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -54,9 +54,9 @@
  .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q
  .;
- .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO^HLOAPI2(.HLMSTATE,.WHOTO,.ERR2) D
+ .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO(.HLMSTATE,.WHOTO,.ERR2) D
  ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1
  .E  D
- ..S ERROR=$G(ERR1)_": "_$G(ERR2)
- ..D DONTSEND(.HLMSTATE,ERROR)
+ .S ERROR=$G(ERR1)_": "_$G(ERR2)
+ .D DONTSEND(.HLMSTATE,ERROR)
  K PARMS,WHOTO
  Q $S(SUCCESS:HLMSTATE("IEN"),1:0)
@@ -106,5 +106,5 @@
  .K STATE M STATE=HLMSTATE S STATE("IEN")=""
  .S ERROR=""
- .I $$CHKWHO^HLOAPI2(.STATE,.WHO,.ERROR) D
+ .I $$CHKWHO(.STATE,.WHO,.ERROR) D
  ..I $$SEND(.STATE,.ERROR) D
  ...S WHOTO(I,"QUEUED")=1
@@ -190,14 +190,10 @@
  ;
  I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0
- I HLMSTATE("BATCH"),$L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) S ERROR="SEQUENCE QUEUES NOT SUPPORTED FOR BATCH MESSAGES" Q 0
- I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
- .S HLMSTATE("STATUS","MOVED TO OUT QUEUE")=$$SQUE^HLOQUE(HLMSTATE("STATUS","SEQUENCE QUEUE"),HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) D:HLMSTATE("STATUS","MOVED TO OUT QUEUE")
- ..S $P(^HLB(HLMSTATE("IEN"),5),"^",2)=1
- E  D
- .D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
+ D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
  Q HLMSTATE("IEN")
  ;
 DONTSEND(HLMSTATE,ERROR) ;
- ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the status ER.  
+ ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the
+ ;of "SE".  
  ;Input:
  ;       HLMSTATE - pass-by-reference
@@ -207,7 +203,20 @@
  I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue
  ;
- S HLMSTATE("STATUS")="ER"
+ S HLMSTATE("STATUS")="SE"
  S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE"))
  S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR)
  I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app
  Q
+ ;
+CHKWHO(HLMSTATE,WHOTO,ERROR) ;
+ N RETURN,I
+ S RETURN=1
+ I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
+ ;
+ ;move parameters into HLMSTATE
+ S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
+ S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
+ S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
+ S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
+ F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
+ Q RETURN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/30/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134,137**;Oct 13, 1995;Build 21
+HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;12/11/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -66,5 +66,5 @@
  .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
  .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
- .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
+ .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
  .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))
  .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
@@ -117,17 +117,9 @@
  I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20)
  I 'LEN S PARMS("QUEUE")="DEFAULT"
- D
- .N APPIEN
- .I $G(PARMS("SENDING APPLICATION"))="" D  Q
- ..S ERROR="SENDING APPLICATION IS REQUIRED"
- ..S PARMS("SENDING APPLICATION")=""
- .E  D  Q:'APPIEN
- ..S APPIEN=$$GETIEN^HLOAPP(PARMS("SENDING APPLICATION"))
- ..I 'APPIEN S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
- .I $L($G(PARMS("SEQUENCE QUEUE"))) D
- ..I ($L(PARMS("SEQUENCE QUEUE"))>30) S ERROR="SEQUENCE QUEUE NAME > 30 CHARACTERS" Q
- ..I PARMS("SEQUENCE QUEUE")["^" S ERROR="SEQUENCE QUEUE NAME MAY NOT CONTAIN '^'" Q
- ..I $G(PARMS("APP ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN APPLICATION ACKNOWLEDGMENT" Q
- ..I $G(PARMS("ACCEPT ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN ACCEPT ACKNOWLEDGMENT" Q
+ I $G(PARMS("SENDING APPLICATION"))="" D
+ .S ERROR="SENDING APPLICATION IS REQUIRED"
+ .S PARMS("SENDING APPLICATION")=""
+ E  D
+ .I '$D(^HLD(779.2,"C",PARMS("SENDING APPLICATION"))) S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
  ;
  ;move parameters into HLMSTATE
@@ -140,8 +132,6 @@
  S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE"))
  S @SARY@("QUEUE")=PARMS("QUEUE")
- S @SARY@("SEQUENCE QUEUE")=$G(PARMS("SEQUENCE QUEUE"))
  Q:$L(ERROR) 0
  Q 1
- ;
  ;
 SETCODE(SEG,VALUE,FIELD,COMP,REP) ;
@@ -165,15 +155,2 @@
  S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT"))
  Q
- ;
-CHKWHO(HLMSTATE,WHOTO,ERROR) ;
- N RETURN,I
- S RETURN=1
- I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
- ;
- ;move parameters into HLMSTATE
- S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
- S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
- S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
- S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
- F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
- Q RETURN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,133,134,137**;Oct 13, 1995;Build 21
+HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;03/13/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -92,5 +92,5 @@
  .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3)
  .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID")
- .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
+ .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
  .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR)
  .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE"))
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m	(revision 636)
@@ -1,9 +1,13 @@
-HLOAPP ;ALB/CJM-HL7 -Application Registry ;07/09/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,137**;Oct 13, 1995;Build 21
+HLOAPP ;ALB/CJM-HL7 -Application Registry ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
 GETIEN(NAME) ;given the application name, it finds the ien.  Returns 0 on failure
  Q:'$L($G(NAME)) 0
- Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0))
+ N IEN,SUB
+ S SUB=$E(NAME,1,60)
+ S IEN=0
+ F  S IEN=$O(^HLD(779.2,"B",SUB,IEN)) Q:'IEN  Q:$P($G(^HLD(779.2,IEN,0)),"^")=NAME
+ Q +IEN
  ;
 ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
@@ -93,24 +97,2 @@
  S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
  Q ACTIVE
- ;
-EXCEPT(APPNAME) ;
- ;returns the exception handler (tag^routine) that should be invoked
- ;when an applicaiton's messages are being sequenced and an app ack
- ;is not timely received
- ;
- N IEN,RTN
- S IEN=$$GETIEN($G(APPNAME))
- I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11)
- I $L($G(RTN))>1 Q RTN
- Q "DEFAULT^HLOAPP"
- ;
-DEFAULT ;default exception handler if the app doesn't specify one
- S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))=""
- Q
- ;
-TIMEOUT(APPNAME) ;
- N IEN,TIME
- S IEN=$$GETIEN($G(APPNAME))
- I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12)
- Q:'$G(TIME) 10
- Q TIME
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;08/15/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -155,6 +155,4 @@
  .;
  .;try to send the message
- .;
- .;
  .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
  .;does the message need an accept ack?
@@ -170,20 +168,10 @@
  ..S $P(UPDATE,"^",5)=1
  ..S UPDATE("MSA")=ACKID_"^"_MSA
- ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=2
+ ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2
  ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
- ..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
+ ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
  ..;
- ..;if it's from a sequence queue, timestamp the queue
- ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
- ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
- ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
- ...I ACKCODE="CA" S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($P(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))) L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
- ...;if the message wasn't accepted, need to notify without waiting
- ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2)
- ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
- ..;
- ..;does the app need notification of accept ack?
+ ..;did the app request notification of accept ack?
  ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
- ..;
  ..S SUCCESS=1
  .E  D  ;accept ack wasn't requested
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -146,5 +146,5 @@
  ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS"
  ...S $P(^HLB(MSG,0),"^",20)="TF"
- ...S ^HLB("ERRORS",RAPP,TIME,MSG)=""
+ ...S ^HLB("ERRORS","TF",SAPP,TIME,MSG)=""
  ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT)
  ...S ACTION=$P(NODE0,"^",14,15)
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -53,7 +53,7 @@
 UPDATE(MSGIEN,TIME,PARMS) ;
  S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS")
- I PARMS("STATUS")="ER" D
- .S ^HLB("ERRORS",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
- .D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
+ S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)=""
+ S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
+ I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
  S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK")
  S $P(^HLB(MSGIEN,0),"^",16)=TIME
@@ -101,5 +101,4 @@
  ;    "ID" - message id from the header
  ;    "IEN" - ien, file 778
- ;    "STATUS","SEQUENCE QUEUE")=name of the sequence queue (optional)
  ;
  K MSG
@@ -147,5 +146,4 @@
  .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2)
  .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2)
- S MSG("STATUS","SEQUENCE QUEUE")=$P($G(^HLB(IEN,5)),"^")
  Q 1
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
+HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -29,9 +29,9 @@
  .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
  .S ^HLB("AD","OUT",PURGE,MSGIEN)=""
- .S $P(^HLB(MSGIEN,0),"^",20)="ER"
+ .S $P(^HLB(MSGIEN,0),"^",20)="AE"
  .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT"
  .M HDR=MSG("HDR")
  .Q:'$$PARSEHDR^HLOPRS(.HDR)
- .S ^HLB("ERRORS",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
+ .S ^HLB("ERRORS","AE",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
  .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT")))
  S:MSGIEN>99999999999 MSGIEN=0
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;07/24/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -17,9 +17,8 @@
  ;   ARYTYP = The array where HL7 message resides
  ;   HLP = Additional HL7 message parameters (optional, pass by reference)
- ;        These optional subscripts to HLP are supported for input:
- ;             "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
- ;             "CONTPTR"
+ ;        These optional subscripts to HLL are supported for input:
  ;             "SECURITY"
- ;             "SEQUENCE QUEUE" - queue used to maintain the order of the messages via application acks.  If used, the application MUST specify that both an accept ack and application ack be returned. 
+ ;              "CONTPTR"
+ ;              "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
  ;        
  ;   HLL  (optional, pass by reference) Additional message recipients being dynamically added
@@ -51,5 +50,4 @@
  . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR")
  . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE")
- . I $G(HLP("SEQUENCE QUEUE"))'="" S APPARMS("SEQUENCE QUEUE")=HLP("SEQUENCE QUEUE")
  . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE")
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -142,9 +142,9 @@
  .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY"))
  .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS
- I (STATUS="ER"),'SKIP D
+ I (STATUS="AE"),'SKIP D
  .N APP
- .S APP=HLMSTATE("HDR","RECEIVING APPLICATION")
+ .S APP=HLMSTATE("HDR","SENDING APPLICATION")
  .I APP="" S APP="UNKNOWN"
- .S ^HLB("ERRORS",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
+ .S ^HLB("ERRORS","AE",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
  .;don't count the error - the app ack was already counted as an error.
  .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -47,6 +47,6 @@
  .S ^HLB("B",ID,IEN)=""
  .S ^HLB("C",HLMSTATE("BODY"),IEN)=""
- .I ($G(@STAT)="ER") D
- ..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
+ .I ($G(@STAT)="SE") D
+ ..S ^HLB("ERRORS","SE",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
  ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
  .;
@@ -70,7 +70,4 @@
  ;The "SEARCH" x-ref will be created asynchronously
  S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
- ;
- ;sequence q?
- I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
  ;
  Q IEN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
+HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;03/28/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -115,5 +115,5 @@
  D DEQUE()
  ;
- ;may need to change the status to Error
+ ;may need to change the status to Application Error
  D
  .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW
@@ -121,6 +121,6 @@
  .S NODE=$G(^HLB(MSGIEN,0))
  .Q:NODE=""
- .Q:$P(NODE,"^",20)="ER"
- .S $P(NODE,"^",20)="ER",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
+ .Q:$P(NODE,"^",20)="AE"
+ .S $P(NODE,"^",20)="AE",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
  .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
  .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)
@@ -138,5 +138,5 @@
  .I RAPP="" S RAPP="UNKNOWN"
  .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
- .S ^HLB("ERRORS",RAPP,NOW,MSGIEN)=""
+ .S ^HLB("ERRORS","AE",RAPP,NOW,MSGIEN)=""
  .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN")
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -43,5 +43,4 @@
  ;     "PURGE" - scheduled purge dt/tm
  ;     "QUEUE" - the queue that the message was placed on
- ;     "SEQUENCE QUEUE" - the sequence queue (optional)
  ;
  K MSG
@@ -96,10 +95,4 @@
  .S MSG("MESSAGE TYPE")=$P(NODE,"^",3)
  .S MSG("EVENT")=$P(NODE,"^",4)
- I MSG("DIRECTION")="OUT" D
- .N NODE5
- .S NODE5=$G(^HLB(IEN,5))
- .S MSG("STATUS","SEQUENCE QUEUE")=$P(NODE5,"^")
- .S MSG("STATUS","MOVED TO OUT QUEUE")=$P(NODE5,"^",2)
- .S MSG("STATUS","SEQUENCE EXCEPTION RAISED")=$P(NODE5,"^",3)
  Q 1
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m	(revision 636)
@@ -1,5 +1,4 @@
-HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;07/20/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;05/03/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
  ;
  N SYSTEM,DATA,VASITE,OLDSITE
@@ -80,13 +79,2 @@
  S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0"
  Q
- ;
-P137 ;
- ;move the existing errros to the new structure
- N TYPE
- K ^TMP($J,"HLO ERRORS")
- F TYPE="TF","SE","AE" D
- .M ^TMP($J,"HLO ERRORS",TYPE)=^HLB("ERRORS",TYPE)
- .M ^HLB("ERRORS")=^TMP($J,"HLO ERRORS",TYPE)
- .K ^TMP($J,"HLO ERRORS",TYPE)
- .K ^HLB("ERRORS",TYPE)
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
+HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;04/30/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -28,5 +28,5 @@
  Q
 OLD778 ;
- N OLD,START,END,APP,TYPE,TODAY,PARMS
+ N OLD,START,END,APP,TYPE,TODAY
  S TODAY=$$DT^XLFDT
  S OLD=$$FMADD^XLFDT(TODAY,-45)
@@ -58,11 +58,10 @@
  ;
  ;also kill old errors left lying around
- D SYSPARMS^HLOSITE(.PARMS)
- S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
- S APP=""
- F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D
- .N TIME
+ F TYPE="TF","AE","SE" S APP="" F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D
+ .N TIME,PARMS
+ .D SYSPARMS^HLOSITE(.PARMS)
+ .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
  .S TIME=0
- .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",APP,TIME)
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",TYPE,APP,TIME)
  Q
 OLD777 ;
@@ -102,10 +101,12 @@
  ;if an error status,take care of the "ERRORS" x-ref
  I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
- .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
- .I MSG("STATUS")="ER" D
+ .N APP
+ .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP)
+ .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN)
+ .I MSG("STATUS")="AE" D
  ..N SUB
  ..S SUB=MSGIEN_"^"
- ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
- ..F  S SUB=$O(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
+ ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
+ ..F  S SUB=$O(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
  ;
  ;kill the whole-file xrefs for the message ien within a batch
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;07/31/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;01/05/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -90,131 +90,2 @@
  I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1
  Q 0
- ;
-SQUE(SQUE,LINKNAME,PORT,QNAME,IEN778) ;
- ;Will place the message=IEN778 on the sequencing queue. This is always done in the context of the application calling an HLO API to send a message.
- ;Input:
- ;  SQUE - name of the sequencing queue
- ;  LINKNAME = name of (.01) the logical link
- ;  PORT (optional) the port to connect to
- ;  QNAME (optional) outgoing queue
- ;  IEN778 = ien of the message in file 778
- ;Output: 1 if placed on the outgoing queue, 0 if placed on the sequence queue
- ;
- N NEXT,MOVED
- S MOVED=0
- ;
- ;keep a count of messages pending on sequence queues for the HLO System Monitor
- I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")))
- ;
- L +^HLB("QUEUE","SEQUENCE",SQUE):200
- ;
- S NEXT=+$G(^HLB("QUEUE","SEQUENCE",SQUE))
- Q:NEXT=IEN778 0  ;already queued!
- ;if the sequence queue is empty and not waiting on a message, then the message can be put directly on the outgoing queue, bypassing the sequence queue
- I '$O(^HLB("QUEUE","SEQUENCE",SQUE,0)),'NEXT D
- .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;to mean something moved to outgoing but not yet transmitted
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- .D OUTQUE(.LINKNAME,.PORT,.QNAME,IEN778)
- .S MOVED=1
- E  D
- .;Put the message on the sequence queue.
- .S ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)=""
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- Q MOVED
- ;
-ADVANCE(SQUE,MSGIEN) ;
- ;Will move the specified sequencing queue to the next message. 
- ;Input:
- ;  SQUE - name of the sequencing queue
- ;  MSGIEN - the ien of the message upon which the sequence queue was waiting.  If it is NOT the correct ien, then the sequence queue will NOT be advance.
- ;Output:
- ;  Function - 1 if advanced, 0 if not
- ;
- N NODE,IEN778,LINKNAME,PORT,QNAME
- Q:'$L($G(SQUE)) 0
- Q:'$G(MSGIEN) 0
- L +^HLB("QUEUE","SEQUENCE",SQUE):200
- ;
- ;do not advance if the queue wasn't pending the message=MSGIEN
- I (MSGIEN'=$P($G(^HLB("QUEUE","SEQUENCE",SQUE)),"^")) L -^HLB("QUEUE","SEQUENCE",SQUE) Q 0
- ;
- I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
- ;
- S IEN778=0
- ;look for the first message on the sequence que.  Make sure its valid, if not remove the invalid entry and keep looking.
- F  S IEN778=$O(^HLB("QUEUE","SEQUENCE",SQUE,0)) Q:'IEN778  S NODE=$G(^HLB(IEN778,0)) Q:$L(NODE)  D
- .;message does not exist! Remove from queue and try again.
- .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)
- .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
- ;
- ;IEN778 is the next pending msg on this sequence queue
- I IEN778 D
- .;
- .;parse out info needed to move to outgoing queue
- .S LINKNAME=$P(NODE,"^",5),PORT=$P(NODE,"^",8),QNAME=$P(NODE,"^",6)
- .;
- .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;indicates this sequence queue is now waiting for msg=IEN778 before advancing.  The second pieces is the timer, but will not be set until the message=IEN778 is actually transmitted.
- .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) ;remove from sequence queue
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- .S $P(^HLB(IEN778,5),"^",2)=1
- .D OUTQUE(.LINKNAME,$G(PORT),$G(QNAME),IEN778) ;move to outgoing queue
- E  D
- .K ^HLB("QUEUE","SEQUENCE",SQUE) ;this sequence queue is currently empty and not needed
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- Q 1
- ;
-SEQCHK(WORK) ;functions under the HLO Process Manager
- ;check sequence queues for timeout
- N QUE,NOW
- S NOW=$$NOW^XLFDT
- S QUE=""
- F  S QUE=$O(^HLB("QUEUE","SEQUENCE",QUE)) Q:QUE=""  D
- .N NODE,MSGIEN,ACTION,NODE
- .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
- .Q:'$P(NODE,"^",2)
- .Q:$P(NODE,"^",2)>NOW
- .Q:$P(NODE,"^",3)
- .L +^HLB("QUEUE","SEQUENCE",QUE):2
- .;don't report if a lock wasn't obtained
- .Q:'$T
- .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
- .I '$P(NODE,"^",2) L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .I ($P(NODE,"^",2)>NOW) L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .I $P(NODE,"^",3) L -^HLB("QUEUE","SEQUENCE",QUE) Q  ;exception already raised
- .S MSGIEN=$P(NODE,"^")
- .I 'MSGIEN L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .S ACTION=$$EXCEPT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))
- .S $P(^HLB(MSGIEN,5),"^",3)=1
- .S $P(^HLB("QUEUE","SEQUENCE",QUE),"^",3)=1 ;indicates exception raised
- .L -^HLB("QUEUE","SEQUENCE",QUE)
- .D  ;call the application to take action
- ..N HLMSGIEN,MCODE,DUZ,QUE,NOW
- ..N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOQUE"
- ..S HLMSGIEN=MSGIEN
- ..S MCODE="D "_ACTION
- ..N MSGIEN,X
- ..D DUZ^XUP(.5)
- ..X MCODE
- ..;kill the apps variables
- ..D
- ...N ZTSK
- ...D KILL^XUSCLEAN
- Q
-ERROR ;error trap for application context
- S $ETRAP="D UNWIND^%ZTER"
- D ^%ZTER
- S $ECODE=",UAPPLICATION ERROR,"
- ;
- ;kill the apps variables
- D
- .N ZTSK,MSGIEN,QUEUE
- .D KILL^XUSCLEAN
- ;
- ;release all the locks the app may have set, except Taskman lock
- L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1
- L:'$D(ZTSK)
- ;reset HLO's lock
- L +^HLTMP("HL7 RUNNING PROCESSES",$J):0
- ;return to processing the next message on the queue
- D UNWIND^%ZTER
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;07/19/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -56,5 +56,4 @@
  ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
  ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
- ..I $G(HLMSTATE("ACK TO","IEN")),$L($G(HLMSTATE("ACK TO","SEQUENCE QUEUE"))) D ADVANCE^HLOQUE(HLMSTATE("ACK TO","SEQUENCE QUEUE"),+HLMSTATE("ACK TO","IEN"))
  .E  D INQUE() H:HLCSTATE("CONNECTED") 1
  ;
@@ -138,5 +137,5 @@
  .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
  .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
- .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="ER"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="ER":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
+ .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="AE"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
  .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
  .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
@@ -151,5 +150,5 @@
  I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
  .N APP
- .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
+ .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
  .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
  ;
@@ -161,5 +160,5 @@
  .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
  .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
- .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1)
+ .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1)
  .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;07/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;03/26/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -52,8 +52,6 @@
  ....S HLMSTATE("ACK TO")=OLDMSGID
  ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
- ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER")
- ....I $G(IEN) D
- .....S HLMSTATE("ACK TO","IEN")=IEN
- .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
+ ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
+ ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
  ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
  ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
@@ -68,5 +66,5 @@
  .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
  .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
- .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER")
+ .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
  .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
  ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
@@ -127,5 +125,5 @@
  ;  HLMSTATE("HDR") - the parsed header segment
  ;Output:
- ;  HLMSTATE("STATUS")="ER" if an error is detected
+ ;  HLMSTATE("STATUS")="SE" if an error is detected
  ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
  ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
@@ -139,7 +137,7 @@
  E  D
  .S WANTACK=1
- I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q
+ I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
  I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
- .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q
+ .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
  .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
  E  D  Q:ERROR  ;this is an app ack
@@ -147,6 +145,6 @@
  .N NODE
  .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
- .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
- .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
+ .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
+ .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
  .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
  .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
@@ -154,5 +152,5 @@
  .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
  ;
- I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
+ I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
  ;
  ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
@@ -166,5 +164,5 @@
  .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
  .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
- I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
+ I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
  I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
  Q
@@ -215,7 +213,7 @@
  D END^HLOSRVR
  ;
- ;multi-listener should stop execution, only a single server may continue
+ ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
  I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
- .;don't log these errors
+ .;don't log these common errors
  .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
  ..;
@@ -223,10 +221,11 @@
  ..D ^%ZTER
  ;
- ;debugging?
+ ;while debugging quit on all errors
  I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
  ;
- ;possibly an endless loop?
+ ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count
  N HOUR
  S HOUR=$E($$NOW^XLFDT,1,10)
+ ;
  I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m	(revision 636)
@@ -1,5 +1,4 @@
-HLOSRVR2 ;ALB/CJM-HL7 - HLO Server ;07/20/2007
- ;;1.6;HEALTH LEVEL SEVEN;**131,137**;Oct 13, 1995;Build 21
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLOSRVR2 ;ALB/CJM-HL7 - Sends an application ack over an open connection, for original mode ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**131**;Oct 13, 1995;Build 10
  ;
 NEWMSG(HLCSTATE,HLMSTATE,HDR) ;
@@ -49,2 +48,46 @@
  S HLMSTATE("MSA",2)=HLMSTATE("ID")
  Q
+ ;
+ACKNOW(MSG,ERROR) ;
+ ;Sends the messge immediately if there is an open connection, otherwise
+ ;will return an error.
+ ;
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR2"
+ N SENT
+ S SENT=0,ERROR=""
+ I '$G(HLCSTATE("CONNECTED")) D
+ .S ERROR="NOT CONNECTED"
+ .S MSG("STATUS")="TF"
+ E  S MSG("STATUS")="SU"
+ S:'$G(MSG("DT/TM CREATED")) MSG("DT/TM CREATED")=$$NOW^XLFDT
+ S MSG("STATUS","PURGE")=$$FMADD^XLFDT(MSG("DT/TM CREATED"),$S($G(HLCSTATE("ERROR PURGE")):HLCSTATE("ERROR PURGE"),1:7))
+ D
+ .I $G(MSG("UNSTORED LINES")),'$$SAVEMSG^HLOF777(.MSG) S ERROR="$$SAVE^HLOF777 FAILED!" Q
+ .I '$$SAVEMSG^HLOF778(.MSG) S ERROR="$$SAVE^HLOF778 FAILED!" Q
+ .Q:MSG("STATUS")'="SU"
+ .I '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.MSG) S ERROR="TRANSMISSION FAILURE" Q
+ .S SENT=1
+ .D COUNT^HLOSTAT(.HLCSTATE,ACK("HDR","RECEIVING APPLICATION"),ACK("HDR","SENDING APPLICATION"),ACK("HDR","MESSAGE TYPE")_"~"_ACK("HDR","EVENT"))
+ ;
+END ;
+ I 'SENT,MSG("STATUS")="SU",$G(MSG("IEN")) D
+ .Q:'$D(^HLB(MSG("IEN"),0))
+ .S MSG("STATUS")="TF"
+ .S MSG("STATUS","ERROR TEXT")=ERROR
+ .S $P(^HLB(MSG("IEN"),0),"^",20)=MSG("STATUS")
+ .S $P(^HLB(MSG("IEN"),0),"^",21)=MSG("STATUS","ERROR TEXT")
+ .S ^HLB("ERRORS","TF",$S($L($G(MSG("HDR","RECEIVING APPLICATION"))):MSG("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),MSG("DT/TM CREATED"),IEN)=""
+ ;
+ Q SENT
+ ;
+ERROR ;error trap for ACKNOW
+ S SENT=0,ERROR="TRANSMISSION FAILURE:"_$P($ECODE,",",1,2)
+ S $ETRAP="D UNWIND^%ZTER"
+ ;
+ ;don't log some common errors
+ I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+ .;nothing!
+ E  D
+ .D ^%ZTER
+ G END^HLOSRVR2
+ Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
+HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -129,8 +129,8 @@
  ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
  ..F  Q:'(J+$L(LINE)>MAX)  D
- ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
+ ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
  ...S LINE=$E(LINE,(MAX-J)+1,99999)
  ...S J=0
- ..I (LINE]"") W LINE S HLCSTATE("FLUSHED")=0
+ ..W:(LINE]"") LINE
  K HLCSTATE("BUFFER")
  S HLCSTATE("BUFFER","SEGMENT COUNT")=1
@@ -203,4 +203,4 @@
  .D FLUSH
  .U HLCSTATE("DEVICE")
- .I ('$G(HLCSTATE("FLUSHED")))!$X W @HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
+ .W:$X @HLCSTATE("FLUSH")
  Q 0
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m	(revision 636)
@@ -1,4 +1,22 @@
-HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004  14:43
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131**;Oct 13, 1995;Build 10
+HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004  14:43 ;1/23/07  16:59
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,135**;Oct 13, 1995;Build 10
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ;;  VWSD LOGICAL TO ALLOW A NON-VA STATION ( NODE )WITH $D(HLVWNOVA) VARIABLE EXIST FOR HL LOGICAL LINKS
  ;
 SETSHUT(LINKIEN) ;
@@ -64,10 +82,13 @@
  ;reserved for officially released links associated with VHA institutions
  ;** EXCEPTION** MPIVA is an official link associated with 200M
- ;
+ ;***LOCAL VWSD - ALLOW NON-VA STATION (NODE) AS VARIABLE HLVWNOVA TO BE USED TO DETERMINE FACILITY LINK
  Q:'$L($G(STATN)) 0
  ;
  N NAME,IEN
  S (NAME,IEN)=""
- F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),($E(NAME,1,2)="VA")!(NAME="MPIVA") S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ ; START LOCAL MOD VWSD FLAG HLVWNOVA
+ ; F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),($E(NAME,1,2)="VA")!(NAME="MPIVA") S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),(($E(NAME,1,2)="VA")!(NAME="MPIVA"))!$D(HLVWNOVA) S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ ;END LOCAL MOD
  Q IEN
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m	(revision 636)
@@ -1,25 +1,24 @@
-HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;07/30/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
+HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;02/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
 EN ;
  ;
- N HLSCREEN,TESTOPEN,HLRFRSH,HLPARMS
+ N HLSCREEN,TESTOPEN,HLRFRSH
  D WAIT^DICD
  D EN^VALM("HLO SYSTEM MONITOR")
  Q
  ;
-BRIEF ;
+BRIEF ;Init variables and list array
  N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST
  S HLRFRSH="BRIEF^HLOUSR"
  S (HLSCREEN,VALMSG)="Brief System Status"
- S VALMCNT=16
+ S VALMCNT=8
  ;K @VALMAR
  D CLEAN^VALM10
  S VALMBG=1
  S VALMBCK="R"
- S VALMDDF("COL 1")="COL1^1^80^"
  K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5")
- D CHGCAP^VALM("COL 1"," Brief Operational Overview")
+ D CHGCAP^VALM("COL 1","Brief Operational Overview")
  S @VALMAR@(1,0)="SYSTEM STATUS:             "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING")
  S @VALMAR@(2,0)="PROCESS MANAGER:           "_$S($$RUNNING:"RUNNING",1:"STOPPED")
@@ -55,5 +54,5 @@
  ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
  ..S:TEMP>0 COUNT=COUNT+TEMP
- S @VALMAR@(8,0)="MESSAGES PENDING ON OUT QUEUES:    "_$$RJ(+COUNT,7)_"     ON SEQUENCE QUEUES:  "_$$RJ(+$G(^HLC("QUEUECOUNT","SEQUENCE")),7)
+ S @VALMAR@(8,0)="MESSAGES PENDING TRANSMISSION:      "_+COUNT
  S TEMP="STOPPED OUTGOING QUEUES: "
  S COUNT=0,QUE=""
@@ -66,5 +65,5 @@
  ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM))
  ..S:TEMP>0 COUNT=COUNT+TEMP
- S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_$$RJ(+COUNT,7)
+ S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS:   "_+COUNT
  S TEMP="STOPPED INCOMING QUEUES: "
  S COUNT=0,QUE=""
@@ -93,14 +92,15 @@
  Q TOTAL
  ;
-HELP ;
+HELP ;Help code
  S X="?" D DISP^XQORM1 W !!
  Q
  ;
-EXIT ;
+EXIT ;Exit code
  D CLEAN^VALM10
  D CLEAR^VALM1
- Q
- ;
-EXPND ;
+ ;
+ Q
+ ;
+EXPND ;Expand code
  Q
  ;
@@ -111,5 +111,4 @@
  S VALMCNT=0
  S VALMBCK="R"
- S VALMDDF("COL 1")="COL1^1^34^"
  S VALMDDF("COL 2")="COL 2^35^10^MIN^H"
  S VALMDDF("COL 3")="COL 3^47^10^MAX^H"
@@ -194,5 +193,5 @@
  S VALMBCK="R"
  ;
- ;currently HL7 (Optimized) only does TCP
+ ;currently HL7 (Optimized) only does TCP, when serial added a change is needed here
  S LINK=$$ASKLINK
  Q:LINK=""
@@ -215,5 +214,5 @@
  Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN)
  ;
-RUNNING() ;Process Manager running?
+RUNNING() ;Is the Process Manager running?
  N RUNNING
  L +^HLTMP("PROCESS MANAGER"):0
@@ -257,31 +256,27 @@
  Q
  ;
-UPDMODE ;realtime
+UPDMODE ;update mode
  Q:'$L(HLRFRSH)
- N TOP,BOTTOM,DX,DY,IOTM,IOBM,LINE,OLD,OLDCNT
- S OLDCNT=VALMCNT
- W !!!!!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
- S IOTM=20,IOBM=23 W @IOSTBM
+ N QUIT,NEW,TOP,BOTTOM,DX,DY,IOTM,IOBM,I
+ W !!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
+ S IOTM=3,IOBM=23
+ W @IOSTBM
+ S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY
+ I VALMCNT>16 F I=17:1:$S(VALMCNT<22:VALMCNT,1:21) W !,@VALMAR@(I,0)
+ S QUIT=0
  S TOP=VALMBG
- S BOTTOM=TOP+20
- F LINE=TOP:1:BOTTOM D
- .I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
- .S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
- F LINE=TOP:1:BOTTOM D
- .S OLD(LINE)=@VALMAR@(LINE,0)
- F LINE=17:1:BOTTOM D
- .S DX=50,DY=22 X IOXY W !
- .D WRITE^VALM10(LINE)
- D  F  R *C:4 Q:$T  D
+ S BOTTOM=TOP+23
+ S OLD=VALMAR
+ S VALMAR="NEW"
+ S VALMCNT=0
+ F  D  Q:QUIT
+ .N LINE
+ .R *C:3 I $T S QUIT=1
+ .S (VALMCNT,I)=0
  .D @HLRFRSH
- .F LINE=TOP:1:BOTTOM D
- ..I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
- ..S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
- .S VALMCNT=BOTTOM
- .F LINE=TOP:1:BOTTOM IF OLD(LINE)'=@VALMAR@(LINE,0) D
- ..S OLD(LINE)=@VALMAR@(LINE,0)
- ..S DX=50,DY=22 X IOXY W !
+ .F LINE=TOP:1:BOTTOM IF $G(@OLD@(LINE,0))'=$G(@VALMAR@(LINE,0)) D
+ ..S:'$D(@VALMAR@(LINE,0)) @VALMAR@(LINE,0)=" "
  ..D WRITE^VALM10(LINE)
- S VALMCNT=OLDCNT
- S VALMBCK="R"
- Q
+ K @OLD M @OLD=@VALMAR S VALMAR=OLD
+ S VALMBCK="R"
+ Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -101,8 +101,6 @@
  S @VALMAR@($$I,0)="Dir:   "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ("  Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ("  Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2)
  S @VALMAR@($$I,0)="Link:  "_$$LJ(MSG("STATUS","LINK NAME"),29)_"   "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE")
- I $L($G(MSG("STATUS","SEQUENCE QUEUE"))) D
- .S @VALMAR@($$I,0)="Sequence Queue: "_MSG("STATUS","SEQUENCE QUEUE")_"    Moved: "_$S(MSG("STATUS","MOVED TO OUT QUEUE"):"YES",1:"NO")
  I MSG("STATUS","ACCEPT ACK'D") D
- .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" DT/TM Ack'd: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
+ .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" At: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
  .S @VALMAR@($$I,0)="   "_MSG("STATUS","ACCEPT ACK MSA")
  I MSG("DIRECTION")="IN" D
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;07/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified
  ;
@@ -8,5 +8,6 @@
  Q
  ;
-SHOWLIST ;
+SHOWLIST(TYPE) ;
+ ;TYPE= "SE", "AE", "TF"
  N PARMS,I,ERRCOUNT
  S (VALMBG,VALMCNT,I,ERRCOUNT)=0
@@ -17,11 +18,11 @@
  .N APP
  .S APP=""
- .F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
+ .F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
  ..N TIME,IEN
  ..S TIME=PARMS("START")
- ..Q:($O(^HLB("ERRORS",APP,TIME))="")
+ ..Q:($O(^HLB("ERRORS",TYPE,APP,TIME))="")
  ..S @VALMAR@($$I,0)="Application: "_APP
  ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
- ..F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ ..F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
  E  D
  .N APP
@@ -29,40 +30,44 @@
  .N TIME,IEN
  .S TIME=PARMS("START")
- .Q:$O(^HLB("ERRORS",APP,TIME))=""
+ .Q:$O(^HLB("ERRORS",TYPE,APP,TIME))=""
  .S @VALMAR@($$I,0)="Application: "_APP
  .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
- .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
  ;
 SHOW S VALMBCK="R"
  ;
  Q
-ADDTO(IEN,TIME,ERRCOUNT) ;
+ADDTO(LTYPE,IEN,TIME,ERRCOUNT) ;
  N NODE,MSG
  Q:'$$GETMSG^HLOMSG(+IEN,.MSG)
  S ERRCOUNT=ERRCOUNT+1
- ;application errors could be an error to a msg within a batch
- ;also, need to go to the ack msg to get the error text from the MSA segment
- ;
- N SUBIEN,MSA,ERRTEXT
- S (ERRTEXT,MSA)=""
- S SUBIEN=$P(IEN,"^",2)
- ;within batch?
- D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
- S ERRTEXT=MSG("STATUS","ERROR TEXT")
- I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
- .N MSG,SEG,FS,AIEN
- .S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
- .Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
- .I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
- .F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
- I ERRTEXT="",MSG("ACK BY")="" D
- .N FS
- .S FS=$E(MSG("HDR",1),4)
- .I $L(FS) S ERRTEXT=$P($G(MSG("STATUS","ACCEPT ACK MSA")),FS,4)
- S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,35)
- D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
- I $L(ERRTEXT)>35 D
- .S @VALMAR@($$I,0)=$$RJ(" ",45)_$E(ERRTEXT,36,115)
- S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ I LTYPE'="AE" D
+ .N TYPE
+ .S TYPE=$S(MSG("BATCH"):"BATCH",1:MSG("MESSAGE TYPE")_"~"_MSG("EVENT"))
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(TYPE,8)_$$LJ($$FMTE^XLFDT(TIME,2),20)_MSG("STATUS","ERROR TEXT")
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ E  D
+ .;application errors - could be an error to a msg within a batch
+ .;also, need to go to the ack msg to get the error text from the MSA segment
+ .;
+ .N SUBIEN,MSA,ERRTEXT
+ .S (ERRTEXT,MSA)=""
+ .S SUBIEN=$P(IEN,"^",2)
+ .;within batch?
+ .D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+ .S ERRTEXT=MSG("STATUS","ERROR TEXT")
+ .I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
+ ..N MSG,SEG,FS,AIEN
+ ..S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
+ ..Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
+ ..I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
+ ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,37)
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .I $L(ERRTEXT)>37 D
+ ..S @VALMAR@($$I,0)="~"_$E(ERRTEXT,38,112)
+ ..D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
  Q
  ;
@@ -95,6 +100,8 @@
  N DIR
  S DIR(0)="F^3:60"
- S DIR("A")="Receiving Application"
+ S DIR("A")="Application"
  S DIR("?")="Enter the full name of the application, or '^' to exit."
+ S DIR("?",1)="For transmission failures, enter the sending application. "
+ S DIR("?",2)="For other errors, enter the name of the receiving application. "
  D ^DIR
  I $D(DIRUT)!(Y="") Q ""
@@ -221,6 +228,4 @@
 LJ(STRING,LEN) ;
  Q $$LJ^XLFSTR(STRING,LEN)
-RJ(STRING,LEN) ;
- Q $$RJ^XLFSTR(STRING,LEN)
  ;
 I() ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m	(revision 636)
@@ -1,8 +1,4 @@
-HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;10/17/2007  09:41
- ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- Q
- ;
+HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;01/23/06  12:56
+ ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120**;Oct 13, 1995;Build 12
 FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only
  D CREATE(,.HLDA,.HLDT,.HLDT1)
@@ -75,11 +71,5 @@
 MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.)
  ;return ien in file 773
- ;
- ; patch HL*1.6*122: MPI-client/server start
- F  L +^HL(772,+$G(X)):10 Q:$T  H 1
  Q:'$G(^HL(772,X,0)) 0
- L -^HL(772,+$G(X))
- ; patch HL*1.6*122: MPI-client/server end
- ;
  N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y
  S DIC="^HLMA(",DIC(0)="L"
@@ -118,26 +108,85 @@
 OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message
  ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D OUT^HLTF2($G(HLDA),$G(HLMID),$G(HLMTN))
+ Q:'$D(HLFS)
+ ;
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
+ ;
+ ;-- if message contained MSA find inbound message
+ I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
+ . N HLDAI
+ . S HLDAI=0
+ . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
+ . I 'HLDAI K HLDAI
+ ;
+ D STUFF^HLTF0("O")
+ ;
+ N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
+ ;
+ ;-- update status if MSA and found inbound message
+ I $D(HLMSA),$D(HLDAI) D
+ .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2)
+ .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
  Q
  ;
 IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message
  ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D IN^HLTF2($G(HLMTN),$G(HLMID),$G(HLTIME))
+ Q:'$D(HLFS)
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
+ ;
+ N HLDAI S HLDA=0
+ I $D(HLNDAP),HLMID]"" D
+ .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
+ .I HLDA D
+ ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
+ ..K ^HL(772,HLDA,"IN")
+ .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
+ ..S HLDAI=0
+ ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
+ ..I 'HLDAI K HLDAI
+ ;
+ I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
+ ;
+ D STUFF^HLTF0("I")
+ N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ ;
+ D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
+ ;
+ I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
+ .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
  Q
  ;
 ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D ACK^HLTF2($G(HLMSA),$G(HLIO),$G(HLDA))
+ ; To determine the correct message to link the ACK, HLIO is used.
+ ; For an ack from DHCP (original message from remote system) then
+ ; HLIO should be "I" so that the correct inbound message is ack-ed. For
+ ; an inbound ack (original message outbound from DHCP) HLIO should be
+ ; "O". This distinction must be made due to the possible duplicate
+ ; message ids from a bi-direction interface.
+ ;
+ ; Input : MSA - MSA from ACK message.
+ ;         HLIO - Either "I" or "O" : See note above.
+ ;Output : None
+ ;
+ N HLAC,HLMIDI
+ ;-- set up required vars
+ S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
+ ;-- quit
+ Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
+ ;-- find message to ack
+ I '$G(HLDA) S HLDA=0 D
+ . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
+ ;-- quit if no message
+ Q:'$D(^HL(772,+HLDA,0))
+ ;-- check for error
+ I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
+ I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
+ ;-- update status
+ S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
+ D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
  Q
  ;
@@ -152,16 +201,12 @@
  I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
  ;
- I OS'["DSM",OS'["OpenM" D
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
  .F  L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN
  E  D
  .F  S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN
- ;
- ; patch HL*1.6*122: MPI-client/server start
- F  L +^HL(772,IEN):10 Q:$T  H 1
  S ^HL(772,IEN,0)=$G(FLD01)_"^"
  I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)=""
- L -^HL(772,IEN)
- ; patch HL*1.6*122: MPI-client/server end
- ;
  Q IEN
  ;
@@ -176,14 +221,11 @@
  I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
  ;
- I OS'["DSM",OS'["OpenM" D
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
  .F  L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN
  E  D
  .F  S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA(IEN):10 Q:$T  H 1
  S ^HLMA(IEN,0)=$G(FLD01)_"^"
  I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)=""
- L -^HLMA(IEN)
- ;
  Q IEN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m	(revision 636)
@@ -1,6 +1,4 @@
-HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:43
- ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;09/10/98  11:21
+ ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78**;Oct 13, 1995
 MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into
  ;Message Text File
@@ -69,7 +67,4 @@
  N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
  ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
- ;
  ;Merge data from a global array with two subscript
  I ARAYTYPE="G",$G(SUB2)'="" D
@@ -105,7 +100,4 @@
  ;-- update 0 node for message text
  S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
- ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HL(772,+$G(MTIEN))
  ;
  ;File message statistics
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m	(revision 636)
@@ -1,6 +1,4 @@
-HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:44
- ;;1.6;HEALTH LEVEL SEVEN;**25,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97  13:56
+ ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995
 MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server
  ;Module Logical Link File into Message Text File
@@ -27,7 +25,4 @@
  N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE
  S (FLG,HLCHAR,HLEVN,X)=0
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
  ;
  ;Move data from Logical Link file to Message Text file
@@ -56,8 +51,4 @@
  S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
  ;Update statistics in Message Text file for this entry
- ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HL(772,+$G(MTIEN))
- ;
  D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
  Q
@@ -89,7 +80,4 @@
  S I=0
  ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLCS(870,+$G(LLD0),2,+$G(LLD1)):10 Q:$T  H 1
- ;
  ;-- move header into 870 from HDR array
  S X="" F  S X=$O(@HDR@(X)) Q:'X  D
@@ -104,105 +92,3 @@
  S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
  ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HLCS(870,+$G(LLD0),2,+$G(LLD1))
- ;
  Q
-OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message
- ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- Q:'$D(HLFS)
- ;
- I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
- ;
- ;-- if message contained MSA find inbound message
- I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
- . N HLDAI
- . S HLDAI=0
- . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
- . I 'HLDAI K HLDAI
- ;
- D STUFF^HLTF0("O")
- ;
- N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
- ;
- ;-- update status if MSA and found inbound message
- I $D(HLMSA),$D(HLDAI) D
- .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
- .S HLAC=$P(HLMSA,HLFS,2)
- .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
- .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
- Q
- ;
-IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message
- ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- Q:'$D(HLFS)
- I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
- ;
- N HLDAI S HLDA=0
- I $D(HLNDAP),HLMID]"" D
- .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
- .I HLDA D
- ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
- ..K ^HL(772,HLDA,"IN")
- .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
- ..S HLDAI=0
- ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
- ..I 'HLDAI K HLDAI
- ;
- ; patch HL*1.6*122: MPI-client/server
- ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
- I 'HLDA D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
- ;
- D STUFF^HLTF0("I")
- N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- ;
- D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
- ;
- I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
- .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
- .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
- .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
- Q
- ;
-ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- ; To determine the correct message to link the ACK, HLIO is used.
- ; For an ack from DHCP (original message from remote system) then
- ; HLIO should be "I" so that the correct inbound message is ack-ed. For
- ; an inbound ack (original message outbound from DHCP) HLIO should be
- ; "O". This distinction must be made due to the possible duplicate
- ; message ids from a bi-direction interface.
- ;
- ; Input : MSA - MSA from ACK message.
- ;         HLIO - Either "I" or "O" : See note above.
- ;Output : None
- ;
- N HLAC,HLMIDI
- ;-- set up required vars
- S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
- ;-- quit
- Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
- ;-- find message to ack
- I '$G(HLDA) S HLDA=0 D
- . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
- ;-- quit if no message
- Q:'$D(^HL(772,+HLDA,0))
- ;-- check for error
- I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
- I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
- ;-- update status
- S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
- D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- Q
- ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m	(revision 636)
@@ -1,9 +1,9 @@
-HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;10/05/2007  15:17
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122**;Oct 13, 1995;Build 14
+HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  Q
-NEW(X) ;process new msg. ien in 773^ien in 772
- ;HLMTIENS=ien in #773; HLMTIEN=ien in #772
+NEW(X) ;process new msg. ien in 773^msg. ien in 772
+ ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text
  ;HLHDRO=original header;  HLHDR=response header
  ;set error trap
@@ -21,13 +21,14 @@
  . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
  . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
- . ;write ack back
+ . ;write ack back over connection
  . S X=$$WRITE^HLCSTCP2(HLTCP)
  . ;update counter to sent
  . D LLCNT^HLCSTCP(HLDP,4)
- . ;update status of ack
+ . ;update status of ack to complete
  . D STATUS^HLTF0(HLTCP,3,,,1)
  ;
  ;check for duplicate msg., use rec. app and msg. id x-ref
  ; patch HL*1.6*120
+ ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
  I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
  . ;HLASTMSG=last ien received during this connection
@@ -41,14 +42,14 @@
  .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
  .;
- . ;msg is duplicate, set status
+ . ;msg is duplicate, set status as duplicate
  . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
- . ;msg was resent, ignore it.
+ . ;msg was resent during this connection, ignore it.
  . I HLASTMSG=HLMTIENS K HLMTIENS Q
  . ;find original response and send back
  . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
  ;
- ;Quit if this is ack to ack
+ ;Quit if this is acknowledgment to acknowledgement message
  I $G(HL("ACK")) D  Q
- . ;Update status of original ack message
+ . ;Update status of original acknowledgment message to successfully
  . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
  . ;unlock record
@@ -76,5 +77,6 @@
  ; patch HL*1.6*120 start
  ;resending old response, msg is a resend
- ; do not re-send duplicate when $G(HL("ACAT"))="AL"
+ ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK
+ ; do not re-send duplicate message when $G(HL("ACAT"))="AL"
  I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
  ; quit if duplicate
@@ -90,9 +92,9 @@
  . ;X=1 if ack ok, 0=reject of error
  . S X=$E(HLMSA,2)="A"
- . ;Update status of original message and remove it from the queue
+ . ;Update status of original subscriber message and remove it from the out-going queue
  . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
  . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
  . D
- .. N HLTCP ;variable to update status in file #772.
+ .. N HLTCP ;New variable to update status in file #772.
  ..;
  ..;**108**
@@ -104,5 +106,5 @@
  ..;
  .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
- . ;update status of incoming & unlock
+ . ;update status of incoming to complete & unlock
  . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
  ;
@@ -123,5 +125,5 @@
  ;update status of incoming to complete & unlock
  D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
- ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
+ ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK
 ACK I $G(HLTCPO),$G(HLTCP) D  Q
  . D LLCNT^HLCSTCP(HLDP,3)
@@ -137,5 +139,5 @@
  ;
  ; patch HL*1.6*120 start
- ; clean non-Kernel variables
+ ; clean variables except Kernel related variables
  D
  . ; protect variables defined in STARTIN^HLCSIN
@@ -152,7 +154,10 @@
  N HLERR     ;patch HL*1.6*109
  Q:'$G(HLDP)!'$G(X)  Q:'$G(^HLMA(X,0))
+ ;**109 START**
  Q:'$D(^HLMA("AC","I",HLDP,X))
+ ;**109 END**
  ;
  N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+ ;setup variables
  S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
  S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
@@ -164,12 +169,16 @@
  M HLHDRO=^HLMA(HLMTIENS,"MSH")
  ; if no header quit
+ ;**109**
+ ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q
  Q:'$O(HLHDRO(0))
  ;
  S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
  ;
+ ; patch HL*1.6*109 start
  ; quit if ien of #772 is not defined
  Q:'HLMTIEN
  ; quit if field separator is not defined
  Q:HL("FS")=""
+ ; patch HL*1.6*109 end
  ;
  S X=$$P^HLTPCK2(.HLHDRO,1)
@@ -187,5 +196,5 @@
  . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
  . ;
- . ; original code incorrectly treats repetition separator as
+ . ; original implementation incorrectly treats repetition separator as
  . ; subcomponent separator
  . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
@@ -206,9 +215,12 @@
  . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
  ;
+ ; HL*1.6*108
  ; quit if this is a commit ack
  I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
+ ; ** 
  ;
  ;**  HL*1.6*117 **
  K HLL("SET FOR APP ACK"),HLL("LINKS")
+ ;** END HL*1.6*117 **
  ;
  D CONT
@@ -217,19 +229,6 @@
 MSA(Y) ;Y=ien in 772, returns MSA segment
  ;ack code^msg being ack id^text
- ; patch HL*1.6*122
- ; for HL7 v2.5 and beyond with MSA as 3rd segment
- N X,SUBIEN,DATA,DONE
+ N X
  S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
- Q:X]"" X
- ;
- S DONE=0
- S SUBIEN=1
- F  S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN  D  Q:DONE
- . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D
- .. S DONE=1
- .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN
- .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
- ; patch HL*1.6*122 end
- ;
  Q X
  ;
@@ -237,5 +236,5 @@
  D ^%ZTER
  I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
- ; release locks created by inbound filer
+ ;*109* release all locks created by inbound filer
  L -^HLMA("AC","I",+$G(HLXX))
  G UNWIND^%ZTER
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m	(revision 636)
@@ -1,4 +1,4 @@
-HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;10/04/2007  16:00
- ;;1.6;HEALTH LEVEL SEVEN;**120,133,122**;Oct 13, 1995;Build 14
+HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,14 +23,9 @@
  . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
  . ;if no subscriber protocol then response msg. is invalid
- . ;
- . ; patch HL*1.6*122 start
- . ; comment out the following code: for patch 109- dynamic addressing
- . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
+ . I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
  . ;get message text ien in file 772 and server protocol, 'EID'
  . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
  . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
- . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
- . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
- . ; patch HL*1.6*122 end
+ . D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
  ;
  ;Find Server Protocol - based on sending application, message type,
