HLCSTCP1.m

HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006

 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133**;JUL 17,1995;Build 13

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;Receiver

 ;connection is initiated by sender and listener accepts connection

 ;and calls this routine

 ;

 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"

 N HLMIEN,HLASTMSG

 D MON^HLCSTCP("Open")

 K ^TMP("HLCSTCP",$J,0)

 S HLMIEN=0,HLASTMSG=""

 F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3

 . S HLMIEN=$$READ

 . Q:'HLMIEN

 . D PROCESS

 Q

 ;

PROCESS ;check message and reply

 ;HLDP=LL in 870, update monitor, received msg.

 N HLTCP,HLTCPI,HLTCPO

 S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN

 ;update monitor, msg. received

 D LLCNT^HLCSTCP(HLDP,1)

 D NEW^HLTP3(HLMIEN)

 ;update monitor, msg. processed

 D LLCNT^HLCSTCP(HLDP,2)

 Q

 ;

READ() ;read 1 message, returns ien in 773^ien in 772 for message

 D MON^HLCSTCP("Reading")

 N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X

 ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator

 S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)

 ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772

 ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack

 S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK

 K ^TMP("HLCSTCP",$J,0)

 F  D RDBLK Q:HLRDOUT

 ;save any excess for next time

 S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX

 I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0

 Q HLIND1

 ;

RDBLK S HLDB=HLDBSIZE-$L(HLX)

 U IO R X#HLDB:HLDREAD

 ;switch to null device if opened to prevent 'leakage'

 I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)

 ; timedout, check ack timeout, clean up

 I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q

 ;data stream: <sb>dddd<cr><eb><cr>

 ;add incoming line to what wasn't processed in last read

 S HLX=$G(HLX)_X

 ; look for segment= <CR>

 F  Q:HLX'[HLRS  D  Q:HLRDOUT

 . ; Get the first piece, save the rest of the line

 . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)

 . ; check for start block, Quit if no ien

 . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q

 .. D:HLMSG(HLINE,0)[HLDSTRT

 ... S X=$L(HLMSG(HLINE,0),HLDSTRT)

 ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)

 ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)

 ... D RESET:(HLINE>1)

 .. ;ping message

 .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q

 .. ; get next ien to store

 .. D MIEN

 .. K HLMSG

 .. S (HLINE,HLHDR)=0

 . ; check for end block; HLMSG(HLINE) = <eb><cr>

 . I HLMSG(HLINE,0)[HLDEND D

 .. ;no msg. ien

 .. Q:'HLIND1

 .. ; Kill just the last line

 .. K HLMSG(HLINE,0) S HLINE=HLINE-1

 .. ; move into 772

 .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")

 .. ;mark that end block has been received

 .. ;HLIND1=ien in 773^ien in 772^1 if end block was received

 .. S $P(HLIND1,U,3)=1

 .. ;reset variables for next message

 .. D CLEAN

 . ;add blank line for carriage return

 . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""

 Q:HLRDOUT

 ;If the line is long and no <CR> move it into the array. 

 I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q

 . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""

 ;have start block but no record seperator

 I HLX[HLDSTRT D  Q

 . ;check for more than 1 start block

 . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)

 . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1

 . D RESET:(HLHDR&(HLINE>1))

 ;if no ien, then we don't have start block, reset

 I 'HLIND1 D CLEAN Q

 ; big message-merge from local to global every 100 lines

 I (HLINE-$O(HLMSG(0)))>100 D

 . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG

 . ; reset working array

 . K HLMSG

 Q

 ;

SAVE(SRC,DEST) ;save into global & set top node

 ;SRC=source array (passed by ref.), DEST=destination global

 M @DEST=SRC

 S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"

 Q

 ;

DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.

 N DIK,DA

 S DA=+HLMAMT,DIK="^HLMA("

 D ^DIK

 S DA=$P(HLMAMT,U,2),DIK="^HL(772,"

 D ^DIK

 Q

MIEN ; sets HLIND1=ien in 773^ien in 772 for message

 N HLMID,X

 I HLIND1 D

 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0

 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0

 ;msg. id is 10th of MSH & 11th for BSH or FSH

 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)

 ;if HLIND1 is set, kill old message, use HLIND1 for new

 ;message, it means we never got end block for 1st msg.

 I HLIND1 D  Q

 . ;get pointer to 772, kill header

 . K ^HLMA(+HLIND1,"MSH")

 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")

 . S X=$$MAID^HLTF(+HLIND1,HLMID)

 . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")

 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""

 D TCP^HLTF(.HLMID,.X,.HLDT)

 I 'X D  Q

 . ;error - record and reset array

 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server

 . D CLEAN K HLLSTN

 . ;error 100=LLP Could not Enqueue the Message, reset array

 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30

 ;HLIND1=ien in 773^ien in 772

 S HLIND1=X_U_+$G(^HLMA(X,0))

 ;save MSH into 773

 D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")

 Q

 ;

PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)

 N FS,I,L,L1,L2,X,Y

 S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""

 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))

 . S:L1=1 L=L+1

 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))

 . S L2=Y,Y=L

 Q X

 ;

PING ;process PING message

 S X=HLMSG(1,0)

 I X[HLDEND U IO W X,! I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage'

 ;

CLEAN ;reset var. for next message

 K HLMSG

 S HLINE=0,HLRDOUT=1

 Q

 ;

ERROR ; Error trap for disconnect error and return back to the read loop.

 S $ETRAP="D UNWIND^%ZTER"

 I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q

 I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q

 S HLCSOUT=1 D ^%ZTER,CC("Error")

 D UNWIND^%ZTER

 Q

 ;

CC(X) ;cleanup and close

 D MON^HLCSTCP(X)

 H 2

 Q

RESET ;reset info as a result of no end block

 N %

 S HLMSG(1,0)=HLMSG(HLINE,0)

 F %=2:1:HLINE K HLMSG(%,0)

 S HLINE=1

 Q

HLCSTCP1  ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006

 +1       ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133**;JUL 17,1995;Build 13

 +2       ;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;Receiver

 +4       ;connection is initiated by sender and listener accepts connection

 +5       ;and calls this routine

 +6       ;

 +7        NEW $ETRAP,$ESTACK

           SET $ETRAP="D ERROR^HLCSTCP1"

 +8        NEW HLMIEN,HLASTMSG

 +9        DO MON^HLCSTCP("Open")

 +10       KILL ^TMP("HLCSTCP",$JOB,0)

 +11       SET HLMIEN=0

           SET HLASTMSG=""

 +12       FOR 

               Begin DoDot:1

 +13               SET HLMIEN=$$READ

 +14               IF 'HLMIEN

                       QUIT 

 +15               DO PROCESS

               End DoDot:1

               IF $$STOP^HLCSTCP

                   QUIT 

               IF 'HLMIEN

                   DO MON^HLCSTCP("Idle")

                   HANG 3

 +16       QUIT 

 +17      ;

PROCESS   ;check message and reply

 +1       ;HLDP=LL in 870, update monitor, received msg.

 +2        NEW HLTCP,HLTCPI,HLTCPO

 +3        SET HLTCP=""

           SET HLTCPO=HLDP

           SET HLTCPI=+HLMIEN

 +4       ;update monitor, msg. received

 +5        DO LLCNT^HLCSTCP(HLDP,1)

 +6        DO NEW^HLTP3(HLMIEN)

 +7       ;update monitor, msg. processed

 +8        DO LLCNT^HLCSTCP(HLDP,2)

 +9        QUIT 

 +10      ;

READ()    ;read 1 message, returns ien in 773^ien in 772 for message

 +1        DO MON^HLCSTCP("Reading")

 +2        NEW HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X

 +3       ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator

 +4        SET HLDSTRT=$CHAR(11)

           SET HLDEND=$CHAR(28)

           SET HLRS=$CHAR(13)

 +5       ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772

 +6       ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack

 +7        SET (HLRDOUT,HLINE,HLIND1,HLHDR)=0

           SET HLX=$GET(^TMP("HLCSTCP",$JOB,0))

           SET HLACKWT=HLDBACK

 +8        KILL ^TMP("HLCSTCP",$JOB,0)

 +9        FOR 

               DO RDBLK

               IF HLRDOUT

                   QUIT 

 +10      ;save any excess for next time

 +11       IF $LENGTH(HLX)

               SET ^TMP("HLCSTCP",$JOB,0)=HLX

 +12       IF +HLIND1

               IF '$PIECE(HLIND1,U,3)

                   DO DELMSG(HLIND1)

                   SET HLIND1=0

 +13       QUIT HLIND1

 +14      ;

RDBLK      SET HLDB=HLDBSIZE-$LENGTH(HLX)

 +1        USE IO

           READ X#HLDB:HLDREAD

 +2       ;switch to null device if opened to prevent 'leakage'

 +3        IF $GET(IO(0))'=""

               IF $GET(IO(0))'=IO

                   USE IO(0)

 +4       ; timedout, check ack timeout, clean up

 +5        IF '$TEST

               IF X=""

                   IF HLX=""

                       SET HLACKWT=HLACKWT-HLDREAD

                       IF HLACKWT<0&'HLHDR

                           DO CLEAN

                       QUIT 

 +6       ;data stream: <sb>dddd<cr><eb><cr>

 +7       ;add incoming line to what wasn't processed in last read

 +8        SET HLX=$GET(HLX)_X

 +9       ; look for segment= <CR>

 +10       FOR 

               IF HLX'[HLRS

                   QUIT 

               Begin DoDot:1

 +11      ; Get the first piece, save the rest of the line

 +12               SET HLINE=HLINE+1

                   SET HLMSG(HLINE,0)=$PIECE(HLX,HLRS)

                   SET HLX=$PIECE(HLX,HLRS,2,999)

 +13      ; check for start block, Quit if no ien

 +14               IF HLMSG(HLINE,0)[HLDSTRT!HLHDR

                       Begin DoDot:2

 +15                       IF HLMSG(HLINE,0)[HLDSTRT

                               Begin DoDot:3

 +16                               SET X=$LENGTH(HLMSG(HLINE,0),HLDSTRT)

 +17                               IF X>2

                                       SET HLMSG(HLINE,0)=HLDSTRT_$PIECE(HLMSG(HLINE,0),HLDSTRT,X)

 +18                               SET HLMSG(HLINE,0)=$PIECE(HLMSG(HLINE,0),HLDSTRT,2)

 +19                               IF (HLINE>1)

                                       DO RESET

                               End DoDot:3

 +20      ;ping message

 +21                       IF $EXTRACT(HLMSG(1,0),1,9)="MSH^PING^"

                               DO PING

                               QUIT 

 +22      ; get next ien to store

 +23                       DO MIEN

 +24                       KILL HLMSG

 +25                       SET (HLINE,HLHDR)=0

                       End DoDot:2

                       QUIT 

 +26      ; check for end block; HLMSG(HLINE) = <eb><cr>

 +27               IF HLMSG(HLINE,0)[HLDEND

                       Begin DoDot:2

 +28      ;no msg. ien

 +29                       IF 'HLIND1

                               QUIT 

 +30      ; Kill just the last line

 +31                       KILL HLMSG(HLINE,0)

                           SET HLINE=HLINE-1

 +32      ; move into 772

 +33                       DO SAVE(.HLMSG,"^HL(772,"_+$PIECE(HLIND1,U,2)_",""IN"")")

 +34      ;mark that end block has been received

 +35      ;HLIND1=ien in 773^ien in 772^1 if end block was received

 +36                       SET $PIECE(HLIND1,U,3)=1

 +37      ;reset variables for next message

 +38                       DO CLEAN

                       End DoDot:2

 +39      ;add blank line for carriage return

 +40               IF HLINE'=0

                       IF HLMSG(HLINE,0)]""

                           SET HLINE=HLINE+1

                           SET HLMSG(HLINE,0)=""

               End DoDot:1

               IF HLRDOUT

                   QUIT 

 +41       IF HLRDOUT

               QUIT 

 +42      ;If the line is long and no <CR> move it into the array. 

 +43       IF ($LENGTH(HLX)=HLDBSIZE)

               IF (HLX'[HLRS)

                   IF (HLX'[HLDEND)

                       IF (HLX'[HLDSTRT)

                           Begin DoDot:1

 +44                           SET HLINE=HLINE+1

                               SET HLMSG(HLINE,0)=HLX

                               SET HLX=""

                           End DoDot:1

                           QUIT 

 +45      ;have start block but no record seperator

 +46       IF HLX[HLDSTRT

               Begin DoDot:1

 +47      ;check for more than 1 start block

 +48               SET X=$LENGTH(HLX,HLDSTRT)

                   IF X>2

                       SET HLX=HLDSTRT_$PIECE(HLX,HLDSTRT,X)

 +49               IF $LENGTH($PIECE(HLX,HLDSTRT,2))>8

                       SET HLINE=HLINE+1

                       SET HLMSG(HLINE,0)=$PIECE(HLX,HLDSTRT,2)

                       SET HLX=""

                       SET HLHDR=1

 +50               IF (HLHDR&(HLINE>1))

                       DO RESET

               End DoDot:1

               QUIT 

 +51      ;if no ien, then we don't have start block, reset

 +52       IF 'HLIND1

               DO CLEAN

               QUIT 

 +53      ; big message-merge from local to global every 100 lines

 +54       IF (HLINE-$ORDER(HLMSG(0)))>100

               Begin DoDot:1

 +55               MERGE ^HL(772,+$PIECE(HLIND1,U,2),"IN")=HLMSG

 +56      ; reset working array

 +57               KILL HLMSG

               End DoDot:1

 +58       QUIT 

 +59      ;

SAVE(SRC,DEST) ;save into global & set top node

 +1       ;SRC=source array (passed by ref.), DEST=destination global

 +2        MERGE @DEST=SRC

 +3        SET @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"

 +4        QUIT 

 +5       ;

DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.

 +1        NEW DIK,DA

 +2        SET DA=+HLMAMT

           SET DIK="^HLMA("

 +3        DO ^DIK

 +4        SET DA=$PIECE(HLMAMT,U,2)

           SET DIK="^HL(772,"

 +5        DO ^DIK

 +6        QUIT 

MIEN      ; sets HLIND1=ien in 773^ien in 772 for message

 +1        NEW HLMID,X

 +2        IF HLIND1

               Begin DoDot:1

 +3                IF '$GET(^HLMA(+HLIND1,0))

                       SET HLIND1=0

 +4                IF '$GET(^HL(772,+$PIECE(HLIND1,U,2),0))

                       SET HLIND1=0

               End DoDot:1

 +5       ;msg. id is 10th of MSH & 11th for BSH or FSH

 +6        SET X=10+($EXTRACT(HLMSG(1,0),1,3)'="MSH")

           SET HLMID=$$PMSH(.HLMSG,X)

 +7       ;if HLIND1 is set, kill old message, use HLIND1 for new

 +8       ;message, it means we never got end block for 1st msg.

 +9        IF HLIND1

               Begin DoDot:1

 +10      ;get pointer to 772, kill header

 +11               KILL ^HLMA(+HLIND1,"MSH")

 +12               IF $DATA(^HL(772,+$PIECE(HLIND1,U,2),"IN"))

                       KILL ^("IN")

 +13               SET X=$$MAID^HLTF(+HLIND1,HLMID)

 +14               DO SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")

 +15               IF $PIECE(HLIND1,U,3)

                       SET $PIECE(HLIND1,U,3)=""

               End DoDot:1

               QUIT 

 +16       DO TCP^HLTF(.HLMID,.X,.HLDT)

 +17       IF 'X

               Begin DoDot:1

 +18      ;error - record and reset array

 +19      ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server

 +20               DO CLEAN

                   KILL HLLSTN

 +21      ;error 100=LLP Could not Enqueue the Message, reset array

 +22               DO MONITOR^HLCSDR2(100,19,HLDP)

                   DO MON^HLCSTCP("ERROR")

                   HANG 30

               End DoDot:1

               QUIT 

 +23      ;HLIND1=ien in 773^ien in 772

 +24       SET HLIND1=X_U_+$GET(^HLMA(X,0))

 +25      ;save MSH into 773

 +26       DO SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")

 +27       QUIT 

 +28      ;

PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)

 +1        NEW FS,I,L,L1,L2,X,Y

 +2        SET FS=$EXTRACT(MSH(1,0),4)

           SET (L2,Y)=0

           SET X=""

 +3        FOR I=1:1

               SET L1=$LENGTH($GET(MSH(I,0)),FS)

               SET L=L1+Y-1

               Begin DoDot:1

 +4                IF L1=1

                       SET L=L+1

 +5                IF P'>L

                       SET X=$PIECE($GET(MSH(I-1,0)),FS,P-L2)_$PIECE($GET(MSH(I,0)),FS,(P-Y))

 +6                SET L2=Y

                   SET Y=L

               End DoDot:1

               IF $LENGTH(X)!'$DATA(MSH(I,0))

                   QUIT 

 +7        QUIT X

 +8       ;

PING      ;process PING message

 +1        SET X=HLMSG(1,0)

 +2       ;switch to null device if opened to prevent 'leakage'

           IF X[HLDEND

               USE IO

               WRITE X,!

               IF $GET(IO(0))'=""

                   IF $GET(IO(0))'=IO

                       USE IO(0)

 +3       ;

CLEAN     ;reset var. for next message

 +1        KILL HLMSG

 +2        SET HLINE=0

           SET HLRDOUT=1

 +3        QUIT 

 +4       ;

ERROR     ; Error trap for disconnect error and return back to the read loop.

 +1        SET $ETRAP="D UNWIND^%ZTER"

 +2        IF $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")

               DO UNWIND^%ZTER

               QUIT 

 +3        IF $$EC^%ZOSV["WRITE"

               DO CC("Wr-err")

               DO UNWIND^%ZTER

               QUIT 

 +4        SET HLCSOUT=1

           DO ^%ZTER

           DO CC("Error")

 +5        DO UNWIND^%ZTER

 +6        QUIT 

 +7       ;

CC(X)     ;cleanup and close

 +1        DO MON^HLCSTCP(X)

 +2        HANG 2

 +3        QUIT 

RESET     ;reset info as a result of no end block

 +1        NEW %

 +2        SET HLMSG(1,0)=HLMSG(HLINE,0)

 +3        FOR %=2:1:HLINE

               KILL HLMSG(%,0)

 +4        SET HLINE=1

 +5        QUIT