BOPRNEW ;IHS/ILC/ALG/CIA/PLS - ILC Listener;06-Feb-2007 21:19;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1,3**;Jul 26, 2005
Q
DEBUG ;Call here for testing
D DT^DICRW
S BOPLSOC=9002,BOPDIV=1
;
;Entry used as "ZTRTN" in BOPOMTR
GO ; EP
I $G(BOPDIV)="" S BOPDIV=1
;
;Quit if Channel Active field set to NO for Receiving Facility
I '$P($G(^BOP(90355,1,3,BOPDIV,0)),U,2) G QUIT
;Quit if STOP field set to INTERFACE STOPPED
I $P($G(^BOP(90355,1,12)),U,1)+0>0 G QUIT
;
;Lock / Test / Quit if a job is already running
L +^BOP(90355,"L",BOPDIV):99 E Q
;
;Listen on socket, start routine
N %A,ZISOS,X,NIO S ZISOS=^%ZOSF("OS")
;IHS exemption approved on March 16, 2005
I $$NEWERR^%ZTER() N $ETRAP S $ETRAP="D ERR^BOPRNEW"
E S X="ERR^BOPRNEW",@^%ZOSF("TRAP")
;
;Open a channel. Parameter 1 is Socket, parameter 2 is the routine.
;S IO("C")=1 ; If not commented out, the channel stops after 1 message
;
;If this side is supposed to be the client, make the connection
I $P(^BOP(90355,1,3,BOPDIV,0),U,8)="C" S X=^(0) D
.S BOPLSOC=$P(X,U,5),X=$P(X,U,3)
.D CALL^%ZISTCP(X,BOPLSOC) Q:POP
.D READ
.K BOPLSOC
;
QUIT Q
;
READ ;LISTEN^%ZISTCP will call here to read the message.
S DIQUIET=1,BOPBUF="" D DT^DICRW
;
LOOP U IO R X:1 H 1
I $P($G(^BOP(90355,1,12)),U,1)+0>0 G QUIT ; all interfaces stopped
I '$L(X) H 5 G LOOP:+$G(^BOP(90355,1,4)),QUIT
S BOPBUF=X
LOOP1 D RECEIVE(2)
I $P($G(^BOP(90355,1,12)),U,1)+0>0 G QUIT ; all interfaces stopped
I +$G(^BOP(90355,1,4)) G LOOP1:$L(BOPBUF),LOOP
G QUIT
;
RECEIVE(BOPWAIT) ;
N I,J
;
K BOPIN S BOPI=0,U="^" U IO
;Calculate Operating System to be able to read properly
I '$D(BOPOS) S BOPOS=^%ZOSF("OS")
I BOPOS["MSM" G RMSM
G RR
;
K BOPIN S BOPI=0,U="^" U IO
;
RMSM ; go here if MSM
S BOPOS("MSMVER")=$$VERSION^%ZOSV()
S:+BOPOS("MSMVER")=0 BOPOS("MSMVER")=8
;
;Read
;If there are multiple records, BOPIN needs to be
;changed to a global array.
;
RR ;
F D R(BOPWAIT,BOPOS) Q:$S(X="":1,X=$C(28):1,1:"") D
.I $E(X)=$C(11) S X=$E(X,2,$L(X)) Q:X=""
.S BOPI=BOPI+1,BOPIN(BOPI)=X
;
;Quit if no data received
Q:'$D(BOPIN)
;
;Quit if the wrong type of record
S I=":"_$P($P(BOPIN(1),"|",9),U)_":"
Q:":DFT:EPQ:EOQ:ETO:"'[I
;
D RSET
I BOPBUF'="" K BOPIN S BOPI=0 G RR
Q
;
RSET ; file new transaction
;Create NEW Record
;
;First calculate now
S DIC="^BOP(90355.1,"
S X=$$NOW^XLFDT()
;
;Then make sure NOW is unique in the file
L +^BOP(90355.1,0):1
F I=X:.000001 Q:'$D(^BOP(90355.1,"B",I))
K DD,DO S X=I,DIC="^BOP(90355.1,",DIC(0)="F" D FILE^DICN
L -^BOP(90355.1,0)
;
;Put data into file -- first mark it "NOT COMPLETE"
S DIE=90355.1,DR=".1///99;.12///"_BOPDIV_";99///1;99.1///1",DA=+Y
D ^DIE
;
;Put data into file
S J=0 F I=0:0 S I=$O(BOPIN(I)) Q:I<1 S J=J+1,^BOP(90355.1,DA,"DATA",J,0)=BOPIN(I)
S ^BOP(90355.1,DA,"DATA",0)=U_U_J_U_J_U_$P(^BOP(90355.1,DA,0),".")
;
;Mark transaction received and Acknowledge
S DIE=90355.1,DR="99.1///0" D ^DIE S BOPSTOP=1
S ^BOP(90355.1,"AC",0,DA)=""
; send ack back
K OUT N A,B S A=BOPIN(1),$P(A,"|",9)="ACK"
S B=$P(A,"|",2) S:B'["&" B=B_"&",$P(A,"|",2)=B
S B="MSA|AA|"_DA_"|"
S OUT(1)=$C(11)_A_$C(13),OUT(2)=B_$C(13)_$C(28)_$C(13)
S A=0 F S A=$O(OUT(A)) Q:'A U IO W OUT(A),!
; keep copy in file
S OUT(0)=$H M ^BOP(90355.1,DA,"OUT")=OUT
K OUT,A,B
Q
;
RACK ; send ack back
ERR ;
G QUIT
;
;Job out at this line to start a new receiver at single division site.
JOB N ZTIO,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
S ZTIO="",ZTDTH=$H,ZTRTN="JOBGO^BOPRNEW",ZTDESC="BOP LISTENER"
D ^%ZTLOAD
I '$G(ZTSK) D
.W !,"BOPRNEW job startup Failed"
Q
JOBGO ;Start a new listener
S X="Automated Dispense "_$J D SETENV^%ZOSV,DT^DICRW
S I=$O(^BOP(90355,1,3,1,0)) Q:I<1 S X=^(I,0)
S BOPLSOC=$P(X,U,5),BOPDIV=$P(X,U)
S X="ERR^ZU",@^%ZOSF("TRAP"),ER=0
G GO^BOPRNEW
;
R(A,Z) ;Read the TCP/IP channel
;This module returns X each time it is called
;as a "line" of data (the text terminated by a $C(13)
;
N BOPQ,Y
RGO ;
;First look in "buffer" for a segment
S Y=$F(BOPBUF,$C(13)),BOPQ=0
I 'Y S BOPQ=1
I Y S X=$E(BOPBUF,1,Y-2),BOPBUF=$E(BOPBUF,Y,9999) Q
;
;Since there was no discernable line in the buffer, read the channel
S X="ERR^BOPRNEW",@^%ZOSF("TRAP")
I $G(Z)["VAX" R X#200:$S($G(A):A,1:160)
;Compliant with M standard
E R X:$S(A:A,1:60)
;
;Add what was read to the buffer
I $L(X) S BOPBUF=BOPBUF_X
;
;If there was nothing in the buffer and nothing read then quit
I BOPQ,'$L(X),$L(BOPBUF) S X=BOPBUF,BOPBUF=""
I BOPBUF="",BOPQ Q
S BOPQ=0 G RGO:$L(BOPBUF)
Q
TEST ;This is used for testing
TSTGO ;
W $C(11)
W "MSH|^~\&|OMNICELLRX||PHARM||19940|260855||DFT^P03||P|2.2|",$C(13)
W "PID|||6|6|MAQQIA^ALAN|",$C(13)
W "PV1||NU4E^A22^Main2|",$C(13)
W "FT1||||199401260855||V|1217712^ASPIRIN^03||OR123|1||||||||||NID^NNAME|DR123",$C(13)
W "ZPM|V|OMNICELLRX|NUE100|3|A|12177121|ASPIRIN|U|112|112|1|NID|NNAME|WID|WNAME|222||Main2||NU4E||125|25|19940126085533||",$C(13)
W $C(28,13),!
H 9 R X:9
U 0
W !!,"Read from Channel (ACK?): "_X
W !!,"Don't forget to close the channel."
Q
BOPRNEW ;IHS/ILC/ALG/CIA/PLS - ILC Listener;06-Feb-2007 21:19;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,3**;Jul 26, 2005
+2 QUIT
DEBUG ;Call here for testing
+1 DO DT^DICRW
+2 SET BOPLSOC=9002
SET BOPDIV=1
+3 ;
+4 ;Entry used as "ZTRTN" in BOPOMTR
GO ; EP
+1 IF $GET(BOPDIV)=""
SET BOPDIV=1
+2 ;
+3 ;Quit if Channel Active field set to NO for Receiving Facility
+4 IF '$PIECE($GET(^BOP(90355,1,3,BOPDIV,0)),U,2)
GOTO QUIT
+5 ;Quit if STOP field set to INTERFACE STOPPED
+6 IF $PIECE($GET(^BOP(90355,1,12)),U,1)+0>0
GOTO QUIT
+7 ;
+8 ;Lock / Test / Quit if a job is already running
+9 LOCK +^BOP(90355,"L",BOPDIV):99
IF '$TEST
QUIT
+10 ;
+11 ;Listen on socket, start routine
+12 NEW %A,ZISOS,X,NIO
SET ZISOS=^%ZOSF("OS")
+13 ;IHS exemption approved on March 16, 2005
+14 IF $$NEWERR^%ZTER()
NEW $ETRAP
SET $ETRAP="D ERR^BOPRNEW"
+15 IF '$TEST
SET X="ERR^BOPRNEW"
SET @^%ZOSF("TRAP")
+16 ;
+17 ;Open a channel. Parameter 1 is Socket, parameter 2 is the routine.
+18 ;S IO("C")=1 ; If not commented out, the channel stops after 1 message
+19 ;
+20 ;If this side is supposed to be the client, make the connection
+21 IF $PIECE(^BOP(90355,1,3,BOPDIV,0),U,8)="C"
SET X=^(0)
Begin DoDot:1
+22 SET BOPLSOC=$PIECE(X,U,5)
SET X=$PIECE(X,U,3)
+23 DO CALL^%ZISTCP(X,BOPLSOC)
IF POP
QUIT
+24 DO READ
+25 KILL BOPLSOC
End DoDot:1
+26 ;
QUIT QUIT
+1 ;
READ ;LISTEN^%ZISTCP will call here to read the message.
+1 SET DIQUIET=1
SET BOPBUF=""
DO DT^DICRW
+2 ;
LOOP USE IO
READ X:1
HANG 1
+1 ; all interfaces stopped
IF $PIECE($GET(^BOP(90355,1,12)),U,1)+0>0
GOTO QUIT
+2 IF '$LENGTH(X)
HANG 5
IF +$GET(^BOP(90355,1,4))
GOTO LOOP
GOTO QUIT
+3 SET BOPBUF=X
LOOP1 DO RECEIVE(2)
+1 ; all interfaces stopped
IF $PIECE($GET(^BOP(90355,1,12)),U,1)+0>0
GOTO QUIT
+2 IF +$GET(^BOP(90355,1,4))
IF $LENGTH(BOPBUF)
GOTO LOOP1
GOTO LOOP
+3 GOTO QUIT
+4 ;
RECEIVE(BOPWAIT) ;
+1 NEW I,J
+2 ;
+3 KILL BOPIN
SET BOPI=0
SET U="^"
USE IO
+4 ;Calculate Operating System to be able to read properly
+5 IF '$DATA(BOPOS)
SET BOPOS=^%ZOSF("OS")
+6 IF BOPOS["MSM"
GOTO RMSM
+7 GOTO RR
+8 ;
+9 KILL BOPIN
SET BOPI=0
SET U="^"
USE IO
+10 ;
RMSM ; go here if MSM
+1 SET BOPOS("MSMVER")=$$VERSION^%ZOSV()
+2 IF +BOPOS("MSMVER")=0
SET BOPOS("MSMVER")=8
+3 ;
+4 ;Read
+5 ;If there are multiple records, BOPIN needs to be
+6 ;changed to a global array.
+7 ;
RR ;
+1 FOR
DO R(BOPWAIT,BOPOS)
IF $SELECT(X=""
QUIT
Begin DoDot:1
+2 IF $EXTRACT(X)=$CHAR(11)
SET X=$EXTRACT(X,2,$LENGTH(X))
IF X=""
QUIT
+3 SET BOPI=BOPI+1
SET BOPIN(BOPI)=X
End DoDot:1
+4 ;
+5 ;Quit if no data received
+6 IF '$DATA(BOPIN)
QUIT
+7 ;
+8 ;Quit if the wrong type of record
+9 SET I=":"_$PIECE($PIECE(BOPIN(1),"|",9),U)_":"
+10 IF "
QUIT
+11 ;
+12 DO RSET
+13 IF BOPBUF'=""
KILL BOPIN
SET BOPI=0
GOTO RR
+14 QUIT
+15 ;
RSET ; file new transaction
+1 ;Create NEW Record
+2 ;
+3 ;First calculate now
+4 SET DIC="^BOP(90355.1,"
+5 SET X=$$NOW^XLFDT()
+6 ;
+7 ;Then make sure NOW is unique in the file
+8 LOCK +^BOP(90355.1,0):1
+9 FOR I=X:.000001
IF '$DATA(^BOP(90355.1,"B",I))
QUIT
+10 KILL DD,DO
SET X=I
SET DIC="^BOP(90355.1,"
SET DIC(0)="F"
DO FILE^DICN
+11 LOCK -^BOP(90355.1,0)
+12 ;
+13 ;Put data into file -- first mark it "NOT COMPLETE"
+14 SET DIE=90355.1
SET DR=".1///99;.12///"_BOPDIV_";99///1;99.1///1"
SET DA=+Y
+15 DO ^DIE
+16 ;
+17 ;Put data into file
+18 SET J=0
FOR I=0:0
SET I=$ORDER(BOPIN(I))
IF I<1
QUIT
SET J=J+1
SET ^BOP(90355.1,DA,"DATA",J,0)=BOPIN(I)
+19 SET ^BOP(90355.1,DA,"DATA",0)=U_U_J_U_J_U_$PIECE(^BOP(90355.1,DA,0),".")
+20 ;
+21 ;Mark transaction received and Acknowledge
+22 SET DIE=90355.1
SET DR="99.1///0"
DO ^DIE
SET BOPSTOP=1
+23 SET ^BOP(90355.1,"AC",0,DA)=""
+24 ; send ack back
+25 KILL OUT
NEW A,B
SET A=BOPIN(1)
SET $PIECE(A,"|",9)="ACK"
+26 SET B=$PIECE(A,"|",2)
IF B'["&"
SET B=B_"&"
SET $PIECE(A,"|",2)=B
+27 SET B="MSA|AA|"_DA_"|"
+28 SET OUT(1)=$CHAR(11)_A_$CHAR(13)
SET OUT(2)=B_$CHAR(13)_$CHAR(28)_$CHAR(13)
+29 SET A=0
FOR
SET A=$ORDER(OUT(A))
IF 'A
QUIT
USE IO
WRITE OUT(A),!
+30 ; keep copy in file
+31 SET OUT(0)=$HOROLOG
MERGE ^BOP(90355.1,DA,"OUT")=OUT
+32 KILL OUT,A,B
+33 QUIT
+34 ;
RACK ; send ack back
ERR ;
+1 GOTO QUIT
+2 ;
+3 ;Job out at this line to start a new receiver at single division site.
JOB NEW ZTIO,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
+1 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="JOBGO^BOPRNEW"
SET ZTDESC="BOP LISTENER"
+2 DO ^%ZTLOAD
+3 IF '$GET(ZTSK)
Begin DoDot:1
+4 WRITE !,"BOPRNEW job startup Failed"
End DoDot:1
+5 QUIT
JOBGO ;Start a new listener
+1 SET X="Automated Dispense "_$JOB
DO SETENV^%ZOSV
DO DT^DICRW
+2 SET I=$ORDER(^BOP(90355,1,3,1,0))
IF I<1
QUIT
SET X=^(I,0)
+3 SET BOPLSOC=$PIECE(X,U,5)
SET BOPDIV=$PIECE(X,U)
+4 SET X="ERR^ZU"
SET @^%ZOSF("TRAP")
SET ER=0
+5 GOTO GO^BOPRNEW
+6 ;
R(A,Z) ;Read the TCP/IP channel
+1 ;This module returns X each time it is called
+2 ;as a "line" of data (the text terminated by a $C(13)
+3 ;
+4 NEW BOPQ,Y
RGO ;
+1 ;First look in "buffer" for a segment
+2 SET Y=$FIND(BOPBUF,$CHAR(13))
SET BOPQ=0
+3 IF 'Y
SET BOPQ=1
+4 IF Y
SET X=$EXTRACT(BOPBUF,1,Y-2)
SET BOPBUF=$EXTRACT(BOPBUF,Y,9999)
QUIT
+5 ;
+6 ;Since there was no discernable line in the buffer, read the channel
+7 SET X="ERR^BOPRNEW"
SET @^%ZOSF("TRAP")
+8 IF $GET(Z)["VAX"
READ X#200:$SELECT($GET(A):A,1:160)
+9 ;Compliant with M standard
+10 IF '$TEST
READ X:$SELECT(A:A,1:60)
+11 ;
+12 ;Add what was read to the buffer
+13 IF $LENGTH(X)
SET BOPBUF=BOPBUF_X
+14 ;
+15 ;If there was nothing in the buffer and nothing read then quit
+16 IF BOPQ
IF '$LENGTH(X)
IF $LENGTH(BOPBUF)
SET X=BOPBUF
SET BOPBUF=""
+17 IF BOPBUF=""
IF BOPQ
QUIT
+18 SET BOPQ=0
IF $LENGTH(BOPBUF)
GOTO RGO
+19 QUIT
TEST ;This is used for testing
TSTGO ;
+1 WRITE $CHAR(11)
+2 WRITE "MSH|^~\&|OMNICELLRX||PHARM||19940|260855||DFT^P03||P|2.2|",$CHAR(13)
+3 WRITE "PID|||6|6|MAQQIA^ALAN|",$CHAR(13)
+4 WRITE "PV1||NU4E^A22^Main2|",$CHAR(13)
+5 WRITE "FT1||||199401260855||V|1217712^ASPIRIN^03||OR123|1||||||||||NID^NNAME|DR123",$CHAR(13)
+6 WRITE "ZPM|V|OMNICELLRX|NUE100|3|A|12177121|ASPIRIN|U|112|112|1|NID|NNAME|WID|WNAME|222||Main2||NU4E||125|25|19940126085533||",$CHAR(13)
+7 WRITE $CHAR(28,13),!
+8 HANG 9
READ X:9
+9 USE 0
+10 WRITE !!,"Read from Channel (ACK?): "_X
+11 WRITE !!,"Don't forget to close the channel."
+12 QUIT
