Changeset 636 for FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (15 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 49 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
HEALTH_LEVEL_SEVEN-HL/HLCS.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCS2.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSIN.m (modified) (6 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m (modified) (8 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSMON.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSREP.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m (modified) (9 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m (modified) (6 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m (modified) (10 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLDIE.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLFNC.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLMA.m (modified) (8 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOAPP.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOF778.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOF778A.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOFILER.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOMSG.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOPOST.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m (modified) (4 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOQUE.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m (modified) (10 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOTCP.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOUSR.m (modified) (8 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m (modified) (2 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m (modified) (6 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLTF.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLTF1.m (modified) (3 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLTF2.m (modified) (5 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLTP3.m (modified) (14 diffs)
-
HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m
r628 r636 1 HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/ 04/2007 14:342 ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132 ,122**;Oct 13, 1995;Build 141 HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/31/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132**;Oct 13, 1995;Build 6 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 48 48 .N I,EXCLUDE 49 49 .S (EXCLUDE,I)=0 50 . ; 51 . ; patch HL*1.6*122 52 . ; F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q 53 . F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I D Q:EXCLUDE 54 .. N TEMP 55 .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I) 56 .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0)) 57 .. I TEMP=HLEIDS S EXCLUDE=1 58 . ; patch HL*1.6*122 59 . ; 50 .F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q 60 51 .Q:EXCLUDE 61 52 .;** 132 end ** -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m
r628 r636 1 HLCS2 ;SF/JC - More Communication Server utilities ; 10/04/2007 14:31 2 ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/2003 17:50 2 ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109**;Oct 13, 1995 4 3 FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array 5 4 ;This enhancement also supports distribution of a message to … … 10 9 . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2) 11 10 . Q:PTR="" I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1 12 . ;13 . ; patch HL*1.6*122: excluding subscribers defined in14 . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber15 . N I,EXCLUDE16 . S (EXCLUDE,I)=017 . F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I D Q:EXCLUDE18 .. N TEMP19 .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)20 .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))21 .. I TEMP=PTR S EXCLUDE=122 . Q:EXCLUDE23 . ;24 11 . Q:LNK="" I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1 25 12 . Q:'$D(^HLCS(870,LNK)) 26 13 . S CLIAP=$$PTR^HLUTIL2(PTR) 27 . ; patch HL*1.6*122: add the 3rd component as receiving facility 28 . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"") 29 . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3)) 14 . S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"") 30 15 Q 31 16 ADD ;Deliver message to supplemental client list. … … 39 24 ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK) 40 25 ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q 41 .. ; patch HL*1.6*122 start 42 .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1) 43 .. S HLOGLINK=ZLOGLINK 44 .. ; 3rd component for receiving facility 45 .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3) 46 .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK) 47 .. D STATUS^HLTF0(+ZMTIENS,1) 48 .. ; patch HL*1.6*122 end 49 .. ; 26 ..S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1) 50 27 K HLL("LINKS"),HLSUP 51 28 Q … … 95 72 . I 'ALL&('$P(HLDP0,U,6)) Q 96 73 . S HLPARM4=$G(^HLCS(870,HLDP,400)) 97 . ; patch HL*1.6*122 98 . ; TCP Multi listener: quit if TCP service as GT.M, DSM, 99 . ; or Cache/VMS 74 . ;TCP Multi listener for non-Cache uses UCX 100 75 . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" 101 . ;102 76 . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown? 103 . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 104 . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting" 77 . S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 105 78 . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown" 106 79 . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109 80 . ;Cache system, need to open TCP port to release job 107 81 . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D 108 .. ; 82 .. ;pass task number to stop listener 109 83 .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12)) 110 ; patch HL*1.6*122 start 111 ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) 112 ; .. I POP D HOME^%ZIS Q 113 ; .. D CLOSE^%ZISTCP 114 ; patch HL*1.6*122 end 84 .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) 85 .. I POP D HOME^%ZIS Q 86 .. D CLOSE^%ZISTCP 115 87 Q 116 88 STRT ;Start Links … … 126 98 . Q:'HLTYPTR!(HLBGR="") 127 99 . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT) 128 . ; patch HL*1.6*122 129 . ; TCP Multi listener: quit if TCP service as GT.M, DSM, 130 . ; or Cache/VMS 100 . ;TCP Multi listener for non-Cache uses UCX 131 101 . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" 132 . ;133 102 . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D Q 134 103 .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m
r628 r636 1 1 HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 142 ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 4;WorldVistA 30-Jan-08 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 7 7 ; number. 8 8 ; 2. find the ien of #870(logical link file) for the multi-listener 9 ;Modified from FOIA VISTA, 10 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 11 ;General Public License See attached copy of the License. 12 ; 13 ;This program is free software; you can redistribute it and/or modify 14 ;it under the terms of the GNU General Public License as published by 15 ;the Free Software Foundation; either version 2 of the License, or 16 ;(at your option) any later version. 17 ; 18 ;This program is distributed in the hope that it will be useful, 19 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 20 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21 ;GNU General Public License for more details. 22 ; 23 ;You should have received a copy of the GNU General Public License along 24 ;with this program; if not, write to the Free Software Foundation, Inc., 25 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 9 26 Q 10 27 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m
r628 r636 1 HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;0 4/17/20072 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133 ,122**;Oct 13, 1995;Build 141 HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment … … 147 147 S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4) 148 148 S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8) 149 ;150 ; patch HL*1.6*122151 ; setting the MSH-15 and MSH-16 from subscriber protocol152 I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D153 . S ACCACK=$P(PROTS,U,7)154 . S APPACK=$P(PROTS,U,8)155 ;156 149 PID ;Processing ID 157 150 ;I PID not 'debug' get from site params -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m
r628 r636 1 HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05 2 ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified 1 HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;3/24/2004 14:27 2 ;;1.6;HEALTH LEVEL SEVEN;**93,108**;Oct 13, 1995 4 3 ; 5 4 DEBUG(STORE) ; If HLP set up for debugging, capture VIEW... … … 112 111 ; Change was made, but not by M code. Must be by array... 113 112 S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A" 114 ;115 ; patch HL*1.6*122: for "^" as component separater116 S $P(HLMSH91,U,PCE+2,999)=""117 113 ; 118 114 ; Upgrade ^HLMA(#,0)... -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m
r628 r636 1 HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;10/17/2007 14:58 2 ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;11/15/2000 09:37 2 ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oct 13, 1995 4 3 STARTIN ;Main entry point for incoming background filer 5 4 ;Create/find entry denoting this filer in the INCOMING FILER TASK 6 5 ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER 7 6 ; file (#869.3) 7 ;N HLOGLINK,HLNODE,HLPARENT,HLST1,TMP ; These vbls aren't used! 8 8 N HLFLG,HLEXIT,HLPTRFLR 9 ;10 ; patch HL*1.6*12211 ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed12 N HLDUZ13 S HLDUZ=+$G(DUZ)14 ;15 9 S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN") 16 10 ;Loop through Logical Links and check for incoming messages 17 11 S HLEXIT=0 18 ; patch HL*1.6*122 TEST v2: DUZ code removed19 ; patch HL*1.6*122, set DUZ for application proxy user20 ;; D PROXY^HLCSTCP421 S HLPTRFLR("$J")=$J22 12 F D Q:HLEXIT 23 13 . S HLFLG=0 … … 28 18 . . S HLPTRFLR("LASTDEL")=$H ; maintain queue sizes 29 19 . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour. 30 . ; patch HL*1.6*122 31 . ; H 5 32 . H 1 20 . H 5 33 21 . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 34 22 S ZTSTOP=1 ;Asked to stop … … 40 28 S HLXX=0 41 29 F S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX D Q:HLEXIT 42 . ; HL*1.6*122, check the in-queue stop flag43 . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)44 30 . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 45 . ; patch HL*1.6*109: Does another filer have this? 46 . ; L +^HLMA("AC","I",HLXX):0 Q:'$T 47 . L +^HLMA("AC","I",HLXX):2 Q:'$T ; patch HL*1.6*122 31 . ; HL*1.6*109 32 . L +^HLMA("AC","I",HLXX):0 Q:'$T ;*109*Does another filer have this? 48 33 . S HLD0=0,HLFLG=1 49 34 . ; HL*1.6*109 changes in for loop below, and post-quit code placed … … 53 38 . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q 54 39 . F S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT) D 55 .. ; patch HL*1.6*122 start 56 .. ; patch HL*1.6*122 TEST v2: DUZ code removed 57 .. ; DUZ comparison/reset for application proxy user 58 .. ;; D HLDUZ^HLCSTCP4 59 .. D HLDUZ2^HLCSTCP4 60 .. ; protect HLDUZ 61 .. N HLDUZ 62 .. S HLPCT=HLPCT+1 63 .. I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 64 .. ; L +^HLMA(HLD0):0 Q:'$T 65 .. F L +^HLMA(HLD0):30 Q:$T H 1 66 .. I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q ;-> Quit if not a valid AC xref 67 .. D DEFACK^HLTP3(HLXX,HLD0) 68 .. D DEQUE^HLCSREP(HLXX,"I",HLD0) 69 .. L -^HLMA(HLD0) 70 . ; patch HL*1.6*122 end 40 . . S HLPCT=HLPCT+1 41 . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 42 . . L +^HLMA(HLD0):0 Q:'$T 43 . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q ;-> Quit if not a valid AC xref 44 . . D DEFACK^HLTP3(HLXX,HLD0) 45 . . D DEQUE^HLCSREP(HLXX,"I",HLD0) 46 . . L -^HLMA(HLD0) 71 47 . ;**109 -add dt/tm stamp to time queue last processed 72 48 . S ^XTMP("HL7-AC","I",HLXX)=$H … … 89 65 S HLXX=0 90 66 F S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX D Q:HLEXIT 91 . ; HL*1.6*122, check the in-queue stop flag92 . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)93 67 . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 94 . ; HL*1.6*109: Does another filer have this? 95 . ; L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T 96 . L +^HLCS(870,HLXX,"INFILER"):2 Q:'$T ; patch HL*1.6*122 68 .; HL*1.6*109 69 . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T ;Does another filer have this? 97 70 . F D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0 D 98 .. ; 99 .. ; patch HL*1.6*122 start 100 .. ; clean variables except Kernel related variables 101 .. D 102 ... ; protect variables defined in STARTIN^HLCSIN 103 ... N HLFLG,HLEXIT,HLPTRFLR 104 ... N HLDUZ 105 ... ; protect variables defined in ACKNOW^HLCSIN 106 ... N HLXX,HLD0,HLD1 107 ... D KILL^XUSCLEAN 108 .. ; 109 .. ; patch HL*1.6*122 TEST v2: DUZ code removed 110 .. ; DUZ comparison/reset for application proxy user 111 .. ;; D HLDUZ^HLCSTCP4 112 .. D HLDUZ2^HLCSTCP4 113 .. ; protect HLDUZ 114 .. N HLDUZ 115 .. ;Make sure message is ready to be received 116 .. S HLFLG=1 117 .. S HLD1=$P(HLD0,"^",2) 118 .. S HLD0=+HLD0 ; At this point, HLD0=HLXX 119 .. I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D Q 120 ... D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE 121 .. D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message 122 .. D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE 123 . ; patch HL*1.6*122 end 71 . . ;Make sure message is ready to be received 72 . . S HLFLG=1 73 . . S HLD1=$P(HLD0,"^",2) 74 . . S HLD0=+HLD0 ; At this point, HLD0=HLXX 75 . . I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D Q 76 . . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE 77 . . D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message 78 . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE 124 79 . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D 125 80 . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around. … … 134 89 F S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX D Q:HLEXIT 135 90 . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT 136 . ; patch HL*1.6*122, comment out, no need to lock 137 . ; L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T 91 . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T 138 92 . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")) 139 . ; patch HL*1.6*122, comment out 140 . ; L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") 93 . L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") 141 94 . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT) 142 95 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m
r628 r636 1 HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;07/26/2007 17:10 2 ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2003 17:37 2 ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**;Oct 13, 1995 4 3 ; 5 4 ;This program is callable from a menu … … 24 23 W !,"appropriate device. Please select the node with which you want" 25 24 W !,"to communicate",! 26 ; patch HL*1.6*12227 S POP=028 25 S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ 29 26 S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0) 30 27 ;-- check if parameter have been setup 31 28 ;-- check for LLP type 32 I 'HLTYPTR W ! !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ29 I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ 33 30 ;-- get TCP information 34 31 S HLPARM4=$G(^HLCS(870,HLDP,400)) … … 38 35 S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) 39 36 ; 40 I HLBGR="" W ! !,$C(7),"No routine has been specified for this LLP." G STARTQ37 I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ 41 38 ; 42 39 ;-- execute environment check routine if HLQUIT is defined then terminate 43 40 I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ 44 ; patch HL*1.6*122 start 45 ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled 46 ; by the external service 41 ;Multi-Servers, only enable the link if not OpenM 47 42 I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D G STARTQ 48 43 . 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." 49 44 . Q 50 ; patch HL*1.6*122 end51 45 ; 52 46 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" 53 47 I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"." 54 ; patch HL*1.6*122 start 55 ; comment out-should be taken care of by the code 2 line above 56 ; 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 !" 57 ; I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ 58 ; . W !,$C(7),"NOTE: The lower level protocol for this application is already running." 59 N HLTEMP 60 S HLTEMP=0 61 I $P(HLPARM0,U,12) D G:HLTEMP STARTQ 62 . N ZTSK 63 . S ZTSK=$P(HLPARM0,U,12) 64 . D STAT^%ZTLOAD 65 . I "12"[ZTSK(1) D 66 .. W !,$C(7),"NOTE: The lower level protocol for this application is already running." 67 .. I '$P(^HLCS(870,HLDP,0),"^",10) S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT 68 .. S HLTEMP=1 69 ; patch HL*1.6*122 end 48 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 !" 49 I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ 50 . W !,$C(7),"NOTE: The lower level protocol for this application is already running." 70 51 I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ 71 .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 52 .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 72 53 .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors 73 54 .N HLJ,X 74 . ; patch HL*1.6*122-comment out 75 . ; I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q 55 .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q 76 56 .L +^HLCS(870,HLDP,0):2 77 57 .E W !,$C(7),"Unable to enable this LLP !" Q … … 84 64 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.",! 85 65 ; 86 ; patch HL*1.6*122 start, for tcp link87 I HLTYPTR=4 D Q88 . S Y="B"89 . D STARTJOB90 ; patch HL*1.6*122 end91 ;92 66 W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" 93 67 S DIR("A")="Method for running the receiver" … … 99 73 Q:(Y=U)!(Y="Q") 100 74 ; 101 STARTJOB ;102 75 S HLX=$G(^HLCS(870,HLDP,0)) 103 76 ;-- foreground 104 77 I Y="F" S HLTRACE=1 D G STARTQ 105 . S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT106 . D MON^HLCSTCP("Start")107 78 . X HLBGR 108 79 ;-- background … … 111 82 . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" 112 83 . D ^%ZTLOAD 113 . ; patch HL*1.6*122 start114 . I $D(ZTSK) D115 .. K HLTRACE116 .. D MON^HLCSTCP("Tasked")117 .. S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT118 . ; patch HL*1.6*122 end119 84 . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") 120 85 ; 121 86 Q 87 ; 122 88 ; 123 89 STARTQ ; … … 132 98 S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 133 99 S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400)) 134 ; patch HL*1.6*122135 ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled136 ; by the external service137 100 I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D Q 138 . 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."101 . 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." 139 102 . Q 140 103 ; … … 150 113 I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown" 151 114 D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109 152 ; patch HL*1.6*122 start 153 ; I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D 154 ; I ^%ZOSF("OS")'["DSM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D 155 I ($P(HLPARM4,U,3)="S")!(($P(HLPARM4,U,3)="M")&($S(^%ZOSF("OS")'["OpenM":0,1:$$OS^%ZOSV'["VMS"))) D 115 I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D 156 116 . ;pass task number to stop listener 157 117 . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12)) 158 . ; D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) 159 . ; I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q 160 . ; U IO W "**STOP**" 161 . ; W ! 162 . ; D CLOSE^%ZISTCP 163 . ; patch HL*1.6*122 end 118 . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) 119 . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q 120 . U IO W "**STOP**" 121 . W ! 122 . D CLOSE^%ZISTCP 164 123 L -^HLCS(870,HLDP,0) 165 124 W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m
r628 r636 1 HLCSMON ;SF-DISPLAY DRIVER PROGRAM ;12/11/2007 17:07 2 ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCSMON ;SF-DISPLAY DRIVER PROGRAM ;07/10/2000 12:18 2 ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109**;Oct 13, 1995 4 3 ; 5 4 ;This Program drives a real-time display monitor for the HL7 … … 18 17 N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE 19 18 N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY 20 ;21 ; patch HL*1.6*122 start22 D HOME^%ZIS23 W @IOF24 ; patch HL*1.6*122 end25 19 ; 26 20 D ^HLCSTERM ;Sets up variables to control display attributes -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m
r628 r636 1 HLCSMON1 ;SF-Utilities for Driver Program ;07/17/2007 17:05 2 ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCSMON1 ;SF-Utilities for Driver Program ;02/04/2004 10:25 2 ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, 1995 4 3 ; 5 4 ;This routine contains several entry points called from HLCSMON … … 12 11 F S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0) D WLINE(HLXX) 13 12 ;DISPLAY INCOMING FILER STATUS 14 ; patch HL*1.6*122 15 S HLXX=$P(HLRUNCNT,"^",1) 16 ; S HLXX=$$CNTFLR^HLCSUTL2("IN") 17 I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("IN") 18 ; 13 S HLXX=$$CNTFLR^HLCSUTL2("IN") 19 14 ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED 20 15 I (HLXX'=+HLRUNCNT) D … … 24 19 .S $P(HLRUNCNT,"^",1)=HLXX 25 20 ;DISPLAY OUTGOING FILER STATUS 26 ; patch HL*1.6*122 27 S HLXX=$P(HLRUNCNT,"^",2) 28 ; S HLXX=$$CNTFLR^HLCSUTL2("OUT") 29 I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("OUT") 30 ; 21 S HLXX=$$CNTFLR^HLCSUTL2("OUT") 31 22 ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED 32 23 I (HLXX'=+$P(HLRUNCNT,"^",2)) D … … 56 47 I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q 57 48 S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1 58 ; patch HL*1.6*122 59 ; F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) 60 F X=1,7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,10) 61 F X=2:1:5 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) 62 S X=6,@$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,7) 63 ; 49 F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) 64 50 ;if link is in error, write node in rev. video 65 51 I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14 66 52 ;Turn off terminal line wrap & inform O/S where cursor is located 67 53 S DY=HLXX X IOXY,^%ZOSF("XY") 68 ; patch HL*1.6*122 69 W:HLERR="" ?4,HLNODE 70 W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?63,HLSTAT 71 ; 54 W:HLERR="" ?5,HLNODE 55 W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?64,HLSTAT 72 56 Q 73 57 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m
r628 r636 1 HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT ;10/17/2007 08:56 2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 1 HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT - 10/4/94 1pm 2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995 5 3 REPMSG ;Duplicate messages on a queue 6 4 ; INPUT: MSG - Array which contains the queue and the … … 36 34 I DIR'="I",DIR'="O" Q 37 35 Q:'$G(IEN773) 38 ;39 ; patch HL*1.6*122: MPI-client/server40 F L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T H 141 36 S ^HLMA("AC",DIR,LINK,IEN773)="" 42 L -^HLMA("AC",DIR,LINK,IEN773)43 ;44 37 S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja 45 38 I DIR="O" D LLCNT^HLCSTCP(LINK,3) … … 56 49 I DIR'="I",DIR'="O" Q 57 50 Q:'$G(IEN773) 58 ;59 ; patch HL*1.6*122: MPI-client/server60 F L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T H 161 51 K ^HLMA("AC",DIR,LINK,IEN773) 62 L -^HLMA("AC",DIR,LINK,IEN773)63 ;64 52 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m
r628 r636 1 HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/1 9/2007 10:212 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133 ,122**;Oct 13, 1995;Build 141 HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133**;Oct 13, 1995;Build 13 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 4 ; 5 5 ; This is an implementation of the HL7 Minimal Lower Layer Protocol 6 ; taskman entry/startup option, HLDP defined in menu entry.7 ; 6 ; 7 ;taskman entry/startup option, HLDP defined in menu entry, 8 8 Q:'$D(HLDP) 9 ; patch HL*1.6*122 start 10 L +^HLCS("HLTCPLINK",HLDP):5 I '$T D Q 11 . D MON^HLCSTCP("TskLcked") 12 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET 13 N HLZRULE 9 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL 14 10 ;HLCSOUT= 1-error 15 11 I '$$INIT D EXITS("Init Error") Q 16 S HLDP("$J")=$J17 S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))18 12 ; Start the client 19 13 I $G(HLTCPCS)="C" D Q 20 . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)21 . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=122 . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))23 14 . ; identify process for ^%SY 24 . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) 25 . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15)) 26 . K HLDP("$J",0) 15 . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) 27 16 . D ST1 28 17 . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT) 29 . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q 30 . I $G(HLCSOUT)=1 D Q 31 .. D MON("Error") H 1 32 .. L -^HLCS("HLTCPLINK",HLDP) 18 . I $G(HLCSOUT)=1 D MON("Error") H 1 Q 33 19 . I $G(HLCSOUT)=2 D EXITS("Inactive") Q 34 20 . D EXITS("Shutdown") 35 21 ; 36 S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)37 I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=138 S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))39 22 ; identify process for ^%SY 40 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) 41 D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15)) 42 K HLDP("$J",0) 43 ; to stop the listener via updated Kernel API, need to pass the 44 ; listener logical link (HLDP) 45 S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP" 23 D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) 24 ;HLCSFAIL=1 port failed to open 25 S HLCSFAIL=1 46 26 ;single threaded listener 47 27 I $G(HLTCPCS)="S" D Q 48 . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE) 49 . I $$STOP D EXITS("Shutdown") Q 50 . D EXITS("Openfail") 51 ; 52 ;multi-threaded listener (for OpenM/NT) 53 I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D Q 54 . L -^HLCS("HLTCPLINK",HLDP) 55 I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q 56 D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE) 57 ; update status of listener 58 I $$STOP D EXITS("Shutdown") Q 59 D EXITS("Openfail") 60 ; HL*1.6*122 end 28 . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")") 29 . ;couldn't open listener port 30 . I HLCSFAIL D EXITS("Openfail") Q 31 ; 32 ;multi-threaded listener (OpenM) 33 I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D Q 34 . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")") 61 35 Q 62 36 ; 63 37 SERVER(HLDP) ; single server using Taskman 38 S HLCSFAIL=0 64 39 I '$$INIT D EXITS("Init error") Q 65 40 D ^HLCSTCP1 … … 80 55 G LISTEN 81 56 ; 57 CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file, 58 ;listener, % = HLDP 59 I $G(%)="" D ^%ZTER Q 60 S IO="SYS$NET",HLDP=% 61 S IO(0)="_NLA0:" O IO(0) ;Setup null device 62 ; **Cache'/VMS specific code** 63 O IO::5 E D MON("Openfail") Q 64 X "U IO:(::""-M"")" ;Packet mode like DSM 65 D LISTEN C IO Q 66 ; 67 EN ;vms ucx entry point, called from HLSEVEN.COM file, 68 ;listener, % = device^HLDP 69 I $G(%)="" D ^%ZTER Q 70 S IO="SYS$NET",U="^",HLDP=$P(%,U,2) 71 S IO(0)="_NLA0:" O IO(0) ;Setup null device 72 ; **VMS specific code, need to share device** 73 O IO:(TCPDEV):60 E D MON("Openfail") Q 82 74 LISTEN ; 83 N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET 75 N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL 84 76 I '$$INIT D ^%ZTER Q 85 ; patch HL*1.6*122 start86 S HLDP("$J")=$J87 S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))88 S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)89 I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=190 S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))91 77 ; identify process for ^%SY 92 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) 93 D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15)) 94 K HLDP("$J",0) 95 ; patch HL*1.6*122 end 78 D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) 96 79 ;HLLSTN used to identify a listener to tag MON 97 80 S HLLSTN=1 … … 110 93 S HLOS=$P($G(^%ZOSF("OS")),"^") 111 94 N DA,DIQUIET,DR,TMP,X,Y 112 S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character113 95 S DIQUIET=1 114 96 D DT^DICRW 115 97 I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0 116 98 S DA=HLDP 117 ; patch HL*1.6*122 for field 400.09 118 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" 99 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" 119 100 D GETS^DIQ(870,DA,DR,"IN","TMP","TMP") 120 101 ; … … 144 125 S HLTCPRET=$G(TMP(870,DA_",",400.05,"I")) 145 126 ; 146 ; patch HL*1.6*122 for field 400.09147 ; -- tcp/ip openfail timeout148 S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))149 ;150 127 ; -- set defaults in case something's not set 151 128 S:HLDREAD=0 HLDREAD=10 152 129 S:HLDBACK=0 HLDBACK=60 153 ; patch HL*1.6*122 154 ; S:HLDBSIZE=0 HLDBSIZE=245 155 S:HLDBSIZE<245 HLDBSIZE=245 130 S:HLDBSIZE=0 HLDBSIZE=245 156 131 S:HLDRETR=0 HLDRETR=5 157 132 S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15) 158 ;159 ; patch HL*1.6*122 for field 400.09160 S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5161 133 ; 162 134 Q 1 … … 166 138 ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors 167 139 N HLJ,X 168 ; HL*1.6*122 remove unnecessary locks 169 ;F L +^HLCS(870,HLDP,0):2 Q:$T 140 F L +^HLCS(870,HLDP,0):2 Q:$T 170 141 S X="HLJ(870,"""_HLDP_","")" 171 142 S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0 … … 175 146 S:$G(ZTSK) @X@(11)=ZTSK 176 147 D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 177 ;L -^HLCS(870,HLDP,0)148 L -^HLCS(870,HLDP,0) 178 149 Q 179 150 ; … … 181 152 ;don't display for multiple server 182 153 Q:$G(HLLSTN) 183 ; HL*1.6*122 remove unnecessary locks 184 ;F L +^HLCS(870,HLDP,0):2 Q:$T 154 F L +^HLCS(870,HLDP,0):2 Q:$T 185 155 S $P(^HLCS(870,HLDP,0),U,5)=Y 186 ;L -^HLCS(870,HLDP,0)156 L -^HLCS(870,HLDP,0) 187 157 Q:'$D(HLTRACE) 188 158 N X U IO(0) 189 159 W !,"IN State: ",Y 190 160 I '$$STOP D 191 . ; patch HL*1.6*122 192 . ; R !,"Type Q to Quit: ",X#1:1 193 . R !,"Type Q to Quit: ",X:1 194 . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 195 . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1 196 . ; patch HL*1.6*122 end 161 . R !,"Type Q to Quit: ",X#1:1 162 . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 197 163 U IO 198 164 Q 199 165 UPDT(Y) ;update job count for multiple servers,X=1 increment 200 166 N HLJ,X 201 ; 202 ; HL*1.6*122 start 203 ; F L +^HLCS(870,HLDP,0):2 Q:$T 204 Q:'$G(HLDP) 205 Q:'$D(^HLCS(870,"E","M",HLDP)) 206 F L +^HLCS(870,HLDP,0):10 Q:$T H 1 207 ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" 208 S X=+$P(^HLCS(870,HLDP,0),U,5) 209 I X<0 S X=0 210 S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server" 167 F L +^HLCS(870,HLDP,0):2 Q:$T 168 S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" 211 169 ;if incrementing, set the Device Type field to Multi-Server 212 ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") 213 I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS" 214 ; HL*1.6*122 end 215 ; 170 I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109 216 171 L -^HLCS(870,HLDP,0) 217 172 Q … … 230 185 N P,X 231 186 S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER" 232 ; patch HL*1.6*122 start 233 ; F L +^HLCS(870,DP,P):2 Q:$T 234 ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) 235 I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) 236 I OS'["DSM",OS'["OpenM" D 237 . F L +^HLCS(870,DP,P):10 Q:$T H 1 238 . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) 239 . L -^HLCS(870,DP,P) 240 E D 241 . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1)) 242 ; L -^HLCS(870,DP,P) 243 ; patch HL*1.6*122 end 187 F L +^HLCS(870,DP,P):2 Q:$T 188 S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) 189 L -^HLCS(870,DP,P) 244 190 Q 245 191 SDFLD ; set Shutdown? field to yes 246 192 Q:'$G(HLDP) 247 ; HL*1.6*122 remove unnecessary lock and call to FM 248 S $P(^HLCS(870,HLDP,0),U,15)=1 249 ;N HLJ,X 250 ;F L +^HLCS(870,HLDP,0):2 Q:$T 193 N HLJ,X 194 F L +^HLCS(870,HLDP,0):2 Q:$T 251 195 ;14=Shutdown LLP? 252 ;S HLJ(870,HLDP_",",14)=1 253 ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 254 ;L -^HLCS(870,HLDP,0) 255 Q 256 ; 257 EXITS(Y) ; shutdown and clean up the listener process for either 258 ; single-threaded or multi-threaded 196 S HLJ(870,HLDP_",",14)=1 197 D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 198 L -^HLCS(870,HLDP,0) 199 Q 200 ; 201 EXITS(Y) ; Single service shutdown and cleans up 259 202 N HLJ,X 260 203 F L +^HLCS(870,HLDP,0):2 Q:$T … … 266 209 L -^HLCS(870,HLDP,0) 267 210 I $D(ZTQUEUED) S ZTREQ="@" 268 ; HL*1.6*122269 L -^HLCS("HLTCPLINK",HLDP)270 211 Q 271 212 ; 272 213 EXITM ;Multiple service shutdown and clean up 273 ; shutdown and clean up a connection spawned by the listener274 ; process for a multi-threaded listener275 214 D UPDT(0) 276 215 I $D(ZTQUEUED) S ZTREQ="@" -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m
r628 r636 1 HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 10/17/2007 12:592 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 141 HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07 08:58 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ;Receiver … … 12 12 ; variable to replace ^TMP 13 13 N HLTMBUF 14 ;15 14 ; for HL7 application proxy user 16 ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed 17 N HLDUZ 18 S HLDUZ=+$G(DUZ) 19 ; 15 N HLDUZ,DUZ 20 16 D MON^HLCSTCP("Open") 21 17 ; K ^TMP("HLCSTCP",$J,0) 22 18 S HLMIEN=0,HLASTMSG="" 23 ;24 ; patch HL*1.6*122 TEST v2: DUZ code removed25 19 ; set DUZ for application proxy user 26 ;; D PROXY^HLCSTCP4 27 ; 20 D PROXY^HLCSTCP4 28 21 F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 29 22 . ; clean variables … … 31 24 . S HLMIEN=$$READ 32 25 . Q:'HLMIEN 33 . ;34 . ; patch HL*1.6*122 TEST v2: DUZ code removed35 26 . ; DUZ comparison/reset for application proxy user 36 . ;; D HLDUZ^HLCSTCP4 37 . D HLDUZ2^HLCSTCP4 27 . D HLDUZ^HLCSTCP4 38 28 . ; protect HLDUZ 39 29 . N HLDUZ … … 112 102 . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1 113 103 ; detect disconnect for GT.M 114 I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=" ,UREAD,"104 I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE="" 115 105 ; timedout, <clean up>, quit 116 106 ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q … … 244 234 SAVE(SRC,DEST) ;save into global & set top node 245 235 ;SRC=source array (passed by ref.), DEST=destination global 246 ;247 ; patch HL*1.6*122: MPI-client/server248 I DEST["HLMA" D249 . F L +^HLMA(+HLIND1):10 Q:$T H 1250 E D251 . F L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T H 1252 ;253 236 M @DEST=SRC 254 237 S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" 255 ;256 I DEST["HLMA" L -^HLMA(+HLIND1)257 E L -^HL(772,+$P(HLIND1,U,2))258 ;259 238 Q 260 239 ; … … 277 256 ; 278 257 ERROR ; Error trap for disconnect error and return back to the read loop. 279 ; patch HL*1.6*122 280 ; move to routine HLCSTCP4 (splitted-size over 10000) 281 D ERROR1^HLCSTCP4 258 S $ETRAP="D UNWIND^%ZTER" 259 I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q ;VOE change for GT.M 260 I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q 261 I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q 262 I $ECODE["UREAD" D UNWIND^%ZTER Q ; HL*1.6*122 GT.M 263 S HLCSOUT=1 D ^%ZTER,CC("Error") 264 D UNWIND^%ZTER 282 265 Q 283 266 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m
r628 r636 1 HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 10/17/2007 09:372 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133 ,122**;Oct 13,1995;Build 141 HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133**;Oct 13,1995;Build 13 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ;Sender … … 11 11 S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0 12 12 ; 13 ; patch 122 14 ; patch 133 15 ; set IO(0) to the null device 16 I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D 17 . 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) 18 . O IO(0) U IO(0) 13 ;set IO(0) to the null device 14 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) 15 O IO(0) U IO(0) 19 16 ; 20 17 ;persistent conection, open connection first, HLPORT=open port … … 39 36 ; and then check the link if it open or not 40 37 N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD 41 N HLTMBUF 42 D MON^HLCSTCP("CheckOut") 38 D MON^HLCSTCP("Check out") 43 39 ;HLMSG=next msg, set at tag DONE 44 40 I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG 45 41 ; 42 ;**109** 43 ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete 44 ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q 45 ;L -^HLMA(HLMSG) 46 ; 46 47 S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP="" 47 48 ;don't have message text or MSH, kill x-ref and decrement 'to send' 48 ; 49 ; patch HL*1.6*122: MPI-client/server 50 ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q 51 I 'HLI!'HLJ D Q 52 . F L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T H 1 53 . K ^HLMA("AC","O",HLDP,HLMSG) 54 . L -^HLMA("AC","O",HLDP,HLMSG) 55 . D LLCNT^HLCSTCP(HLDP,3,1) 56 . S HLMSG=0 57 ; 49 I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q 58 50 ;update msg status to 'being transmitted'; if cancelled decrement link and quit 59 51 I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q … … 153 145 ; Set up error trap 154 146 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" 155 ; patch HL*1.6*122156 N HLTMBUF157 147 ;override ack timeout 158 148 I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME") … … 179 169 D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1) 180 170 ; 171 ;**109** 181 172 D DEQUE^HLCSREP(HLDP,"O",HLMSG) 182 173 ; … … 189 180 ;returns 1=msg was updated, 0=msg has been canceled 190 181 N X 182 ; 183 ;**109** 184 ;F L +^HLMA(HLMSG,"P"):1 Q:$T H 1 185 ; 191 186 ; 192 187 ; New HL*1.6*77 code starting here... … … 195 190 . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1) 196 191 .; 192 .;**109** 197 193 . D DEQUE^HLCSREP(HLDP,"O",HLMSG) 198 ; 199 ; End of HL*1.6*77 194 .;L -^HLMA(HLMSG,"P") 195 ;**end 109** 196 ; 197 ; End of HL*1.6*77 modifications 200 198 ; 201 199 ;get status, quit if msg was cancelled 202 200 ; 201 ;**109** 202 ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0 203 203 S X=+^HLMA(HLMSG,"P") Q:X=3 0 204 204 ; 205 205 ;update status if it is different 206 206 I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI) 207 ; 208 ;**109** 209 ;L -^HLMA(HLMSG,"P") 207 210 ; 208 211 Q 1 … … 216 219 ; -1 - Unsuccessful 217 220 ; 218 N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT 219 S CRCOUNT=0 221 N HLDA2,HLAR,HLI,LINENO,X 220 222 ;set error trap, used when called from HLTP3 221 223 ; … … 235 237 .. ;first line, need start block char. 236 238 .. S:LINENO=1 X=$C(11)_X 237 .. ; HL*1.6*122 238 .. ; I X]"" W X,! 239 .. N LENGTH 240 .. S LENGTH=$L(X) 241 .. ; buffer should be limited to 512 242 .. I LENGTH>512 D 243 ... N X1 244 ... F Q:LENGTH<512 D 245 .... S X1=$E(X,1,512),X=$E(X,513,999999) 246 .... S LENGTH=$L(X) 247 .... W X1,@IOF 248 .. ; 249 .. ; @IOF (! or #) for flush character 250 .. I X]"" W X,@IOF S CRCOUNT=0 251 .. ;send CR 252 .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1 253 .. ; prevent from maxstring error 254 .. I CRCOUNT>200 W @IOF S CRCOUNT=0 239 .. I X]"" W X,! 240 .. ;send CR for blank lines 241 .. I X="" W $C(13) 255 242 .. S LINENO=LINENO+1 256 243 ; Sends end block for this message 257 244 S X=$C(28)_$C(13) 258 ; U IO W X,! 259 U IO W X,@IOF 260 ;switch to null device 261 I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) 245 U IO W X,! 246 I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage' 262 247 Q 1 263 248 ; … … 271 256 G OPENA^HLCSTCP3 272 257 ; 273 RDERR D RDERR^HLCSTCP4 Q 274 ERROR D ERROR^HLCSTCP4 Q 258 RDERR D RDERR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA 259 ERROR D ERROR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA 275 260 ; 276 261 CC(X) ;cleanup and close -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m
r628 r636 1 HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 09/13/2006 15:362 ;;1.6;HEALTH LEVEL SEVEN;**76,77,133 ,122**;OCT 13, 1995;Build 141 HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**76,77,133**;OCT 13, 1995;Build 13 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; 5 OPENA ; 6 ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA 7 ; 8 I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6) 5 OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6) 6 D MON^HLCSTCP("Open") 9 7 S POP=1 10 ;11 ; patch HL*1.6*122 start12 ; variable HLDRETR=re-transmit attemps (#870,200.02)13 ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()14 ; defined in HLCSTCP routine15 ;16 I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=117 I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=518 S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR19 ; patch 13320 ; I $G(HLDIRECT("OPEN TIMEOUT")) D21 ; .S HLI=122 ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))23 ; E D24 ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP25 8 I $G(HLDIRECT("OPEN TIMEOUT")) D 26 . D MON^HLCSTCP("Open") 27 . D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT")) 28 . ; give site one more chance to override the application setup 29 . I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D 30 .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT")) 9 .S HLI=1 10 .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT")) 31 11 E D 32 . N COUNT 33 . ; try to connect HLDRETR times 34 . F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D Q:('POP)!($$STOP^HLCSTCP) 35 .. D MON^HLCSTCP("Open") 36 .. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT) 37 .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT")) 38 .. ;open error 39 .. I POP D 40 ... D CC^HLCSTCP2("Openfail") 41 ... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8) 42 ... I '$D(^XTMP("HL7-Openfail",$J)) D 43 .... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT 44 .... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT 45 ... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1 46 ... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT 47 ; 12 .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP 48 13 ;set # of opens back in msg 49 ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI 50 I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT") 51 ; patch HL*1.6*122 end 52 ; 14 I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI 53 15 ;device open 54 16 I 'POP S HLPORT=IO D Q $S($G(HLERROR)]"":0,1:1) … … 61 23 . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1 62 24 ;openfail-try DNS lookup 63 ; 64 ; patch HL*1.6*122 start 65 ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS 66 I '$D(HLDOM) D 67 . S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) 68 . S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8) 69 . D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS 70 ; 71 Q:$$STOP^HLCSTCP 0 25 I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS 72 26 ;HLIP=ip add. from DNS call, get first one and try open again 73 27 I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA 74 ; open error 75 ;cleanup and close 76 ; patch 133 28 ;open error 77 29 I $G(HLDIRECT("OPEN TIMEOUT")) D 78 . 79 . 30 .D MON^HLCSTCP("Openfail") 31 .I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT 80 32 E D 81 . D CC^HLCSTCP2("Openfail")33 .D CC^HLCSTCP2("Openfail") H 3 82 34 Q 0 83 ; patch HL*1.6*122 end84 ;85 35 ; 86 36 ;following code was removed, site's complained of to many alerts … … 107 57 I HLTCPORT=5000 S HLDOM="HL7."_HLDOM 108 58 I HLTCPORT=5500 S HLDOM="MPI."_HLDOM 109 ;110 ; patch HL*1.6*122 start111 I $L($G(HLDOM("DNS")),".")>2 D112 . S HLDOM=HLDOM("DNS")113 ; patch HL*1.6*122 end114 ;115 59 S HLIP=$$ADDRESS^XLFNSLK(HLDOM) 116 60 K:HLIP="" HLIP -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m
r628 r636 1 HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;1 0/18/2007 09:562 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 141 HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006 13:31 2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 15 15 ;I $G(HLMSG) L -^HLMA(HLMSG) 16 16 ; 17 ; patch HL*1.6*122 start18 N STOP19 S STOP=020 I $G(HLDP) S STOP=$$STOP^HLCSTCP21 17 S $ETRAP="D UNWIND^%ZTER" 22 S HLTCP("$ZA\8192#2")="" 23 I (^%ZOSF("OS")["OpenM") D 24 . S HLTCP("$ZA")=$ZA 25 . ; For TCP devices $ZA\8192#2: the device is currently in the 26 . ; Connected state talking to a remote host. 27 . S HLTCP("$ZA\8192#2")=$ZA\8192#2 28 ; 18 ; patch HL*1.6*122 19 S HLTCPERR("$P")=$P 29 20 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV 30 21 ; 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 31 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D G:STOP H2^XUSCLEANQ32 . D CC^HLCSTCP2("Op-err") H 122 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q 23 . D CC^HLCSTCP2("Op-err") 33 24 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" 34 . I STOP D Q 35 .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')") 36 . I 'STOP D UNWIND^%ZTER 37 I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q 38 . D CC^HLCSTCP2("Wr-err") H 1 39 . S:$G(HLPRIO)="I" HLERROR="108^Write Error" 40 . I STOP D Q 41 .. D CC^HLCSTCP2("Shutdown: (with 'Wr-err')") 42 . I HLTCP("$ZA\8192#2")=0 D Q 43 .. D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')") 44 . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER 25 . D UNWIND^%ZTER 26 I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications start here 27 . D CC^HLCSTCP2("Wr-err") 28 . S:$G(HLPRIO)="I" HLERROR="108^Write Error" 29 . D UNWIND^%ZTER ;HL*1.6*77 modifications end here 45 30 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q 46 I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEANQ47 . D CC^HLCSTCP2("Rd-err") H 131 I $$EC^%ZOSV["READ" D Q 32 . D CC^HLCSTCP2("Rd-err") 48 33 . S:$G(HLPRIO)="I" HLERROR="108^Read Error" 49 . I STOP D Q 50 .. D CC^HLCSTCP2("Shutdown: (with 'Rd-err')") 51 . I HLTCP("$ZA\8192#2")=0 D Q 52 .. D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')") 53 . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER 34 . D UNWIND^%ZTER 54 35 S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP 55 36 S:$G(HLPRIO)="I" HLERROR="9^Error" 56 I STOP D CC^HLCSTCP2("Shutdown: (with 'Error')")57 I HLTCP("$ZA\8192#2")=0 D58 . D CC^HLCSTCP2("Halt (Er): (Disconnected with 'Error')")59 G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN60 ; patch HL*1.6*122 end61 37 D UNWIND^%ZTER 62 38 Q 63 39 ; 64 40 PROXY ; set DUZ for application proxy user 65 ; 66 ; removed the execcution: patch 122 TEST v2 41 S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY") 42 S DUZ=HLDUZ 43 D DUZ^XUP(DUZ) 67 44 Q 68 45 ; 69 ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")70 ;; S DUZ=HLDUZ71 ;; D DUZ^XUP(DUZ)72 ;; Q73 ;74 46 HLDUZ ; compare DUZ and set DUZ to application proxy user 75 ; 76 ; removed the execcution: patch 122 TEST v2 77 Q 78 ; 79 ;; I '$G(HLDUZ) D PROXY 80 ; 81 HLDUZ2 ; compare DUZ and HLDUZ 47 I '$G(HLDUZ) D PROXY 82 48 I $G(DUZ)'=HLDUZ D 83 49 . S DUZ=HLDUZ … … 121 87 I HLIND1 D Q 122 88 . ;get pointer to 772, kill header 123 . ;124 . ; patch HL*1.6*122: MPI-client/server125 . F L +^HLMA(+HLIND1):10 Q:$T H 1126 89 . K ^HLMA(+HLIND1,"MSH") 127 . L -^HLMA(+HLIND1)128 . ;129 90 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") 130 91 . S X=$$MAID^HLTF(+HLIND1,HLMID) … … 155 116 Q X 156 117 ; 157 ERROR1 ;158 ; moved from ERROR^HLCSTCP1159 ; Error trap for disconnect error and return back to the read loop.160 ; patch HL*1.6*122 start161 I (^%ZOSF("OS")["OpenM") D162 . S HLTCP("$ZA")=$ZA163 . ; For TCP devices $ZA\8192#2: the device is currently in the164 . ; Connected state talking to a remote host.165 . S HLTCP("$ZA\8192#2")=$ZA\8192#2166 . I HLTCP("$ZA\8192#2")=0 D167 .. ; decrement counter of multi-listener168 .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP169 .. ; process terminated170 .. D H2^XUSCLEAN171 S $ETRAP="D UNWIND^%ZTER"172 ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q173 I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q174 . ; if it is not a multi-listener175 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")176 . D UNWIND^%ZTER177 I $$EC^%ZOSV["READ" D Q178 . ; if it is not a multi-listener179 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")180 . D UNWIND^%ZTER181 ;182 ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q183 I $$EC^%ZOSV["WRITE" D Q184 . ; if it is not a multi-listener185 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")186 . D UNWIND^%ZTER187 ;188 ; for GT.M189 I $ECODE["UREAD" D Q190 . ; if it is not a multi-listener191 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")192 . D UNWIND^%ZTER193 ;194 ; S HLCSOUT=1 D ^%ZTER,CC("Error")195 S HLCSOUT=1196 D ^%ZTER197 ; if it is not a multi-listener198 I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")199 ; patch HL*1.6*122 end200 ;201 D UNWIND^%ZTER202 Q203 ;204 CLRMCNTR ;205 ; clear the counter to set as "0 server" for multi-listener206 ; HL*1.6*122 start207 Q:'$G(HLDP)208 Q:'$D(^HLCS(870,"E","M",HLDP))209 S $P(^HLCS(870,HLDP,0),"^",4)="MS"210 S $P(^HLCS(870,HLDP,0),U,5)="0 server"211 Q212 ;213 CREATUSR ;214 ; patch HL*1.6*122 TEST v2: DUZ code removed215 ; create application proxy users for listeners and incoming filer216 ;; N HLTEMP217 ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")218 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m
r628 r636 1 HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/26/2007 10:29 2 ;;1.6;HEALTH LEVEL SEVEN;**84,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/10/2003 10:12 2 ;;1.6;HEALTH LEVEL SEVEN;**84**;Oct 13, 1995 4 3 ; 5 ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM, 6 ; HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port 7 ; number. 8 ; 2. find the ien of #870(logical link file) for the multi-listener 4 ; 1. port number is input from VMS HLSxxxxDSM.COM or HLSxxxxCACHE.COM 5 ; file, where xxxx is port number. 6 ; 2. find the ien of #870(logical link file) for the HL7 multi-listener 7 ; 3. call the appropriate entry: 8 ; for Cache: CACHEVMS^HLCSTCP(ien of #870) 9 ; for DSM: EN^HLCSTCP 9 10 Q 11 PORT ; 12 ;HLIEN870: ien in #870 (logical link file) 13 ;HLPORT: port number of multi-listener 14 ;HLPRTS: port number in entry to be tested 15 ;input of DSM: % = device^port number of multi-listener 16 ;input of Cache: port number of TCPIP 10 17 ; 11 GTMPORT(%) ; From tcpip ZFOO for GT.M12 ; %: device^port number13 N HLPORT14 S HLPORT=$P($G(%),"^",2)15 I $G(^%ZOSF("OS"))'["GT.M" D ^%ZTER Q16 D IEN17 Q18 ;19 PORT ;20 ; HLPORT: port number of multi-listener21 ; input of DSM: % = device^port number of multi-listener22 ; input of Cache: port number of TCPIP23 ;24 N HLPORT25 S HLPORT=026 18 I ^%ZOSF("OS")["OpenM" D 27 19 . S HLPORT=$ZF("GETSYM","PORT") 28 20 I ^%ZOSF("OS")["DSM" D 29 21 . S HLPORT=$P(%,"^",2) 30 ;31 IEN ;32 ; HLIEN870: ien in #870 (logical link file)33 ; HLPRTS: port number in entry to be tested34 ;35 N HLIEN87036 22 I 'HLPORT D ^%ZTER Q 37 23 S HLIEN870=0 … … 41 27 ; 42 28 K HLPORT,HLPRTS 43 ; patch 12244 S U="^"45 29 ; 46 30 ;for Cache/VMS 47 31 I ^%ZOSF("OS")["OpenM" D Q 48 . D CACHEVMS(HLIEN870)32 .D CACHEVMS^HLCSTCP(HLIEN870) 49 33 ; 50 34 ;for DSM … … 52 36 . S $P(%,"^",2)=HLIEN870 ;set % = device^ien of #870 53 37 . K HLIEN870 54 . D EN 55 ; 56 ;for GT.M 57 I ^%ZOSF("OS")["GT.M" D Q 58 . S HLDP=HLIEN870 ;set HLDP = ien of #870 59 . K HLIEN870 60 . D GTMUCX 38 . D EN^HLCSTCP 61 39 ; 62 40 D ^%ZTER 63 41 Q 64 GTMUCX ; GT.M /VMS tcpip65 ;listener, % = device^port66 S U="^",IO=$P(%,U)67 ; S IO(0)=$P O IO(0) ;Setup null device68 ; GTM specific code69 S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")70 X "O IO:(RECORDSIZE=512)"71 D LISTEN^HLCSTCP72 C IO73 Q74 ;75 ; $ x=f$trnlnm("sys$net") !This is our MBX device76 ; $!77 ; $! for GT.M78 ; $ assign 'f$trnlnm("SYS$NET")' SYS$NET79 ; $! Depending on how your command files are set up, you may need to80 ; $! run the GT.M profile file.81 ; $ @<user$:[gtmmgr]>gtmprofile.com82 ; $ forfoo="$" + f$parse("user$:[gtmmgr.r]ZFOO.exe")83 ; $ PORT=500084 ; $ data="''x'^''PORT'"85 ; $ forfoo GTMPORT^HLCSTCPA("''data'")86 ;87 CACHEVMS(%) ;Cache'/VMS tcpip88 ;listener, % = HLDP89 I $G(%)="" D ^%ZTER Q90 ; patch 13391 S IO="SYS$NET",U="^",HLDP=%92 S IO(0)="_NLA0:" O IO(0) ;Setup null device93 ; **Cache'/VMS specific code**94 O IO::5 E D MON^HLCSTCP("Openfail") Q95 X "U IO:(::""-M"")" ;Packet mode like DSM96 D LISTEN^HLCSTCP97 C IO98 Q99 ;100 EN ; DSM/VMS tcpip101 ;listener, % = device^HLDP102 I $G(%)="" D ^%ZTER Q103 ; patch 122104 ; S IO="SYS$NET",U="^",HLDP=$P(%,U,2)105 S U="^",IO=$P(%,U),HLDP=$P(%,U,2)106 ; patch 133107 S IO(0)="_NLA0:" O IO(0) ;Setup null device108 ; **VMS specific code, need to share device**109 O IO:(TCPDEV):60 E D MON^HLCSTCP("Openfail") Q110 ; patch 122111 D LISTEN^HLCSTCP112 C IO113 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m
r628 r636 1 HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES ;06/27/2007 17:04 2 ;;1.6;HEALTH LEVEL SEVEN;**40,49,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 1 HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES - 8/1/94 ;07/28/98 09:43 2 ;;1.6;HEALTH LEVEL SEVEN;**40,49**;Oct 13, 1995 5 3 TERM ; -- set up term characteristics 6 4 N X … … 25 23 D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8) 26 24 D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT ",8) 27 ; patch HL*1.6*122 28 ; D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",8) 29 D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",6) 30 ; 25 D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",8) 31 26 D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8) 32 27 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m
r628 r636 1 HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15 2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 1 HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17 2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995 5 3 ; 6 4 ; Rules: if any of these rules is broken, FILE^DIE is called instead … … 75 73 .I FILE=772 D DEL772^HLUOPT3(+IEN) 76 74 ; 77 ; patch HL*1.6*122: MPI-client/server78 75 ; If no data in record passed in, log an error and quit... 79 ; I '$D(@GBL) D Q ; Remember. GBL contains IEN... 80 N HLDGBL 81 F L +@GBL:10 Q:$T H 1 82 S HLDGBL=$D(@GBL) 83 L -@GBL 84 I 'HLDGBL D Q ; Remember. GBL contains IEN... 76 I '$D(@GBL) D Q ; Remember. GBL contains IEN... 85 77 . S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2) 86 78 . S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"") … … 118 110 QUIT:'$D(NODE("CHG")) ;-> 119 111 ; 120 ; patch HL*1.6*122: MPI-client/server121 I FILE=773 D122 . F L +^HLMA(IEN):10 Q:$T H 1123 E D124 . F L +^HL(772,IEN):10 Q:$T H 1125 ;126 112 ; Store changes in the global now... 127 113 D STORE(FILE,IEN,.NODE) … … 131 117 F S XRF=$O(XRF(XRF)) Q:XRF']"" D 132 118 . D @("XRF"_XRF_U_ROUTINE) 133 ;134 ; patch HL*1.6*122: MPI-client/server135 I FILE=773 L -^HLMA(IEN)136 E L -^HL(772,IEN)137 119 ; 138 120 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m
r628 r636 1 HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages ;03/26/2008 11:34 2 ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 1 HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;08/03/2000 15:45 2 ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66**;Oct 13, 1995 5 3 HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format 6 4 ; INPUT: X - Name in DHCP format … … 55 53 Q $S(Y="DT":$E(%,1,8),1:%) 56 54 ; 57 FMDATE(X) ; 55 FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format 58 56 I X="" Q "" 59 57 N % … … 160 158 Q:'$D(X) "" Q:$L(X)<7 "" 161 159 N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C) 162 ; 163 ; patch HL*1.6*141 start 164 ; 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="" 165 N CH 166 S Y="" 167 F I=1:1:$L(X) D 168 . S CH=$E(X,I) 169 . ; Next line modified by RBN 170 . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"") 171 . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"") 172 . I "Xx"[CH S Z="" 173 ; 174 ; the number, following "X" character, should be greater than 0 175 I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X") 176 ; patch HL*1.6*141 end 177 ; 160 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="" 178 161 I $L(Y)<7 Q "" 179 162 S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q "" -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m
r628 r636 1 HLMA ;AISC/SAW-Message Administration Module ;10/2 4/2007 10:152 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132 ,122**;Oct 13, 1995;Build 141 HLMA ;AISC/SAW-Message Administration Module ;10/25/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ; … … 35 35 ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string 36 36 ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91 37 ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or 38 ; <subscriber protocol name> - A list of protocols to dynamically 39 ; drop from the event protocol's subscriber multiple. 37 ; HLP("EXLCLUDE SUBSCRIBER",<n=1,2,3...>)=<subsciber protocol ien> - A list of protocols to dynamically drop from the event protocol's subscriber multiple. 40 38 ; 41 39 ;can't have link open when generating new message … … 44 42 S HLRESLT="" 45 43 ;Check for required parameters 46 CONT ; 47 I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D G EXIT 48 . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" 44 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 49 45 I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT 50 46 N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)="" … … 82 78 I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR 83 79 S HLRESLT=HLRESLT_"^"_HLRESLT1 84 ;85 ; patch HL*1.6*12286 S HLRESLT("HLMID")=$G(HLMIDAR("HLMID"))87 S HLRESLT("IEN773")=$G(HLMIDAR("IEN773"))88 ;89 80 ;Execute exit action for event driver protocol 90 81 I HLEXROU]"" X HLEXROU … … 97 88 ;Entry point to generate an immediate message, must be TCP Logical Link 98 89 ;Input: 99 ; The same as GENERATE,with one additional subscript to the HLP input 100 ; array: 90 ; The same as GENERATE,with one additional subscript to the HLP input array: 101 91 ; 102 92 ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between 103 93 ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should 104 ; try to open a connection before failing. It is killed upon 105 ; completion. 94 ; try to open a connection before failing. It is killed upon completion. 106 95 ; 107 96 N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT … … 137 126 ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q 138 127 D SETUP^HLCSAC G:HLCS PINGQ 139 ; patch HL*1.6*122140 G:$$DONTPING^HLMA4 PINGQ141 128 ;PING header=MSH^PING^domain^PING^logical link^datetime 142 129 S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H) … … 147 134 . ;non-standard HL7 header; start block,header,end block 148 135 . S HLX1=$H 149 . ; 150 . ; HL*1.6*122 start 151 . ; replace flush character '!' with @IOF (! or #) 152 . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char 153 . W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF 154 . ; HL*1.6*122 end 155 . ; 136 . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char 156 137 . ;read response 157 138 . R X:HLDREAD … … 179 160 N HLDOM,HLIP S HLCS="" 180 161 S HLDOM=$P(^HLCS(870,HLDP,0),U,7) 181 ; patch HL*1.6*122 start 182 S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8) 183 ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q 184 I 'HLDOM,($L(HLDOM("DNS"),".")<3) D Q 185 . I 'HLQUIET W !,"Domain Unknown" 186 . S HLCS="-1^Connection Fail" 187 ; patch HL*1.6*122 end 162 I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q 188 163 I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U) 189 ; patch HL*1.6*122 190 ; I HLDOM]"" D Q:'POP 191 I HLDOM]""!($L(HLDOM("DNS"),".")>2) D Q:'POP 164 I HLDOM]"" D Q:'POP 192 165 . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" 193 166 . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM 194 167 . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM 195 . ; patch HL*1.6*122196 . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS")197 168 . I 'HLQUIET W !,"Domain, "_HLDOM 198 169 . I 'HLQUIET W !,"Port: ",HLTCPORT -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m
r628 r636 1 HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;0 7/18/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134 ,137**;Oct 13, 1995;Build 211 HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;02/06/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 54 54 .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q 55 55 .; 56 .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO ^HLOAPI2(.HLMSTATE,.WHOTO,.ERR2) D56 .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO(.HLMSTATE,.WHOTO,.ERR2) D 57 57 ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1 58 58 .E D 59 . .S ERROR=$G(ERR1)_": "_$G(ERR2)60 . .D DONTSEND(.HLMSTATE,ERROR)59 .S ERROR=$G(ERR1)_": "_$G(ERR2) 60 .D DONTSEND(.HLMSTATE,ERROR) 61 61 K PARMS,WHOTO 62 62 Q $S(SUCCESS:HLMSTATE("IEN"),1:0) … … 106 106 .K STATE M STATE=HLMSTATE S STATE("IEN")="" 107 107 .S ERROR="" 108 .I $$CHKWHO ^HLOAPI2(.STATE,.WHO,.ERROR) D108 .I $$CHKWHO(.STATE,.WHO,.ERROR) D 109 109 ..I $$SEND(.STATE,.ERROR) D 110 110 ...S WHOTO(I,"QUEUED")=1 … … 190 190 ; 191 191 I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0 192 I HLMSTATE("BATCH"),$L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) S ERROR="SEQUENCE QUEUES NOT SUPPORTED FOR BATCH MESSAGES" Q 0 193 I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D 194 .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") 195 ..S $P(^HLB(HLMSTATE("IEN"),5),"^",2)=1 196 E D 197 .D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) 192 D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) 198 193 Q HLMSTATE("IEN") 199 194 ; 200 195 DONTSEND(HLMSTATE,ERROR) ; 201 ;This procedure does NOT send a message. Rather, it creates an entry in file 778 with the status ER. 196 ;This procedure does NOT send a message. Rather, it creates an entry in file 778 with the 197 ;of "SE". 202 198 ;Input: 203 199 ; HLMSTATE - pass-by-reference … … 207 203 I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue 208 204 ; 209 S HLMSTATE("STATUS")=" ER"205 S HLMSTATE("STATUS")="SE" 210 206 S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE")) 211 207 S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR) 212 208 I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app 213 209 Q 210 ; 211 CHKWHO(HLMSTATE,WHOTO,ERROR) ; 212 N RETURN,I 213 S RETURN=1 214 I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0 215 ; 216 ;move parameters into HLMSTATE 217 S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN")) 218 S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME")) 219 S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2) 220 S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION")) 221 F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I)) 222 Q RETURN -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m
r628 r636 1 HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ; 07/30/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134 ,137**;Oct 13, 1995;Build 211 HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;12/11/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 66 66 .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION")) 67 67 .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I)) 68 .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:" ER")68 .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE") 69 69 .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID")) 70 70 .S ACK("ACK TO","IEN")=HLMSTATE("IEN") … … 117 117 I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20) 118 118 I 'LEN S PARMS("QUEUE")="DEFAULT" 119 D 120 .N APPIEN 121 .I $G(PARMS("SENDING APPLICATION"))="" D Q 122 ..S ERROR="SENDING APPLICATION IS REQUIRED" 123 ..S PARMS("SENDING APPLICATION")="" 124 .E D Q:'APPIEN 125 ..S APPIEN=$$GETIEN^HLOAPP(PARMS("SENDING APPLICATION")) 126 ..I 'APPIEN S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY" 127 .I $L($G(PARMS("SEQUENCE QUEUE"))) D 128 ..I ($L(PARMS("SEQUENCE QUEUE"))>30) S ERROR="SEQUENCE QUEUE NAME > 30 CHARACTERS" Q 129 ..I PARMS("SEQUENCE QUEUE")["^" S ERROR="SEQUENCE QUEUE NAME MAY NOT CONTAIN '^'" Q 130 ..I $G(PARMS("APP ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN APPLICATION ACKNOWLEDGMENT" Q 131 ..I $G(PARMS("ACCEPT ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN ACCEPT ACKNOWLEDGMENT" Q 119 I $G(PARMS("SENDING APPLICATION"))="" D 120 .S ERROR="SENDING APPLICATION IS REQUIRED" 121 .S PARMS("SENDING APPLICATION")="" 122 E D 123 .I '$D(^HLD(779.2,"C",PARMS("SENDING APPLICATION"))) S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY" 132 124 ; 133 125 ;move parameters into HLMSTATE … … 140 132 S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE")) 141 133 S @SARY@("QUEUE")=PARMS("QUEUE") 142 S @SARY@("SEQUENCE QUEUE")=$G(PARMS("SEQUENCE QUEUE"))143 134 Q:$L(ERROR) 0 144 135 Q 1 145 ;146 136 ; 147 137 SETCODE(SEG,VALUE,FIELD,COMP,REP) ; … … 165 155 S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT")) 166 156 Q 167 ;168 CHKWHO(HLMSTATE,WHOTO,ERROR) ;169 N RETURN,I170 S RETURN=1171 I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0172 ;173 ;move parameters into HLMSTATE174 S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))175 S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))176 S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)177 S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))178 F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))179 Q RETURN -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m
r628 r636 1 HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,133,134 ,137**;Oct 13, 1995;Build 211 HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;03/13/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,133,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 92 92 .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) 93 93 .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID") 94 .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:" ER")94 .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE") 95 95 .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR) 96 96 .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE")) -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m
r628 r636 1 HLOAPP ;ALB/CJM-HL7 -Application Registry ; 07/09/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,132 ,137**;Oct 13, 1995;Build 211 HLOAPP ;ALB/CJM-HL7 -Application Registry ;10/31/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**126,132**;Oct 13, 1995;Build 6 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; 5 5 GETIEN(NAME) ;given the application name, it finds the ien. Returns 0 on failure 6 6 Q:'$L($G(NAME)) 0 7 Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0)) 7 N IEN,SUB 8 S SUB=$E(NAME,1,60) 9 S IEN=0 10 F S IEN=$O(^HLD(779.2,"B",SUB,IEN)) Q:'IEN Q:$P($G(^HLD(779.2,IEN,0)),"^")=NAME 11 Q +IEN 8 12 ; 9 13 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 97 S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7)) 94 98 Q ACTIVE 95 ;96 EXCEPT(APPNAME) ;97 ;returns the exception handler (tag^routine) that should be invoked98 ;when an applicaiton's messages are being sequenced and an app ack99 ;is not timely received100 ;101 N IEN,RTN102 S IEN=$$GETIEN($G(APPNAME))103 I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11)104 I $L($G(RTN))>1 Q RTN105 Q "DEFAULT^HLOAPP"106 ;107 DEFAULT ;default exception handler if the app doesn't specify one108 S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))=""109 Q110 ;111 TIMEOUT(APPNAME) ;112 N IEN,TIME113 S IEN=$$GETIEN($G(APPNAME))114 I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12)115 Q:'$G(TIME) 10116 Q TIME -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m
r628 r636 1 HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;0 8/15/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134 ,137**;Oct 13, 1995;Build 211 HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 155 155 .; 156 156 .;try to send the message 157 .;158 .;159 157 .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE) 160 158 .;does the message need an accept ack? … … 170 168 ..S $P(UPDATE,"^",5)=1 171 169 ..S UPDATE("MSA")=ACKID_"^"_MSA 172 ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)=" ER",$P(UPDATE,"^",4)=2170 ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2 173 171 ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1) 174 ..I ($P(UPDATE,"^",3)=" ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref172 ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref 175 173 ..; 176 ..;if it's from a sequence queue, timestamp the queue 177 ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D 178 ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200 179 ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q 180 ...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 181 ...;if the message wasn't accepted, need to notify without waiting 182 ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2) 183 ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) 184 ..; 185 ..;does the app need notification of accept ack? 174 ..;did the app request notification of accept ack? 186 175 ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE") 187 ..;188 176 ..S SUCCESS=1 189 177 .E D ;accept ack wasn't requested -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m
r628 r636 1 HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004 14:43 ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134 ,137**;Oct 13, 1995;Build 211 HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004 14:43 ;03/19/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 146 146 ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS" 147 147 ...S $P(^HLB(MSG,0),"^",20)="TF" 148 ...S ^HLB("ERRORS", RAPP,TIME,MSG)=""148 ...S ^HLB("ERRORS","TF",SAPP,TIME,MSG)="" 149 149 ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT) 150 150 ...S ACTION=$P(NODE0,"^",14,15) -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m
r628 r636 1 HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134 ,137**;Oct 13, 1995;Build 211 HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 53 53 UPDATE(MSGIEN,TIME,PARMS) ; 54 54 S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS") 55 I PARMS("STATUS")="ER" D56 .S ^HLB("ERRORS",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""57 .D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))55 S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)="" 56 S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")="" 57 I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN)) 58 58 S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK") 59 59 S $P(^HLB(MSGIEN,0),"^",16)=TIME … … 101 101 ; "ID" - message id from the header 102 102 ; "IEN" - ien, file 778 103 ; "STATUS","SEQUENCE QUEUE")=name of the sequence queue (optional)104 103 ; 105 104 K MSG … … 147 146 .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2) 148 147 .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2) 149 S MSG("STATUS","SEQUENCE QUEUE")=$P($G(^HLB(IEN,5)),"^")150 148 Q 1 151 149 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m
r628 r636 1 HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,134 ,137**;Oct 13, 1995;Build 211 HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;03/22/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 29 29 .S $P(^HLB(MSGIEN,0),"^",9)=PURGE 30 30 .S ^HLB("AD","OUT",PURGE,MSGIEN)="" 31 .S $P(^HLB(MSGIEN,0),"^",20)=" ER"31 .S $P(^HLB(MSGIEN,0),"^",20)="AE" 32 32 .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT" 33 33 .M HDR=MSG("HDR") 34 34 .Q:'$$PARSEHDR^HLOPRS(.HDR) 35 .S ^HLB("ERRORS", $S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""35 .S ^HLB("ERRORS","AE",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)="" 36 36 .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT"))) 37 37 S:MSGIEN>99999999999 MSGIEN=0 -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m
r628 r636 1 HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;0 7/24/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134 ,137**;Oct 13, 1995;Build 211 HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;03/15/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 17 17 ; ARYTYP = The array where HL7 message resides 18 18 ; HLP = Additional HL7 message parameters (optional, pass by reference) 19 ; These optional subscripts to HLP are supported for input: 20 ; "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received 21 ; "CONTPTR" 19 ; These optional subscripts to HLL are supported for input: 22 20 ; "SECURITY" 23 ; "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. 21 ; "CONTPTR" 22 ; "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received 24 23 ; 25 24 ; HLL (optional, pass by reference) Additional message recipients being dynamically added … … 51 50 . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR") 52 51 . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE") 53 . I $G(HLP("SEQUENCE QUEUE"))'="" S APPARMS("SEQUENCE QUEUE")=HLP("SEQUENCE QUEUE")54 52 . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE") 55 53 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m
r628 r636 1 HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134 ,137**;Oct 13, 1995;Build 211 HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;03/15/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 142 142 .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY")) 143 143 .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS 144 I (STATUS=" ER"),'SKIP D144 I (STATUS="AE"),'SKIP D 145 145 .N APP 146 .S APP=HLMSTATE("HDR"," RECEIVING APPLICATION")146 .S APP=HLMSTATE("HDR","SENDING APPLICATION") 147 147 .I APP="" S APP="UNKNOWN" 148 .S ^HLB("ERRORS", APP,$$NOW^XLFDT,ACKTO("IEN"))=""148 .S ^HLB("ERRORS","AE",APP,$$NOW^XLFDT,ACKTO("IEN"))="" 149 149 .;don't count the error - the app ack was already counted as an error. 150 150 .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"))) -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m
r628 r636 1 HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134 ,137**;Oct 13, 1995;Build 211 HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/07/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 47 47 .S ^HLB("B",ID,IEN)="" 48 48 .S ^HLB("C",HLMSTATE("BODY"),IEN)="" 49 .I ($G(@STAT)=" ER") D50 ..S ^HLB("ERRORS", $S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""49 .I ($G(@STAT)="SE") D 50 ..S ^HLB("ERRORS","SE",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)="" 51 51 ..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"))) 52 52 .; … … 70 70 ;The "SEARCH" x-ref will be created asynchronously 71 71 S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)="" 72 ;73 ;sequence q?74 I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")75 72 ; 76 73 Q IEN -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m
r628 r636 1 HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,131,134 ,137**;Oct 13, 1995;Build 211 HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;03/28/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 115 115 D DEQUE() 116 116 ; 117 ;may need to change the status to Error117 ;may need to change the status to Application Error 118 118 D 119 119 .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW … … 121 121 .S NODE=$G(^HLB(MSGIEN,0)) 122 122 .Q:NODE="" 123 .Q:$P(NODE,"^",20)=" ER"124 .S $P(NODE,"^",20)=" ER",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"123 .Q:$P(NODE,"^",20)="AE" 124 .S $P(NODE,"^",20)="AE",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR" 125 125 .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT") 126 126 .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN) … … 138 138 .I RAPP="" S RAPP="UNKNOWN" 139 139 .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) 140 .S ^HLB("ERRORS", RAPP,NOW,MSGIEN)=""140 .S ^HLB("ERRORS","AE",RAPP,NOW,MSGIEN)="" 141 141 .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN") 142 142 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m
r628 r636 1 HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;0 7/25/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134 ,137**;Oct 13, 1995;Build 211 HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;02/04/2004 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 43 43 ; "PURGE" - scheduled purge dt/tm 44 44 ; "QUEUE" - the queue that the message was placed on 45 ; "SEQUENCE QUEUE" - the sequence queue (optional)46 45 ; 47 46 K MSG … … 96 95 .S MSG("MESSAGE TYPE")=$P(NODE,"^",3) 97 96 .S MSG("EVENT")=$P(NODE,"^",4) 98 I MSG("DIRECTION")="OUT" D99 .N NODE5100 .S NODE5=$G(^HLB(IEN,5))101 .S MSG("STATUS","SEQUENCE QUEUE")=$P(NODE5,"^")102 .S MSG("STATUS","MOVED TO OUT QUEUE")=$P(NODE5,"^",2)103 .S MSG("STATUS","SEQUENCE EXCEPTION RAISED")=$P(NODE5,"^",3)104 97 Q 1 105 98 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m
r628 r636 1 HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004 14:43 ;07/20/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004 14:43 ;05/03/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9 4 3 ; 5 4 N SYSTEM,DATA,VASITE,OLDSITE … … 80 79 S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0" 81 80 Q 82 ;83 P137 ;84 ;move the existing errros to the new structure85 N TYPE86 K ^TMP($J,"HLO ERRORS")87 F TYPE="TF","SE","AE" D88 .M ^TMP($J,"HLO ERRORS",TYPE)=^HLB("ERRORS",TYPE)89 .M ^HLB("ERRORS")=^TMP($J,"HLO ERRORS",TYPE)90 .K ^TMP($J,"HLO ERRORS",TYPE)91 .K ^HLB("ERRORS",TYPE)92 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
r628 r636 1 HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;0 7/25/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136 ,137**;Oct 13, 1995;Build 211 HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;04/30/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 28 28 Q 29 29 OLD778 ; 30 N OLD,START,END,APP,TYPE,TODAY ,PARMS30 N OLD,START,END,APP,TYPE,TODAY 31 31 S TODAY=$$DT^XLFDT 32 32 S OLD=$$FMADD^XLFDT(TODAY,-45) … … 58 58 ; 59 59 ;also kill old errors left lying around 60 D SYSPARMS^HLOSITE(.PARMS) 61 S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) 62 S APP="" 63 F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D 64 .N TIME 60 F TYPE="TF","AE","SE" S APP="" F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D 61 .N TIME,PARMS 62 .D SYSPARMS^HLOSITE(.PARMS) 63 .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) 65 64 .S TIME=0 66 .F S TIME=$O(^HLB("ERRORS", APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",APP,TIME)65 .F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",TYPE,APP,TIME) 67 66 Q 68 67 OLD777 ; … … 102 101 ;if an error status,take care of the "ERRORS" x-ref 103 102 I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D 104 .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN) 105 .I MSG("STATUS")="ER" D 103 .N APP 104 .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP) 105 .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN) 106 .I MSG("STATUS")="AE" D 106 107 ..N SUB 107 108 ..S SUB=MSGIEN_"^" 108 ..K ^HLB("ERRORS", RAPP,MSG("DT/TM CREATED"),SUB)109 ..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)109 ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB) 110 ..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) 110 111 ; 111 112 ;kill the whole-file xrefs for the message ien within a batch -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m
r628 r636 1 HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;0 7/31/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134 ,137**;Oct 13, 1995;Build 211 HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;01/05/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 90 90 I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1 91 91 Q 0 92 ;93 SQUE(SQUE,LINKNAME,PORT,QNAME,IEN778) ;94 ;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.95 ;Input:96 ; SQUE - name of the sequencing queue97 ; LINKNAME = name of (.01) the logical link98 ; PORT (optional) the port to connect to99 ; QNAME (optional) outgoing queue100 ; IEN778 = ien of the message in file 778101 ;Output: 1 if placed on the outgoing queue, 0 if placed on the sequence queue102 ;103 N NEXT,MOVED104 S MOVED=0105 ;106 ;keep a count of messages pending on sequence queues for the HLO System Monitor107 I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")))108 ;109 L +^HLB("QUEUE","SEQUENCE",SQUE):200110 ;111 S NEXT=+$G(^HLB("QUEUE","SEQUENCE",SQUE))112 Q:NEXT=IEN778 0 ;already queued!113 ;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 queue114 I '$O(^HLB("QUEUE","SEQUENCE",SQUE,0)),'NEXT D115 .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;to mean something moved to outgoing but not yet transmitted116 .L -^HLB("QUEUE","SEQUENCE",SQUE)117 .D OUTQUE(.LINKNAME,.PORT,.QNAME,IEN778)118 .S MOVED=1119 E D120 .;Put the message on the sequence queue.121 .S ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)=""122 .L -^HLB("QUEUE","SEQUENCE",SQUE)123 Q MOVED124 ;125 ADVANCE(SQUE,MSGIEN) ;126 ;Will move the specified sequencing queue to the next message.127 ;Input:128 ; SQUE - name of the sequencing queue129 ; 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.130 ;Output:131 ; Function - 1 if advanced, 0 if not132 ;133 N NODE,IEN778,LINKNAME,PORT,QNAME134 Q:'$L($G(SQUE)) 0135 Q:'$G(MSGIEN) 0136 L +^HLB("QUEUE","SEQUENCE",SQUE):200137 ;138 ;do not advance if the queue wasn't pending the message=MSGIEN139 I (MSGIEN'=$P($G(^HLB("QUEUE","SEQUENCE",SQUE)),"^")) L -^HLB("QUEUE","SEQUENCE",SQUE) Q 0140 ;141 I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues142 ;143 S IEN778=0144 ;look for the first message on the sequence que. Make sure its valid, if not remove the invalid entry and keep looking.145 F S IEN778=$O(^HLB("QUEUE","SEQUENCE",SQUE,0)) Q:'IEN778 S NODE=$G(^HLB(IEN778,0)) Q:$L(NODE) D146 .;message does not exist! Remove from queue and try again.147 .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)148 .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues149 ;150 ;IEN778 is the next pending msg on this sequence queue151 I IEN778 D152 .;153 .;parse out info needed to move to outgoing queue154 .S LINKNAME=$P(NODE,"^",5),PORT=$P(NODE,"^",8),QNAME=$P(NODE,"^",6)155 .;156 .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.157 .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) ;remove from sequence queue158 .L -^HLB("QUEUE","SEQUENCE",SQUE)159 .S $P(^HLB(IEN778,5),"^",2)=1160 .D OUTQUE(.LINKNAME,$G(PORT),$G(QNAME),IEN778) ;move to outgoing queue161 E D162 .K ^HLB("QUEUE","SEQUENCE",SQUE) ;this sequence queue is currently empty and not needed163 .L -^HLB("QUEUE","SEQUENCE",SQUE)164 Q 1165 ;166 SEQCHK(WORK) ;functions under the HLO Process Manager167 ;check sequence queues for timeout168 N QUE,NOW169 S NOW=$$NOW^XLFDT170 S QUE=""171 F S QUE=$O(^HLB("QUEUE","SEQUENCE",QUE)) Q:QUE="" D172 .N NODE,MSGIEN,ACTION,NODE173 .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))174 .Q:'$P(NODE,"^",2)175 .Q:$P(NODE,"^",2)>NOW176 .Q:$P(NODE,"^",3)177 .L +^HLB("QUEUE","SEQUENCE",QUE):2178 .;don't report if a lock wasn't obtained179 .Q:'$T180 .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))181 .I '$P(NODE,"^",2) L -^HLB("QUEUE","SEQUENCE",QUE) Q182 .I ($P(NODE,"^",2)>NOW) L -^HLB("QUEUE","SEQUENCE",QUE) Q183 .I $P(NODE,"^",3) L -^HLB("QUEUE","SEQUENCE",QUE) Q ;exception already raised184 .S MSGIEN=$P(NODE,"^")185 .I 'MSGIEN L -^HLB("QUEUE","SEQUENCE",QUE) Q186 .S ACTION=$$EXCEPT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))187 .S $P(^HLB(MSGIEN,5),"^",3)=1188 .S $P(^HLB("QUEUE","SEQUENCE",QUE),"^",3)=1 ;indicates exception raised189 .L -^HLB("QUEUE","SEQUENCE",QUE)190 .D ;call the application to take action191 ..N HLMSGIEN,MCODE,DUZ,QUE,NOW192 ..N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOQUE"193 ..S HLMSGIEN=MSGIEN194 ..S MCODE="D "_ACTION195 ..N MSGIEN,X196 ..D DUZ^XUP(.5)197 ..X MCODE198 ..;kill the apps variables199 ..D200 ...N ZTSK201 ...D KILL^XUSCLEAN202 Q203 ERROR ;error trap for application context204 S $ETRAP="D UNWIND^%ZTER"205 D ^%ZTER206 S $ECODE=",UAPPLICATION ERROR,"207 ;208 ;kill the apps variables209 D210 .N ZTSK,MSGIEN,QUEUE211 .D KILL^XUSCLEAN212 ;213 ;release all the locks the app may have set, except Taskman lock214 L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1215 L:'$D(ZTSK)216 ;reset HLO's lock217 L +^HLTMP("HL7 RUNNING PROCESSES",$J):0218 ;return to processing the next message on the queue219 D UNWIND^%ZTER220 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m
r628 r636 1 HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;0 7/19/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134 ,137**;Oct 13, 1995;Build 211 HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 56 56 ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE) 57 57 ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE) 58 ..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"))59 58 .E D INQUE() H:HLCSTATE("CONNECTED") 1 60 59 ; … … 138 137 .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU" 139 138 .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE") 140 .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"))139 .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")) 141 140 .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT) 142 141 .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE … … 151 150 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" 152 151 .N APP 153 .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS", APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""152 .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))="" 154 153 .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"))) 155 154 ; … … 161 160 .I FROM="" S FROM="UNKNOWN SENDING FACILITY" 162 161 .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION") 163 .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS") ="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1)162 .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1) 164 163 .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 165 164 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m
r628 r636 1 HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;0 7/17/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134 ,137**;Oct 13, 1995;Build 211 HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;03/26/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 52 52 ....S HLMSTATE("ACK TO")=OLDMSGID 53 53 ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID") 54 ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER") 55 ....I $G(IEN) D 56 .....S HLMSTATE("ACK TO","IEN")=IEN 57 .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^") 54 ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE") 55 ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN 58 56 ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT 59 57 ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG) … … 68 66 .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID 69 67 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID 70 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:" ER")68 .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE") 71 69 .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN 72 70 ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG) … … 127 125 ; HLMSTATE("HDR") - the parsed header segment 128 126 ;Output: 129 ; HLMSTATE("STATUS")=" ER" if an error is detected127 ; HLMSTATE("STATUS")="SE" if an error is detected 130 128 ; HLMSTATE("STATUS","QUEUE") queue to put the message on 131 129 ; HLMSTATE("STATUS","ACTION") <tag^rtn> that is the processing routine for the receiving application … … 139 137 E D 140 138 .S WANTACK=1 141 I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")=" ER" Q139 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 142 140 I $G(HLMSTATE("ACK TO"))="" D Q:ERROR 143 .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" Q141 .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 144 142 .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) 145 143 E D Q:ERROR ;this is an app ack … … 147 145 .N NODE 148 146 .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0)) 149 .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" Q150 .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" Q147 .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 148 .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 151 149 .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 152 150 .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry … … 154 152 .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) 155 153 ; 156 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") Q154 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 157 155 ; 158 156 ;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 164 .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q 167 165 .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q 168 I 'PASS S HLMSTATE("STATUS")=" ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"166 I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE" 169 167 I PASS,WANTACK S HLMSTATE("MSA",1)="CA" 170 168 Q … … 215 213 D END^HLOSRVR 216 214 ; 217 ; multi-listenershould stop execution, only a single server may continue215 ;concurrent server connections (multi-listener) should stop execution, only a single server may continue 218 216 I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D Q:$QUIT "" Q 219 .;don't log these errors217 .;don't log these common errors 220 218 .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D 221 219 ..; … … 223 221 ..D ^%ZTER 224 222 ; 225 ; debugging?223 ;while debugging quit on all errors 226 224 I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q 227 225 ; 228 ; possibly an endless loop?226 ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count 229 227 N HOUR 230 228 S HOUR=$E($$NOW^XLFDT,1,10) 229 ; 231 230 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q 232 231 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m
r628 r636 1 HLOSRVR2 ;ALB/CJM-HL7 - HLO Server ;07/20/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**131,137**;Oct 13, 1995;Build 21 3 ;Per VHA Directive 2004-038, this routine should not be modified. 1 HLOSRVR2 ;ALB/CJM-HL7 - Sends an application ack over an open connection, for original mode ;02/04/2004 2 ;;1.6;HEALTH LEVEL SEVEN;**131**;Oct 13, 1995;Build 10 4 3 ; 5 4 NEWMSG(HLCSTATE,HLMSTATE,HDR) ; … … 49 48 S HLMSTATE("MSA",2)=HLMSTATE("ID") 50 49 Q 50 ; 51 ACKNOW(MSG,ERROR) ; 52 ;Sends the messge immediately if there is an open connection, otherwise 53 ;will return an error. 54 ; 55 N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR2" 56 N SENT 57 S SENT=0,ERROR="" 58 I '$G(HLCSTATE("CONNECTED")) D 59 .S ERROR="NOT CONNECTED" 60 .S MSG("STATUS")="TF" 61 E S MSG("STATUS")="SU" 62 S:'$G(MSG("DT/TM CREATED")) MSG("DT/TM CREATED")=$$NOW^XLFDT 63 S MSG("STATUS","PURGE")=$$FMADD^XLFDT(MSG("DT/TM CREATED"),$S($G(HLCSTATE("ERROR PURGE")):HLCSTATE("ERROR PURGE"),1:7)) 64 D 65 .I $G(MSG("UNSTORED LINES")),'$$SAVEMSG^HLOF777(.MSG) S ERROR="$$SAVE^HLOF777 FAILED!" Q 66 .I '$$SAVEMSG^HLOF778(.MSG) S ERROR="$$SAVE^HLOF778 FAILED!" Q 67 .Q:MSG("STATUS")'="SU" 68 .I '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.MSG) S ERROR="TRANSMISSION FAILURE" Q 69 .S SENT=1 70 .D COUNT^HLOSTAT(.HLCSTATE,ACK("HDR","RECEIVING APPLICATION"),ACK("HDR","SENDING APPLICATION"),ACK("HDR","MESSAGE TYPE")_"~"_ACK("HDR","EVENT")) 71 ; 72 END ; 73 I 'SENT,MSG("STATUS")="SU",$G(MSG("IEN")) D 74 .Q:'$D(^HLB(MSG("IEN"),0)) 75 .S MSG("STATUS")="TF" 76 .S MSG("STATUS","ERROR TEXT")=ERROR 77 .S $P(^HLB(MSG("IEN"),0),"^",20)=MSG("STATUS") 78 .S $P(^HLB(MSG("IEN"),0),"^",21)=MSG("STATUS","ERROR TEXT") 79 .S ^HLB("ERRORS","TF",$S($L($G(MSG("HDR","RECEIVING APPLICATION"))):MSG("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),MSG("DT/TM CREATED"),IEN)="" 80 ; 81 Q SENT 82 ; 83 ERROR ;error trap for ACKNOW 84 S SENT=0,ERROR="TRANSMISSION FAILURE:"_$P($ECODE,",",1,2) 85 S $ETRAP="D UNWIND^%ZTER" 86 ; 87 ;don't log some common errors 88 I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D 89 .;nothing! 90 E D 91 .D ^%ZTER 92 G END^HLOSRVR2 93 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m
r628 r636 1 HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;0 7/10/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,131,134 ,137**;Oct 13, 1995;Build 211 HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 129 129 ..S LINE=HLCSTATE("BUFFER",SEGMENT,I) 130 130 ..F Q:'(J+$L(LINE)>MAX) D 131 ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1131 ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") 132 132 ...S LINE=$E(LINE,(MAX-J)+1,99999) 133 133 ...S J=0 134 .. I (LINE]"") W LINE S HLCSTATE("FLUSHED")=0134 ..W:(LINE]"") LINE 135 135 K HLCSTATE("BUFFER") 136 136 S HLCSTATE("BUFFER","SEGMENT COUNT")=1 … … 203 203 .D FLUSH 204 204 .U HLCSTATE("DEVICE") 205 . I ('$G(HLCSTATE("FLUSHED")))!$X W @HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1205 .W:$X @HLCSTATE("FLUSH") 206 206 Q 0 -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m
r628 r636 1 HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004 14:43 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131**;Oct 13, 1995;Build 10 1 HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004 14:43 ;1/23/07 16:59 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,135**;Oct 13, 1995;Build 10 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ; 20 ;; VWSD LOGICAL TO ALLOW A NON-VA STATION ( NODE )WITH $D(HLVWNOVA) VARIABLE EXIST FOR HL LOGICAL LINKS 3 21 ; 4 22 SETSHUT(LINKIEN) ; … … 64 82 ;reserved for officially released links associated with VHA institutions 65 83 ;** EXCEPTION** MPIVA is an official link associated with 200M 66 ; 84 ;***LOCAL VWSD - ALLOW NON-VA STATION (NODE) AS VARIABLE HLVWNOVA TO BE USED TO DETERMINE FACILITY LINK 67 85 Q:'$L($G(STATN)) 0 68 86 ; 69 87 N NAME,IEN 70 88 S (NAME,IEN)="" 71 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 89 ; START LOCAL MOD VWSD FLAG HLVWNOVA 90 ; 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 91 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 92 ;END LOCAL MOD 72 93 Q IEN 73 94 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m
r628 r636 1 HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;0 7/30/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,130,134 ,137**;Oct 13, 1995;Build 211 HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;02/07/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; 5 5 EN ; 6 6 ; 7 N HLSCREEN,TESTOPEN,HLRFRSH ,HLPARMS7 N HLSCREEN,TESTOPEN,HLRFRSH 8 8 D WAIT^DICD 9 9 D EN^VALM("HLO SYSTEM MONITOR") 10 10 Q 11 11 ; 12 BRIEF ; 12 BRIEF ;Init variables and list array 13 13 N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST 14 14 S HLRFRSH="BRIEF^HLOUSR" 15 15 S (HLSCREEN,VALMSG)="Brief System Status" 16 S VALMCNT= 1616 S VALMCNT=8 17 17 ;K @VALMAR 18 18 D CLEAN^VALM10 19 19 S VALMBG=1 20 20 S VALMBCK="R" 21 S VALMDDF("COL 1")="COL1^1^80^"22 21 K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5") 23 D CHGCAP^VALM("COL 1"," 22 D CHGCAP^VALM("COL 1","Brief Operational Overview") 24 23 S @VALMAR@(1,0)="SYSTEM STATUS: "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING") 25 24 S @VALMAR@(2,0)="PROCESS MANAGER: "_$S($$RUNNING:"RUNNING",1:"STOPPED") … … 55 54 ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) 56 55 ..S:TEMP>0 COUNT=COUNT+TEMP 57 S @VALMAR@(8,0)="MESSAGES PENDING ON OUT QUEUES: "_$$RJ(+COUNT,7)_" ON SEQUENCE QUEUES: "_$$RJ(+$G(^HLC("QUEUECOUNT","SEQUENCE")),7)56 S @VALMAR@(8,0)="MESSAGES PENDING TRANSMISSION: "_+COUNT 58 57 S TEMP="STOPPED OUTGOING QUEUES: " 59 58 S COUNT=0,QUE="" … … 66 65 ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM)) 67 66 ..S:TEMP>0 COUNT=COUNT+TEMP 68 S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_$$RJ(+COUNT,7)67 S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_+COUNT 69 68 S TEMP="STOPPED INCOMING QUEUES: " 70 69 S COUNT=0,QUE="" … … 93 92 Q TOTAL 94 93 ; 95 HELP ; 94 HELP ;Help code 96 95 S X="?" D DISP^XQORM1 W !! 97 96 Q 98 97 ; 99 EXIT ; 98 EXIT ;Exit code 100 99 D CLEAN^VALM10 101 100 D CLEAR^VALM1 102 Q 103 ; 104 EXPND ; 101 ; 102 Q 103 ; 104 EXPND ;Expand code 105 105 Q 106 106 ; … … 111 111 S VALMCNT=0 112 112 S VALMBCK="R" 113 S VALMDDF("COL 1")="COL1^1^34^"114 113 S VALMDDF("COL 2")="COL 2^35^10^MIN^H" 115 114 S VALMDDF("COL 3")="COL 3^47^10^MAX^H" … … 194 193 S VALMBCK="R" 195 194 ; 196 ;currently HL7 (Optimized) only does TCP 195 ;currently HL7 (Optimized) only does TCP, when serial added a change is needed here 197 196 S LINK=$$ASKLINK 198 197 Q:LINK="" … … 215 214 Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN) 216 215 ; 217 RUNNING() ; Process Manager running?216 RUNNING() ;Is the Process Manager running? 218 217 N RUNNING 219 218 L +^HLTMP("PROCESS MANAGER"):0 … … 257 256 Q 258 257 ; 259 UPDMODE ; realtime258 UPDMODE ;update mode 260 259 Q:'$L(HLRFRSH) 261 N TOP,BOTTOM,DX,DY,IOTM,IOBM,LINE,OLD,OLDCNT 262 S OLDCNT=VALMCNT 263 W !!!!!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM 264 S IOTM=20,IOBM=23 W @IOSTBM 260 N QUIT,NEW,TOP,BOTTOM,DX,DY,IOTM,IOBM,I 261 W !!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM 262 S IOTM=3,IOBM=23 263 W @IOSTBM 264 S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY 265 I VALMCNT>16 F I=17:1:$S(VALMCNT<22:VALMCNT,1:21) W !,@VALMAR@(I,0) 266 S QUIT=0 265 267 S TOP=VALMBG 266 S BOTTOM=TOP+20 267 F LINE=TOP:1:BOTTOM D 268 .I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q 269 .S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80) 270 F LINE=TOP:1:BOTTOM D 271 .S OLD(LINE)=@VALMAR@(LINE,0) 272 F LINE=17:1:BOTTOM D 273 .S DX=50,DY=22 X IOXY W ! 274 .D WRITE^VALM10(LINE) 275 D F R *C:4 Q:$T D 268 S BOTTOM=TOP+23 269 S OLD=VALMAR 270 S VALMAR="NEW" 271 S VALMCNT=0 272 F D Q:QUIT 273 .N LINE 274 .R *C:3 I $T S QUIT=1 275 .S (VALMCNT,I)=0 276 276 .D @HLRFRSH 277 .F LINE=TOP:1:BOTTOM D 278 ..I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q 279 ..S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80) 280 .S VALMCNT=BOTTOM 281 .F LINE=TOP:1:BOTTOM IF OLD(LINE)'=@VALMAR@(LINE,0) D 282 ..S OLD(LINE)=@VALMAR@(LINE,0) 283 ..S DX=50,DY=22 X IOXY W ! 277 .F LINE=TOP:1:BOTTOM IF $G(@OLD@(LINE,0))'=$G(@VALMAR@(LINE,0)) D 278 ..S:'$D(@VALMAR@(LINE,0)) @VALMAR@(LINE,0)=" " 284 279 ..D WRITE^VALM10(LINE) 285 S VALMCNT=OLDCNT286 S VALMBCK="R" 287 Q 280 K @OLD M @OLD=@VALMAR S VALMAR=OLD 281 S VALMBCK="R" 282 Q -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m
r628 r636 1 HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;0 7/25/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134 ,137**;Oct 13, 1995;Build 211 HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;03/19/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 101 101 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) 102 102 S @VALMAR@($$I,0)="Link: "_$$LJ(MSG("STATUS","LINK NAME"),29)_" "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE") 103 I $L($G(MSG("STATUS","SEQUENCE QUEUE"))) D104 .S @VALMAR@($$I,0)="Sequence Queue: "_MSG("STATUS","SEQUENCE QUEUE")_" Moved: "_$S(MSG("STATUS","MOVED TO OUT QUEUE"):"YES",1:"NO")105 103 I MSG("STATUS","ACCEPT ACK'D") D 106 .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)104 .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) 107 105 .S @VALMAR@($$I,0)=" "_MSG("STATUS","ACCEPT ACK MSA") 108 106 I MSG("DIRECTION")="IN" D -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m
r628 r636 1 HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;0 7/17/20072 ;;1.6;HEALTH LEVEL SEVEN;**126,134 ,137**;Oct 13, 1995;Build 211 HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;03/19/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 3 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 4 ; … … 8 8 Q 9 9 ; 10 SHOWLIST ; 10 SHOWLIST(TYPE) ; 11 ;TYPE= "SE", "AE", "TF" 11 12 N PARMS,I,ERRCOUNT 12 13 S (VALMBG,VALMCNT,I,ERRCOUNT)=0 … … 17 18 .N APP 18 19 .S APP="" 19 .F S APP=$O(^HLB("ERRORS", APP)) Q:APP="" D Q:ERRCOUNT>PARMS("MAX")20 .F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D Q:ERRCOUNT>PARMS("MAX") 20 21 ..N TIME,IEN 21 22 ..S TIME=PARMS("START") 22 ..Q:($O(^HLB("ERRORS", APP,TIME))="")23 ..Q:($O(^HLB("ERRORS",TYPE,APP,TIME))="") 23 24 ..S @VALMAR@($$I,0)="Application: "_APP 24 25 ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) 25 ..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")26 ..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") 26 27 E D 27 28 .N APP … … 29 30 .N TIME,IEN 30 31 .S TIME=PARMS("START") 31 .Q:$O(^HLB("ERRORS", APP,TIME))=""32 .Q:$O(^HLB("ERRORS",TYPE,APP,TIME))="" 32 33 .S @VALMAR@($$I,0)="Application: "_APP 33 34 .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) 34 .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")35 .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") 35 36 ; 36 37 SHOW S VALMBCK="R" 37 38 ; 38 39 Q 39 ADDTO( IEN,TIME,ERRCOUNT) ;40 ADDTO(LTYPE,IEN,TIME,ERRCOUNT) ; 40 41 N NODE,MSG 41 42 Q:'$$GETMSG^HLOMSG(+IEN,.MSG) 42 43 S ERRCOUNT=ERRCOUNT+1 43 ;application errors could be an error to a msg within a batch 44 ;also, need to go to the ack msg to get the error text from the MSA segment 45 ; 46 N SUBIEN,MSA,ERRTEXT 47 S (ERRTEXT,MSA)="" 48 S SUBIEN=$P(IEN,"^",2) 49 ;within batch? 50 D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) 51 S ERRTEXT=MSG("STATUS","ERROR TEXT") 52 I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D 53 .N MSG,SEG,FS,AIEN 54 .S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2) 55 .Q:'$$GETMSG^HLOMSG(AIEN,.MSG) 56 .I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0 57 .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 58 I ERRTEXT="",MSG("ACK BY")="" D 59 .N FS 60 .S FS=$E(MSG("HDR",1),4) 61 .I $L(FS) S ERRTEXT=$P($G(MSG("STATUS","ACCEPT ACK MSA")),FS,4) 62 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) 63 D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) 64 I $L(ERRTEXT)>35 D 65 .S @VALMAR@($$I,0)=$$RJ(" ",45)_$E(ERRTEXT,36,115) 66 S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN 44 I LTYPE'="AE" D 45 .N TYPE 46 .S TYPE=$S(MSG("BATCH"):"BATCH",1:MSG("MESSAGE TYPE")_"~"_MSG("EVENT")) 47 .S @VALMAR@($$I,0)=" "_$$LJ(MSG("ID"),15)_$$LJ(TYPE,8)_$$LJ($$FMTE^XLFDT(TIME,2),20)_MSG("STATUS","ERROR TEXT") 48 .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) 49 .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN 50 E D 51 .;application errors - could be an error to a msg within a batch 52 .;also, need to go to the ack msg to get the error text from the MSA segment 53 .; 54 .N SUBIEN,MSA,ERRTEXT 55 .S (ERRTEXT,MSA)="" 56 .S SUBIEN=$P(IEN,"^",2) 57 .;within batch? 58 .D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) 59 .S ERRTEXT=MSG("STATUS","ERROR TEXT") 60 .I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D 61 ..N MSG,SEG,FS,AIEN 62 ..S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2) 63 ..Q:'$$GETMSG^HLOMSG(AIEN,.MSG) 64 ..I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0 65 ..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 66 .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) 67 .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) 68 .I $L(ERRTEXT)>37 D 69 ..S @VALMAR@($$I,0)="~"_$E(ERRTEXT,38,112) 70 ..D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF) 71 .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN 67 72 Q 68 73 ; … … 95 100 N DIR 96 101 S DIR(0)="F^3:60" 97 S DIR("A")=" ReceivingApplication"102 S DIR("A")="Application" 98 103 S DIR("?")="Enter the full name of the application, or '^' to exit." 104 S DIR("?",1)="For transmission failures, enter the sending application. " 105 S DIR("?",2)="For other errors, enter the name of the receiving application. " 99 106 D ^DIR 100 107 I $D(DIRUT)!(Y="") Q "" … … 221 228 LJ(STRING,LEN) ; 222 229 Q $$LJ^XLFSTR(STRING,LEN) 223 RJ(STRING,LEN) ;224 Q $$RJ^XLFSTR(STRING,LEN)225 230 ; 226 231 I() ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m
r628 r636 1 HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;10/17/2007 09:41 2 ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 ; 1 HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;01/23/06 12:56 2 ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120**;Oct 13, 1995;Build 12 7 3 FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only 8 4 D CREATE(,.HLDA,.HLDT,.HLDT1) … … 75 71 MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.) 76 72 ;return ien in file 773 77 ;78 ; patch HL*1.6*122: MPI-client/server start79 F L +^HL(772,+$G(X)):10 Q:$T H 180 73 Q:'$G(^HL(772,X,0)) 0 81 L -^HL(772,+$G(X))82 ; patch HL*1.6*122: MPI-client/server end83 ;84 74 N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y 85 75 S DIC="^HLMA(",DIC(0)="L" … … 118 108 OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message 119 109 ;Version 1.5 Interface Only 120 ; 121 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, 122 ; OUT, IN, and ACK to HLTF2 routine. 123 ; 124 D OUT^HLTF2($G(HLDA),$G(HLMID),$G(HLMTN)) 110 Q:'$D(HLFS) 111 ; 112 I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"I") Q 113 ; 114 ;-- if message contained MSA find inbound message 115 I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D 116 . N HLDAI 117 . S HLDAI=0 118 . 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") 119 . I 'HLDAI K HLDAI 120 ; 121 D STUFF^HLTF0("O") 122 ; 123 N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) 124 D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN)) 125 ; 126 ;-- update status if MSA and found inbound message 127 I $D(HLMSA),$D(HLDAI) D 128 .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) 129 .S HLAC=$P(HLMSA,HLFS,2) 130 .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR 131 .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) 125 132 Q 126 133 ; 127 134 IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message 128 135 ;Version 1.5 Interface Only 129 ; 130 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, 131 ; OUT, IN, and ACK to HLTF2 routine. 132 ; 133 D IN^HLTF2($G(HLMTN),$G(HLMID),$G(HLTIME)) 136 Q:'$D(HLFS) 137 I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"O",$G(HLDA)) Q 138 ; 139 N HLDAI S HLDA=0 140 I $D(HLNDAP),HLMID]"" D 141 .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") 142 .I HLDA D 143 ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT) 144 ..K ^HL(772,HLDA,"IN") 145 .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D 146 ..S HLDAI=0 147 ..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") 148 ..I 'HLDAI K HLDAI 149 ; 150 I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ 151 ; 152 D STUFF^HLTF0("I") 153 N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) 154 ; 155 D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME) 156 ; 157 I '$D(HLERR),$D(HLMSA),$D(HLDAI) D 158 .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) 159 .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR 160 .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) 134 161 Q 135 162 ; 136 163 ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only 137 ; 138 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, 139 ; OUT, IN, and ACK to HLTF2 routine. 140 ; 141 D ACK^HLTF2($G(HLMSA),$G(HLIO),$G(HLDA)) 164 ; To determine the correct message to link the ACK, HLIO is used. 165 ; For an ack from DHCP (original message from remote system) then 166 ; HLIO should be "I" so that the correct inbound message is ack-ed. For 167 ; an inbound ack (original message outbound from DHCP) HLIO should be 168 ; "O". This distinction must be made due to the possible duplicate 169 ; message ids from a bi-direction interface. 170 ; 171 ; Input : MSA - MSA from ACK message. 172 ; HLIO - Either "I" or "O" : See note above. 173 ;Output : None 174 ; 175 N HLAC,HLMIDI 176 ;-- set up required vars 177 S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3) 178 ;-- quit 179 Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP)) 180 ;-- find message to ack 181 I '$G(HLDA) S HLDA=0 D 182 . 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) 183 ;-- quit if no message 184 Q:'$D(^HL(772,+HLDA,0)) 185 ;-- check for error 186 I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4) 187 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 188 ;-- update status 189 S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3) 190 D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) 142 191 Q 143 192 ; … … 152 201 I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) 153 202 ; 154 I OS'["DSM",OS'["OpenM" D 203 ; patch HL*1.6*120, protect Else command 204 ; I OS'["DSM",OS'["OpenM" D 205 I OS'["DSM",OS'["OpenM" D I 1 155 206 .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 156 207 E D 157 208 .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 158 ;159 ; patch HL*1.6*122: MPI-client/server start160 F L +^HL(772,IEN):10 Q:$T H 1161 209 S ^HL(772,IEN,0)=$G(FLD01)_"^" 162 210 I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)="" 163 L -^HL(772,IEN)164 ; patch HL*1.6*122: MPI-client/server end165 ;166 211 Q IEN 167 212 ; … … 176 221 I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) 177 222 ; 178 I OS'["DSM",OS'["OpenM" D 223 ; patch HL*1.6*120, protect Else command 224 ; I OS'["DSM",OS'["OpenM" D 225 I OS'["DSM",OS'["OpenM" D I 1 179 226 .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 180 227 E D 181 228 .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 182 ;183 ; patch HL*1.6*122: MPI-client/server184 F L +^HLMA(IEN):10 Q:$T H 1185 229 S ^HLMA(IEN,0)=$G(FLD01)_"^" 186 230 I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)="" 187 L -^HLMA(IEN)188 ;189 231 Q IEN -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m
r628 r636 1 HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007 09:43 2 ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 1 HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;09/10/98 11:21 2 ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78**;Oct 13, 1995 5 3 MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into 6 4 ;Message Text File … … 69 67 N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 70 68 ; 71 ; patch HL*1.6*122: MPI-client/server72 F L +^HL(772,+$G(MTIEN)):10 Q:$T H 173 ;74 69 ;Merge data from a global array with two subscript 75 70 I ARAYTYPE="G",$G(SUB2)'="" D … … 105 100 ;-- update 0 node for message text 106 101 S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" 107 ;108 ; patch HL*1.6*122: MPI-client/server109 L -^HL(772,+$G(MTIEN))110 102 ; 111 103 ;File message statistics -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m
r628 r636 1 HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007 09:44 2 ;;1.6;HEALTH LEVEL SEVEN;**25,122**;Oct 13, 1995;Build 14 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 1 HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97 13:56 2 ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995 5 3 MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server 6 4 ;Module Logical Link File into Message Text File … … 27 25 N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE 28 26 S (FLG,HLCHAR,HLEVN,X)=0 29 ;30 ; patch HL*1.6*122: MPI-client/server31 F L +^HL(772,+$G(MTIEN)):10 Q:$T H 132 27 ; 33 28 ;Move data from Logical Link file to Message Text file … … 56 51 S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" 57 52 ;Update statistics in Message Text file for this entry 58 ;59 ; patch HL*1.6*122: MPI-client/server60 L -^HL(772,+$G(MTIEN))61 ;62 53 D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) 63 54 Q … … 89 80 S I=0 90 81 ; 91 ; patch HL*1.6*122: MPI-client/server92 F L +^HLCS(870,+$G(LLD0),2,+$G(LLD1)):10 Q:$T H 193 ;94 82 ;-- move header into 870 from HDR array 95 83 S X="" F S X=$O(@HDR@(X)) Q:'X D … … 104 92 S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" 105 93 ; 106 ; patch HL*1.6*122: MPI-client/server107 L -^HLCS(870,+$G(LLD0),2,+$G(LLD1))108 ;109 94 Q 110 OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message111 ;Version 1.5 Interface Only112 ;113 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,114 ; OUT, IN, and ACK to HLTF2 routine.115 ;116 Q:'$D(HLFS)117 ;118 I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"I") Q119 ;120 ;-- if message contained MSA find inbound message121 I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D122 . N HLDAI123 . S HLDAI=0124 . 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")125 . I 'HLDAI K HLDAI126 ;127 D STUFF^HLTF0("O")128 ;129 N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))130 D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))131 ;132 ;-- update status if MSA and found inbound message133 I $D(HLMSA),$D(HLDAI) D134 .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)135 .S HLAC=$P(HLMSA,HLFS,2)136 .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR137 .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))138 Q139 ;140 IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message141 ;Version 1.5 Interface Only142 ;143 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,144 ; OUT, IN, and ACK to HLTF2 routine.145 ;146 Q:'$D(HLFS)147 I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"O",$G(HLDA)) Q148 ;149 N HLDAI S HLDA=0150 I $D(HLNDAP),HLMID]"" D151 .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")152 .I HLDA D153 ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)154 ..K ^HL(772,HLDA,"IN")155 .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D156 ..S HLDAI=0157 ..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")158 ..I 'HLDAI K HLDAI159 ;160 ; patch HL*1.6*122: MPI-client/server161 ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ162 I 'HLDA D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ163 ;164 D STUFF^HLTF0("I")165 N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))166 ;167 D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)168 ;169 I '$D(HLERR),$D(HLMSA),$D(HLDAI) D170 .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)171 .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR172 .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))173 Q174 ;175 ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only176 ;177 ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,178 ; OUT, IN, and ACK to HLTF2 routine.179 ;180 ; To determine the correct message to link the ACK, HLIO is used.181 ; For an ack from DHCP (original message from remote system) then182 ; HLIO should be "I" so that the correct inbound message is ack-ed. For183 ; an inbound ack (original message outbound from DHCP) HLIO should be184 ; "O". This distinction must be made due to the possible duplicate185 ; message ids from a bi-direction interface.186 ;187 ; Input : MSA - MSA from ACK message.188 ; HLIO - Either "I" or "O" : See note above.189 ;Output : None190 ;191 N HLAC,HLMIDI192 ;-- set up required vars193 S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)194 ;-- quit195 Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))196 ;-- find message to ack197 I '$G(HLDA) S HLDA=0 D198 . 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)199 ;-- quit if no message200 Q:'$D(^HL(772,+HLDA,0))201 ;-- check for error202 I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)203 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:"")_" - "_HLERR204 ;-- update status205 S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)206 D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))207 Q208 ; -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m
r628 r636 1 HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ; 10/05/2007 15:172 ;;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 141 HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006 2 ;;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 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; 5 5 Q 6 NEW(X) ;process new msg. ien in 773^ ien in 7727 ;HLMTIENS=ien in #773 ; HLMTIEN=ien in #7726 NEW(X) ;process new msg. ien in 773^msg. ien in 772 7 ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text 8 8 ;HLHDRO=original header; HLHDR=response header 9 9 ;set error trap … … 21 21 . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4 22 22 . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP) 23 . ;write ack back 23 . ;write ack back over connection 24 24 . S X=$$WRITE^HLCSTCP2(HLTCP) 25 25 . ;update counter to sent 26 26 . D LLCNT^HLCSTCP(HLDP,4) 27 . ;update status of ack 27 . ;update status of ack to complete 28 28 . D STATUS^HLTF0(HLTCP,3,,,1) 29 29 ; 30 30 ;check for duplicate msg., use rec. app and msg. id x-ref 31 31 ; patch HL*1.6*120 32 ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) 32 33 I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) 33 34 . ;HLASTMSG=last ien received during this connection … … 41 42 .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q 42 43 .; 43 . ;msg is duplicate, set status 44 . ;msg is duplicate, set status as duplicate 44 45 . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT 45 . ;msg was resent , ignore it.46 . ;msg was resent during this connection, ignore it. 46 47 . I HLASTMSG=HLMTIENS K HLMTIENS Q 47 48 . ;find original response and send back 48 49 . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS)) 49 50 ; 50 ;Quit if this is ack to ack51 ;Quit if this is acknowledgment to acknowledgement message 51 52 I $G(HL("ACK")) D Q 52 . ;Update status of original ack message53 . ;Update status of original acknowledgment message to successfully 53 54 . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1) 54 55 . ;unlock record … … 76 77 ; patch HL*1.6*120 start 77 78 ;resending old response, msg is a resend 78 ; do not re-send duplicate when $G(HL("ACAT"))="AL" 79 ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK 80 ; do not re-send duplicate message when $G(HL("ACAT"))="AL" 79 81 I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK 80 82 ; quit if duplicate … … 90 92 . ;X=1 if ack ok, 0=reject of error 91 93 . S X=$E(HLMSA,2)="A" 92 . ;Update status of original message and remove it from thequeue94 . ;Update status of original subscriber message and remove it from the out-going queue 93 95 . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1) 94 96 . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS")) 95 97 . D 96 .. N HLTCP ; variable to update status in file #772.98 .. N HLTCP ;New variable to update status in file #772. 97 99 ..; 98 100 ..;**108** … … 104 106 ..; 105 107 .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) 106 . ;update status of incoming & unlock108 . ;update status of incoming to complete & unlock 107 109 . 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 108 110 ; … … 123 125 ;update status of incoming to complete & unlock 124 126 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 125 ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK127 ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK 126 128 ACK I $G(HLTCPO),$G(HLTCP) D Q 127 129 . D LLCNT^HLCSTCP(HLDP,3) … … 137 139 ; 138 140 ; patch HL*1.6*120 start 139 ; clean non-Kernelvariables141 ; clean variables except Kernel related variables 140 142 D 141 143 . ; protect variables defined in STARTIN^HLCSIN … … 152 154 N HLERR ;patch HL*1.6*109 153 155 Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0)) 156 ;**109 START** 154 157 Q:'$D(^HLMA("AC","I",HLDP,X)) 158 ;**109 END** 155 159 ; 156 160 N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1 161 ;setup variables 157 162 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")="""""" 158 163 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 169 M HLHDRO=^HLMA(HLMTIENS,"MSH") 165 170 ; if no header quit 171 ;**109** 172 ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q 166 173 Q:'$O(HLHDRO(0)) 167 174 ; 168 175 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) 169 176 ; 177 ; patch HL*1.6*109 start 170 178 ; quit if ien of #772 is not defined 171 179 Q:'HLMTIEN 172 180 ; quit if field separator is not defined 173 181 Q:HL("FS")="" 182 ; patch HL*1.6*109 end 174 183 ; 175 184 S X=$$P^HLTPCK2(.HLHDRO,1) … … 187 196 . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4) 188 197 . ; 189 . ; original codeincorrectly treats repetition separator as198 . ; original implementation incorrectly treats repetition separator as 190 199 . ; subcomponent separator 191 200 . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D … … 206 215 . 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) 207 216 ; 217 ; HL*1.6*108 208 218 ; quit if this is a commit ack 209 219 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 220 ; ** 210 221 ; 211 222 ;** HL*1.6*117 ** 212 223 K HLL("SET FOR APP ACK"),HLL("LINKS") 224 ;** END HL*1.6*117 ** 213 225 ; 214 226 D CONT … … 217 229 MSA(Y) ;Y=ien in 772, returns MSA segment 218 230 ;ack code^msg being ack id^text 219 ; patch HL*1.6*122 220 ; for HL7 v2.5 and beyond with MSA as 3rd segment 221 N X,SUBIEN,DATA,DONE 231 N X 222 232 S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") 223 Q:X]"" X224 ;225 S DONE=0226 S SUBIEN=1227 F S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN D Q:DONE228 . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D229 .. S DONE=1230 .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN231 .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")232 ; patch HL*1.6*122 end233 ;234 233 Q X 235 234 ; … … 237 236 D ^%ZTER 238 237 I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT 239 ; releaselocks created by inbound filer238 ;*109* release all locks created by inbound filer 240 239 L -^HLMA("AC","I",+$G(HLXX)) 241 240 G UNWIND^%ZTER -
FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m
r628 r636 1 HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ; 10/04/2007 16:002 ;;1.6;HEALTH LEVEL SEVEN;**120,133 ,122**;Oct 13, 1995;Build 141 HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13 3 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 4 ; … … 23 23 . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10) 24 24 . ;if no subscriber protocol then response msg. is invalid 25 . ; 26 . ; patch HL*1.6*122 start 27 . ; comment out the following code: for patch 109- dynamic addressing 28 . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q 25 . I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q 29 26 . ;get message text ien in file 772 and server protocol, 'EID' 30 27 . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10) 31 28 . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q 32 . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) 33 . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) 34 . ; patch HL*1.6*122 end 29 . D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) 35 30 ; 36 31 ;Find Server Protocol - based on sending application, message type,
Note:
See TracChangeset
for help on using the changeset viewer.
