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

HLCSTCP1.m

Go to the documentation of this file. 
  1. HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;07/08/2009  15:27
  1.  ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140,142,145,165**;OCT 13,1995;Build 2
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;Receiver
  1.  ;connection is initiated by sender and listener accepts connection
  1.  ;and calls this routine
  1.  ;
  1.  N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
  1.  N HLMIEN,HLASTMSG
  1.  ;
  1.  ; patch HL*1.6*140, save IO
  1.  S HLTCPORT("IO")=IO ;RWF
  1.  ; patch HL*1.6*122 start
  1.  ; variable to replace ^TMP
  1.  N HLTMBUF
  1.  ;
  1.  ; for HL7 application proxy user
  1.  ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
  1.  N HLDUZ
  1.  S HLDUZ=+$G(DUZ)
  1.  ;
  1.  D MON^HLCSTCP("Open")
  1.  ; K ^TMP("HLCSTCP",$J,0)
  1.  S HLMIEN=0,HLASTMSG=""
  1.  ;
  1.  ; patch HL*1.6*122 TEST v2: DUZ code removed
  1.  ; set DUZ for application proxy user
  1.  ;; D PROXY^HLCSTCP4
  1.  ;
  1.  F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
  1.  . ; clean variables
  1.  . D CLEANVAR^HLCSTCP4
  1.  . ; patch HL*1.6*140, restore the saved IO
  1.  . S IO=HLTCPORT("IO") ;RWF
  1.  . S HLMIEN=$$READ
  1.  . Q:'HLMIEN
  1.  . ;
  1.  . ; patch HL*1.6*122 TEST v2: DUZ code removed
  1.  . ; DUZ comparison/reset for application proxy user
  1.  . ;; D HLDUZ^HLCSTCP4
  1.  . D HLDUZ2^HLCSTCP4
  1.  . ; protect HLDUZ
  1.  . N HLDUZ
  1.  . D PROCESS
  1.  ; patch HL*1.6*122 end
  1.  Q
  1.  ;
  1. PROCESS ;check message and reply
  1.  ;HLDP=LL in 870
  1.  N HLTCP,HLTCPI,HLTCPO
  1.  S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
  1.  ; patch HL*1.6*145 start
  1.  ; variable HLDP("HLLINK") will be used as the client link ien,
  1.  ; in which the incoming original messages received by listener
  1.  ; will be stored and the messages in the client link queue will
  1.  ; be processed by incoming filer.
  1.  ; variable HLDP("SETINQUE")=1 to indicate the x-ref
  1.  ; ^HLMA("AC","I",<ien of link>,<ien of message>) is set.
  1.  ; initilizes to 0.
  1.  S HLDP("HLLINK")=0
  1.  S HLDP("SETINQUE")=0
  1.  ; patch HL*1.6*145 end
  1.  ;
  1.  ;update monitor, msg. received
  1.  D LLCNT^HLCSTCP(HLDP,1)
  1.  D NEW^HLTP3(HLMIEN)
  1.  ;
  1.  ; patch HL*1.6*145 start
  1.  ; quit if x-ref ^HLMA("AC","I",<ien of link>,<ien of message>)
  1.  ; was set, and counter will be incrmented later after message
  1.  ; being processed.
  1.  Q:HLDP("SETINQUE")
  1.  ;update monitor, msg. processed
  1.  I HLDP("HLLINK") D LLCNT^HLCSTCP(HLDP("HLLINK"),2) Q
  1.  D LLCNT^HLCSTCP(HLDP,2)
  1.  ; patch HL*1.6*145 end
  1.  Q
  1.  ;
  1. READ() ;read 1 message, returns ien in 773^ien in 772 for message
  1.  D MON^HLCSTCP("Reading")
  1.  N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
  1.  ;HLDSTRT=start char., HLDEND=end char., HLRS=record separator
  1.  S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
  1.  ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
  1.  ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack
  1.  ; HL*1.6*122 start
  1.  ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
  1.  S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK
  1.  N HLBUFF,HLXX,MAXWAIT
  1.  ; based on patch 132 for readtime
  1.  S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD)
  1.  S HLRS("START-FLAG")=0
  1.  S HLTMBUF(0)=""
  1.  ; variable used to store data in HLBUFF
  1.  S HLX(1)=$G(HLTMBUF(1))
  1.  S HLTMBUF(1)=""
  1.  S HLBUFF("START")=0
  1.  S HLBUFF("END")=0
  1.  I (HLX]"")!(HLX(1)]"") D
  1.  . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D
  1.  .. S HLBUFF("START")=1
  1.  . I (HLX[HLDEND)!(HLX(1)[HLDEND) D
  1.  .. S HLBUFF("END")=1
  1.  F  D RDBLK Q:HLRDOUT
  1.  ;**132**
  1.  ;switch to null device if opened to prevent 'leakage'
  1.  I $G(IO(0))]"",IO(0)'=IO U IO(0)
  1.  ;
  1.  ;save any excess for next time
  1.  S:HLX]"" HLTMBUF(0)=HLX
  1.  S:HLX(1)]"" HLTMBUF(1)=HLX(1)
  1.  I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
  1.  Q HLIND1
  1.  ;
  1. RDBLK ;
  1.  ; initialize
  1.  S HLBUFF=""
  1.  ;
  1.  ;S HLDB=HLDBSIZE-$L(HLX)
  1.  ; store the total length of HLX and HLX(1) in HLDB(1)
  1.  S HLDB(1)=$L(HLX)+$L(HLX(1))
  1.  ;
  1.  ;**132 **
  1.  ;U IO R X#HLDB:HLDREAD
  1.  ; U IO R X#HLDB:MAXWAIT
  1.  ;
  1.  ; remove the readcount to speedup GT.M
  1.  U IO
  1.  R:(HLDB(1)<HLDBSIZE) HLBUFF:MAXWAIT
  1.  ;
  1.  I HLBUFF]"" D
  1.  . I HLBUFF[HLDSTRT,(HLBUFF("START")=0) D
  1.  .. ; remove the extraneous text prefixing the "START" char
  1.  .. I $P(HLBUFF,HLDSTRT)]"" S HLBUFF=HLDSTRT_$P(HLBUFF,HLDSTRT,2,99)
  1.  .. S HLBUFF("START")=1
  1.  . ;
  1.  . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
  1.  ; detect disconnect for GT.M
  1.  I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
  1.  ; timedout, <clean up>, quit
  1.  ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
  1.  ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q
  1.  ; patch HL*1.6*140
  1.  ; I '$T,HLBUFF="",HLX="",HLX(1)="" D  Q
  1.  I HLBUFF="",HLX="",HLX(1)="" D  Q
  1.  . D:('HLHDR)&('HLIND1) CLEAN
  1.  ;add incoming line to what wasn't processed in last read
  1.  ;S HLX=$G(HLX)_X
  1.  ; get block of characters from read buffer HLBUFF
  1.  ; every 'for-loop' deal with one read at most, and one message at most
  1.  ; if HLX is not empty, loop continues even no data is read
  1.  ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done
  1.  ; quit, when HLRDOUT is set to 1, means one message is encountered
  1.  ; an "end"
  1.  ; F  D  Q:HLXX=""!(HLRDOUT)
  1.  F  D  Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)=""))
  1.  . ;
  1.  . ; if HLX(1) is not empty
  1.  . I HLX(1)]"" D
  1.  .. ; hldb(2) is the number of characters extracted from hlx(1)
  1.  .. ; to be concatenated with hlx
  1.  .. S HLDB(2)=HLDBSIZE-$L(HLX)
  1.  .. ; hlx(2) stores the first hldb(2) characters extracted
  1.  .. ; from hlx(1)
  1.  .. S HLX(2)=$E(HLX(1),1,HLDB(2))
  1.  .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1)))
  1.  .. S HLX=$G(HLX)_HLX(2)
  1.  . ;
  1.  . ; if HLX(1) is empty, and HLBUFF contains data
  1.  . ; all the data in hlx(1) need to be extracted first
  1.  . I HLX(1)="",HLBUFF]"" D
  1.  .. S HLDB=HLDBSIZE-$L(HLX)
  1.  .. S HLXX=$E(HLBUFF,1,HLDB)
  1.  .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF))
  1.  .. S HLX=$G(HLX)_HLXX
  1.  . ; quit when HLX is empty
  1.  . Q:(HLX="")
  1.  . ; ** 132 **
  1.  . ; if no segment end, HLX not full, go back for more
  1.  . I $L(HLX)<HLDBSIZE,HLX'[HLRS,HLX'[HLDEND Q
  1.  . ;add incoming line to what wasn't processed
  1.  . D RDBLK2
  1.  ;
  1.  ; it is possible one message is encountered an "end" and other
  1.  ; messages left in buffer,HLBUFF, save it in HLX for next run
  1.  I HLBUFF]"" D
  1.  . ; variable HLBUFF may remain data with size more than HLDBSIZE
  1.  . ; variable HLBUFF is not empty, only if the total length of
  1.  . ; HLX and HLX(1) is less than HLDBSIZE and HLX(1) should be
  1.  . ; empty when the command s hlx(1)=$g(hlx(1))_hlbuff is executed
  1.  . ; use hlx(1) to store the data of hlbuff to avoid "MAXTRING" error
  1.  . S HLX(1)=$G(HLX(1))_HLBUFF
  1.  . S HLBUFF=""
  1.  Q
  1.  ;
  1. RDBLK2 ;data stream: <sb>dddd<cr><eb><cr>
  1.  ; HL*1.6*122 end
  1.  ; look for segment= <CR>
  1.  F  Q:HLX'[HLRS  D  Q:HLRDOUT
  1.  . ; Get the first piece, save the rest of the line
  1.  . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
  1.  . ; check for start block, Quit if no ien
  1.  . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
  1.  .. S HLRS("START-FLAG")=1 ; HL*1.6*122
  1.  .. D:HLMSG(HLINE,0)[HLDSTRT
  1.  ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
  1.  ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
  1.  ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
  1.  ... D RESET:(HLINE>1)
  1.  .. ;
  1.  .. ; patch HL*1.6*122
  1.  .. ; if the first line less than 10 characters
  1.  .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D
  1.  ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10)
  1.  ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999)
  1.  .. ;
  1.  .. ;ping message
  1.  .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
  1.  .. ; get next ien to store
  1.  .. D MIEN^HLCSTCP4
  1.  .. K HLMSG
  1.  .. S (HLINE,HLHDR)=0
  1.  . ; check for end block; <eb><cr>
  1.  . I HLMSG(HLINE,0)[HLDEND D
  1.  .. ; patch HL*1.6*122 start
  1.  .. ;no msg. ien
  1.  .. ; Q:'HLIND1
  1.  .. I 'HLIND1 D CLEAN Q
  1.  .. ; Kill just the last line if no data before HLDEND
  1.  .. I $P(HLMSG(HLINE,0),HLDEND)']"" D
  1.  ... K HLMSG(HLINE,0) S HLINE=HLINE-1
  1.  .. E  S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND)
  1.  .. ; patch HL*1.6*122 end
  1.  .. ;
  1.  .. ; move into 772
  1.  .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
  1.  .. ;mark that end block has been received
  1.  .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
  1.  .. S $P(HLIND1,U,3)=1
  1.  .. S HLBUFF("HLIND1")=HLIND1
  1.  .. ;reset variables for next message
  1.  .. D CLEAN
  1.  . ;add blank line for carriage return
  1.  . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
  1.  Q:HLRDOUT
  1.  ;If the line is long and no <CR> move it into the array.
  1.  I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
  1.  . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
  1.  ;have start block but no record separator
  1.  I HLX[HLDSTRT D  Q
  1.  . ;check for more than 1 start block
  1.  . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
  1.  . ;
  1.  . ; patch HL*1.6*122
  1.  . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
  1.  . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
  1.  . ;
  1.  . D RESET:(HLHDR&(HLINE>1))
  1.  ;if no ien, reset
  1.  ; patch HL*1.6*122
  1.  ; I 'HLIND1 D CLEAN Q
  1.  I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q
  1.  ;HL*1.6*165
  1.  ;if ENDBLOCK without ien reset
  1.  I HLX[HLDEND,'HLIND1 D CLEAN Q
  1.  ; big message-merge from local to global every 100 lines
  1.  I (HLINE-$O(HLMSG(0)))>100 D
  1.  . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
  1.  . ; reset working array
  1.  . K HLMSG
  1.  Q
  1.  ;
  1. SAVE(SRC,DEST) ;save into global & set top node
  1.  ;SRC=source array (passed by ref.), DEST=destination global
  1.  ;
  1.  ; patch HL*1.6*122: MPI-client/server
  1.  I DEST["HLMA" D
  1.  . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
  1.  E  D
  1.  . F  L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T  H 1
  1.  ;
  1.  M @DEST=SRC
  1.  S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
  1.  ;
  1.  I DEST["HLMA" L -^HLMA(+HLIND1)
  1.  E  L -^HL(772,+$P(HLIND1,U,2))
  1.  ;
  1.  Q
  1.  ;
  1. DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
  1.  N DIK,DA
  1.  S DA=+HLMAMT,DIK="^HLMA("
  1.  D ^DIK
  1.  S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
  1.  D ^DIK
  1.  Q
  1. PING ;process PING message
  1.  S X=HLMSG(1,0)
  1.  ; patch HL*1.6*140, flush character- HLTCPLNK("IOF")
  1.  ; I X[HLDEND U IO W X,! D
  1.  ; I X[HLDEND U IO W X,HLTCPLNK("IOF") D
  1.  ; patch HL*1.6*142
  1.  I X[HLDEND U IO W X,@HLTCPLNK("IOF") D
  1.  . ; switch to null device if opened to prevent 'leakage'
  1.  . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0)
  1. CLEAN ;reset var. for next message
  1.  K HLMSG
  1.  S HLINE=0,HLRDOUT=1
  1.  Q
  1.  ;
  1. ERROR ; Error trap for disconnect error and return back to the read loop.
  1.  ; patch HL*1.6*122
  1.  ; move to routine HLCSTCP4 (splitted-size over 10000)
  1.  D ERROR1^HLCSTCP4
  1.  Q
  1.  ;
  1. CC(X) ;cleanup and close
  1.  D MON^HLCSTCP(X)
  1.  H 2
  1.  Q
  1. RESET ;reset info as a result of no end block
  1.  N %
  1.  S HLMSG(1,0)=HLMSG(HLINE,0)
  1.  F %=2:1:HLINE K HLMSG(%,0)
  1.  S HLINE=1
  1.  Q