BOPTCP.m

BOPTCP ;IHS/ILC/ALG/CIA/PLS - TCP/IP Send/Receive Utility;03-Feb-2006 10:58;SM

 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005

 ;;

 ;

 ; NOTE!  This routine may be saved under a different name.  If this is

 ;        done, be sure to edit the first line of the routine and the

 ;        name of the routine in the EOR line

 ;

 ; NOTE!  Normally, transmissions are ended with a sequence of control

 ;        characters such as ASCII 13,11,13 or 27,27,27.  No such

 ;        end-of-transmit characters are used during the sending of

 ;        data.  If any such characters are

 ;        returned, they are not checked for.  PLEASE be sure

 ;        to add them.  (Data sent to in SDATA and data

 ;        received in DATA subroutines.)

 ;

 ; Replaceable parameters that will need to be replaced are

 ; the following:

 ;

 ; Subroutine:  IP (To IP address

 ; Subroutine:  SOCKET (To Socket#)

 ;

 ; Or

 ;

 ; Change these subroutines to call a file or table (which is probably

 ; better than hardsetting the values.)

 ;

 ;

 ; EXPLANATION:

 ;

 ; Then EN call point will transmit to IP/Socket the data contained in

 ; the INPUT array.  Data returned will be returned

 ; in the OUTPUT array.

 ;

 ;

 ; EXAMPLE:

 ;

 ; TRANS(1)="MSH|^~\&|..."       <- message carries over into TRANS(2)

 ; TRANS(2)="...MSA|... etc, etc"

 ;

 ; S A7RERR=$$EN^BOPTCP("TRANS","RESULTS")

 ;

 ; W A7RERR   -> will be = zero if ALL goes well, or -1^... if not

 ;

 ; If the above call works, the response will be in

 ; the RESULTS array.  Something line this...

 ;

 ; RESULTS(1)="MSH|^~\&|..."   <- the response message

 ; RESULTS(2)="... etc, etc"

 ;

EN(INPUT,OUTPUT) ;Call to do direct connect to MPI

 N I,LOOP,LP,POP,X,XCS,XCSDAT,XCSER,XCSEXIT,XCSMD,XCSNT,XCSTIME

 N XCSTRACE,Y

 ;

 D SETUP

 ;

 ;IHS exemption approved on March 16, 2005

 I XCSNT N $ESTACK,$ETRAP S $ETRAP="D ERROR^BOPTCP"

 E  S X="ERROR^BOPTCP",@^%ZOSF("TRAP")

 ;

 D OPEN I POP QUIT $$ERR("POP=1 ON OPEN") ;->

 D DATA

 D GET

 D QUIT

 ;

 Q 0 ;#errors = 0

 ;

ERR(REA) ;Report back an error

 D TRACE("ERROR "_XCS("STAT"))

 D:'POP QUIT

 Q "-1^"_REA

 ;

ERROR ;Trap an error

 D ^%ZTER G UNWIND^%ZTER

 ;

OPEN ;Open connection

 D TRACE("Make Connection")

 D CALL^%ZISTCP(BOPIP,BOPOCK) Q:POP

 D TRACE("Got Connection")

 U IO

 Q

DATA ;Send data

 D TRACE("Send Data")

 D SDATA(INPUT,$G(TYPE,"MPI")) ;LJA

 Q

 ;

GET ;Get responce

 D GDATA(OUTPUT)

 Q

QUIT ;Shut down

 D CLOSE^%ZISTCP

 Q

TRACE(S1) ;

 Q:0  N %,H

 I S1=-1 K ^TMP($J,"ZZXCSA") Q

 S H=$P($H,",",2),H=(H\3600)_":"_(H#3600\60)_":"_(H#60)_" "

 L +^TMP($J,"ZZXCSA"):1

 S %=$G(^TMP($J,"ZZXCSA",0))+1,^(0)=%,^(%)=H_XCSTRACE_S1

 L -^TMP($J,"ZZXCSA")

 Q

SETUP ;EP - SET UP INFO

 S XCS("IP")=BOPIP,XCS("SOCK")=BOPOCK

 S (XCS("STAT"),XCSEXIT)=0,XCSTIME=30,XCSTRACE="C: "

 S XCSNT=$$NEWERR^%ZTER()

 D TRACE(-1),TRACE("Client Setup")

 Q

GDATA(ROOT,STAT) ;EP - get Data

 N E,I,M

 ;

 ;  changed read timeout to 2 from 5 dtg

 S BOPCHKA="" F  U IO R RESTRNG#200:3 Q:RESTRNG=""&'$T  D  Q:BOPCHKA  ;

 .; set quit flag if ascii 28 contained

 .I RESTRNG[$C(28) S BOPCHKA=1

 .;

 .;Strip Control Characters from END of received string

 .F  Q:RESTRNG'?.E1C  S RESTRNG=$E(RESTRNG,1,$L(RESTRNG)-1)

 .;

 .S BOPK=2

MORE .S BOPTRNG=$P(RESTRNG,$C(11),BOPK)

 .Q:BOPTRNG']""

 .F BOPI=1:1 S BOPLINE=$P(BOPTRNG,$C(13),BOPI) Q:BOPLINE']""!(BOPLINE=$C(28))  D

 ..S I=$O(@ROOT@(":"),-1)+1,@ROOT@(I)=BOPLINE

 .S BOPK=BOPK+1

 .G MORE

 ;

 Q

 ;

SDATA(ROOT,TYPE) ;EP - Send data from a source

 N X,Y,L,D

 S X=ROOT

 F  S X=$Q(@X) Q:X']""!(X'[ROOT)  D

 .U IO W @X,!

 ;

 D ENDCHARS

 Q

 ;

ENDCHARS ; Add EOT ctrl characters, etc, below... LJA

 Q

 ;

 ; If end of transmission characters needed, add here...

 ;

IP() ; Substitute IP ADDRESS...

 Q $P(^BOP(90355,1,0),U,17)

 ;

SOCKET() ; Substitute SOCKET...

 Q $P(^BOP(90355,1,0),U,18)

BOPTCP    ;IHS/ILC/ALG/CIA/PLS - TCP/IP Send/Receive Utility;03-Feb-2006 10:58;SM

 +1       ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005

 +2       ;;

 +3       ;

 +4       ; NOTE!  This routine may be saved under a different name.  If this is

 +5       ;        done, be sure to edit the first line of the routine and the

 +6       ;        name of the routine in the EOR line

 +7       ;

 +8       ; NOTE!  Normally, transmissions are ended with a sequence of control

 +9       ;        characters such as ASCII 13,11,13 or 27,27,27.  No such

 +10      ;        end-of-transmit characters are used during the sending of

 +11      ;        data.  If any such characters are

 +12      ;        returned, they are not checked for.  PLEASE be sure

 +13      ;        to add them.  (Data sent to in SDATA and data

 +14      ;        received in DATA subroutines.)

 +15      ;

 +16      ; Replaceable parameters that will need to be replaced are

 +17      ; the following:

 +18      ;

 +19      ; Subroutine:  IP (To IP address

 +20      ; Subroutine:  SOCKET (To Socket#)

 +21      ;

 +22      ; Or

 +23      ;

 +24      ; Change these subroutines to call a file or table (which is probably

 +25      ; better than hardsetting the values.)

 +26      ;

 +27      ;

 +28      ; EXPLANATION:

 +29      ;

 +30      ; Then EN call point will transmit to IP/Socket the data contained in

 +31      ; the INPUT array.  Data returned will be returned

 +32      ; in the OUTPUT array.

 +33      ;

 +34      ;

 +35      ; EXAMPLE:

 +36      ;

 +37      ; TRANS(1)="MSH|^~\&|..."       <- message carries over into TRANS(2)

 +38      ; TRANS(2)="...MSA|... etc, etc"

 +39      ;

 +40      ; S A7RERR=$$EN^BOPTCP("TRANS","RESULTS")

 +41      ;

 +42      ; W A7RERR   -> will be = zero if ALL goes well, or -1^... if not

 +43      ;

 +44      ; If the above call works, the response will be in

 +45      ; the RESULTS array.  Something line this...

 +46      ;

 +47      ; RESULTS(1)="MSH|^~\&|..."   <- the response message

 +48      ; RESULTS(2)="... etc, etc"

 +49      ;

EN(INPUT,OUTPUT) ;Call to do direct connect to MPI

 +1        NEW I,LOOP,LP,POP,X,XCS,XCSDAT,XCSER,XCSEXIT,XCSMD,XCSNT,XCSTIME

 +2        NEW XCSTRACE,Y

 +3       ;

 +4        DO SETUP

 +5       ;

 +6       ;IHS exemption approved on March 16, 2005

 +7        IF XCSNT

               NEW $ESTACK,$ETRAP

               SET $ETRAP="D ERROR^BOPTCP"

 +8       IF '$TEST

               SET X="ERROR^BOPTCP"

               SET @^%ZOSF("TRAP")

 +9       ;

 +10      ;->

           DO OPEN

           IF POP

               QUIT $$ERR("POP=1 ON OPEN")

 +11       DO DATA

 +12       DO GET

 +13       DO QUIT

 +14      ;

 +15      ;#errors = 0

           QUIT 0

 +16      ;

ERR(REA)  ;Report back an error

 +1        DO TRACE("ERROR "_XCS("STAT"))

 +2        IF 'POP

               DO QUIT

 +3        QUIT "-1^"_REA

 +4       ;

ERROR     ;Trap an error

 +1        DO ^%ZTER

           GOTO UNWIND^%ZTER

 +2       ;

OPEN      ;Open connection

 +1        DO TRACE("Make Connection")

 +2        DO CALL^%ZISTCP(BOPIP,BOPOCK)

           IF POP

               QUIT 

 +3        DO TRACE("Got Connection")

 +4        USE IO

 +5        QUIT 

DATA      ;Send data

 +1        DO TRACE("Send Data")

 +2       ;LJA

           DO SDATA(INPUT,$GET(TYPE,"MPI"))

 +3        QUIT 

 +4       ;

GET       ;Get responce

 +1        DO GDATA(OUTPUT)

 +2        QUIT 

QUIT      ;Shut down

 +1        DO CLOSE^%ZISTCP

 +2        QUIT 

TRACE(S1) ;

 +1        IF 0

               QUIT 

           NEW %,H

 +2        IF S1=-1

               KILL ^TMP($JOB,"ZZXCSA")

               QUIT 

 +3        SET H=$PIECE($HOROLOG,",",2)

           SET H=(H\3600)_":"_(H#3600\60)_":"_(H#60)_" "

 +4        LOCK +^TMP($JOB,"ZZXCSA"):1

 +5        SET %=$GET(^TMP($JOB,"ZZXCSA",0))+1

           SET ^(0)=%

           SET ^(%)=H_XCSTRACE_S1

 +6        LOCK -^TMP($JOB,"ZZXCSA")

 +7        QUIT 

SETUP     ;EP - SET UP INFO

 +1        SET XCS("IP")=BOPIP

           SET XCS("SOCK")=BOPOCK

 +2        SET (XCS("STAT"),XCSEXIT)=0

           SET XCSTIME=30

           SET XCSTRACE="C: "

 +3        SET XCSNT=$$NEWERR^%ZTER()

 +4        DO TRACE(-1)

           DO TRACE("Client Setup")

 +5        QUIT 

GDATA(ROOT,STAT) ;EP - get Data

 +1        NEW E,I,M

 +2       ;

 +3       ;  changed read timeout to 2 from 5 dtg

 +4       ;

           SET BOPCHKA=""

           FOR 

               USE IO

               READ RESTRNG#200:3

               IF RESTRNG=""&'$TEST

                   QUIT 

               Begin DoDot:1

 +5       ; set quit flag if ascii 28 contained

 +6                IF RESTRNG[$CHAR(28)

                       SET BOPCHKA=1

 +7       ;

 +8       ;Strip Control Characters from END of received string

 +9                FOR 

                       IF RESTRNG'?.E1C

                           QUIT 

                       SET RESTRNG=$EXTRACT(RESTRNG,1,$LENGTH(RESTRNG)-1)

 +10      ;

 +11               SET BOPK=2

MORE               SET BOPTRNG=$PIECE(RESTRNG,$CHAR(11),BOPK)

 +1                IF BOPTRNG']""

                       QUIT 

 +2                FOR BOPI=1:1

                       SET BOPLINE=$PIECE(BOPTRNG,$CHAR(13),BOPI)

                       IF BOPLINE']""!(BOPLINE=$CHAR(28))

                           QUIT 

                       Begin DoDot:2

 +3                        SET I=$ORDER(@ROOT@(":"),-1)+1

                           SET @ROOT@(I)=BOPLINE

                       End DoDot:2

 +4                SET BOPK=BOPK+1

 +5                GOTO MORE

               End DoDot:1

               IF BOPCHKA

                   QUIT 

 +6       ;

 +7        QUIT 

 +8       ;

SDATA(ROOT,TYPE) ;EP - Send data from a source

 +1        NEW X,Y,L,D

 +2        SET X=ROOT

 +3        FOR 

               SET X=$QUERY(@X)

               IF X']""!(X'[ROOT)

                   QUIT 

               Begin DoDot:1

 +4                USE IO

                   WRITE @X,!

               End DoDot:1

 +5       ;

 +6        DO ENDCHARS

 +7        QUIT 

 +8       ;

ENDCHARS  ; Add EOT ctrl characters, etc, below... LJA

 +1        QUIT 

 +2       ;

 +3       ; If end of transmission characters needed, add here...

 +4       ;

IP()      ; Substitute IP ADDRESS...

 +1        QUIT $PIECE(^BOP(90355,1,0),U,17)

 +2       ;

SOCKET()  ; Substitute SOCKET...

 +1        QUIT $PIECE(^BOP(90355,1,0),U,18)