LADIMPXX ;SLC/DLG - DIMENSION DIRECT CONNECT INTERFACE ;8/16/90 14:15 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
S:$D(ZTQUEUED) ZTREQ="@" S LANM=$T(+0),(HOME,T,TSK)=$E(LANM,7,8) Q:+T<1 Q:$D(^LA("LOCK",T)) G ^LADIMPI
LA ;Entry point from LADIMPI
LA2 K RS,TV,Y S RN=1 G RD:OUT="" D:$D(^LA(DEB,0)) DBO W OUT G W:OUT[$C(6),NAK:OUT[$C(21),RD:OUT[$C(3),LA2
RD S ^LA(T,"R")=$H R *X:TOUT G RD:'$T D:($T&($D(^LA(DEB,0)))) DBX G RD1:X=2
I X=6 S IN=X D IN S ^LA(T,"P3")=^LA(T,"O",0),OUT="" G RD
I X=21 S IN=X D IN S ^LA(T,"O",0)=^LA(T,"P3") G W
I X=5 S IN=X D IN G LA2
S IN=X D IN G RD
RD1 S TOUT=5,IN="[",CS=0,^LA(T,"P")="IN"
RD2 F I=0:0 R *X:TOUT S:($T&($L(IN)<255)) IN=IN_$S(X=3:"]",X=28:FS,1:$C(X)),CS=CS+X Q:(X<0!(X=3)!($L(IN)=255)) I $L(IN)=2,$E(IN)="[" S RT=$E(IN,2)
D:$D(^LA(DEB,0)) DBI S:RT="R" Y(RN)=IN,RN=RN+1
D:'$D(^LA(T,"I")) SET D IN S LN=$L(IN)
I LN=255,(X'=3) S IN="" G RD2
I LN<255,(X'=3) S OUT=$C(21) D OUT G W
S:LN=1 CNT=^LA(T,"I")-1,LRCC=$E(^LA(T,"I",CNT),($L(^(CNT))-1),$L(^(CNT)))
S:LN=2 CNT=^LA(T,"I")-1,LRCC=$E(^LA(T,"I",CNT),$L(^(CNT)))_$E(IN,1)
S:LN>2 LRCC=$E(IN,LN-2,LN-1)
S CS=CS-3-$A(LRCC)-$A(LRCC,2)#256,LRCC=$F("0123456789ABCDEF",$E(LRCC,1))-2*16+$F("0123456789ABCDEF",$E(LRCC,2))-2,OUT=$C($S(CS=LRCC:6,1:21))
D OUT G P:RT="P",R:RT="R",R:RT="C",M:RT="M"
W IF $D(^LA("STOP",HOME)) K ^LA("LOCK",HOME),^LA("STOP",HOME) G H^XUS
S OUT="",CNT=^LA(T,"O",0)+1 I $D(^(CNT)) S OUT=^(CNT),^(0)=CNT,^LA(T,"P")="OUT"
G LA2
;
;
NAK S ^LA(T,"O",0)=^LA(T,"P3") G W
M D UPD S POS=$P(IN,FS,6) S:$P(IN,FS,2)="R" ^LA(T,"C",0)=^LA(T,"P2"),ERC=$P(IN,FS,3) G W
;
P D UPD I POS=60 D NEGR S POS=0 G W
S REQ=$P(IN,FS,4),NC=$P(IN,FS,5),CAR=$S(NC=0:"A",1:0)
I ERC=7,NC=2 D NEGR G W
I ERC=7,NC=1 S CAR=$P(IN,FS,6),CAR=$S(CAR="A":"B",1:"A"),ERC=0
I REQ=0!('$D(^LA(T,"C"))) D NEGR G W
I ^LA(T,"C")=^("C",0) D NEGR K ^LA(T,"C") S ^LA(T,"P2")=0 G W
S ^LA(T,"P2")=^LA(T,"C",0)
P2 S Q=^LA(T,"C",0)+1,^(0)=Q,C=^(Q) I C'["%^%" D P4 G P2
D P4 G W
P4 S J=1,K=$L(C) S:$E(C,1)=$C(2) J=2,$P(C,FS1,2)=CAR S:(($E(C,1)=$C(2))&(CAR'="0")) $P(C,FS1,11)=1 S:C["%^%" K=K-3 D CS
I C["%^%" D HEX S C=$P(C,"%^%",1)_CS_$C(3)
S OUT=C D OUT
Q
NEGR S OUT=$C(2)_"N"_FS1_"6A"_$C(3) D OUT Q
R D UPD S OUT=$C(2)_"M"_FS1_"A"_FS1_FS1_"E2"_$C(3) D OUT G:RT="C" W
S NP=0,P=1 F I=1:1 Q:'$D(Y(I)) S F=0 F II=0:0 S F=$F(Y(I),FS,F) S NP=NP+1 D NX I F<1 S P=2,F=0 Q
S IDE=RS(3),ID=RS(4),TRAY=RS(6),CUP=$P(TRAY,";",2),TRAY=$P(TRAY,";",1),NS=RS(9),NT=RS(11),J=12,K=0
AG I $D(TEST(RS(J))),($D(RS(J+3))),(RS(J+3)="") S @TC(TEST(RS(J)),1)=RS(J+1)
S J=J+4,K=K+1 G:$D(RS(J)) AG G:ID<1 W S %H=$H D YMD^%DTC S:LADT'=X LADT=X K %,%H X LAGEN G:'ISQN W ;Can be changed by the cross-link code
F I=0:0 S I=$O(TV(I)) Q:I<1 S:TV(I,1)]"" ^LAH(LWL,1,ISQN,I)=TV(I,1)
G W
NX I F<1,($E(Y(I),$L(Y(I)))'="]") S NP=NP-1,RS(NP)=RS(NP)_$P(Y(I),FS,P),NP=NP+1,P=2,F=0 Q
S RS(NP)=$P(Y(I),FS,P),P=P+1
I F=256 S NP=NP+1,RS(NP)=$P(Y(I+1),FS),P=2,F=0
Q
IN L ^LA(T) S CNT=^LA(T,"I")+1,^("I")=CNT,^("I",CNT)=IN K:CNT-100>0 ^(CNT-100) L Q
OUT L ^LA(T) S O=^LA(T,"O")+1,^("O")=O,^("O",O)=OUT K:O-100>0 ^(O-100) L Q
UPD S ^LA(T,"I",0)=^LA(T,"I") Q
CS S CS=$S(J=2:0,1:CS) F I=J:1:K S CS=CS+$A(C,I)
Q
HEX S CS=CS#256,CS=$E("0123456789ABCDEF",(CS\16+1))_$E("0123456789ABCDEF",(CS#16+1)) Q
DQ K ^LA("LOCK",$E($T(+0),7,8)) G LADIMPXX
SET S:'$D(^LA(T,"I"))#2 ^LA(T,"I")=0,^("I",0)=0
SETO S:'$D(^LA(T,"O"))#2 ^LA(T,"O")=0,^("O",0)=0 Q
Q
DBO S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="OUT: "_$S($L(OUT)>1:$E(OUT,1,230),1:"~"_$C($A(OUT)+64))_"%^%"_$H Q
DBX S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: ~"_$C(X+64)_"%^%"_$H Q
DBI S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: "_$E(IN,1,230)_"%^%"_$H Q
TRAP D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLADIMPXX 3758 printed Dec 13, 2024@01:42:08 Page 2
LADIMPXX ;SLC/DLG - DIMENSION DIRECT CONNECT INTERFACE ;8/16/90 14:15 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LANM=$TEXT(+0)
SET (HOME,T,TSK)=$EXTRACT(LANM,7,8)
if +T<1
QUIT
if $DATA(^LA("LOCK",T))
QUIT
GOTO ^LADIMPI
LA ;Entry point from LADIMPI
LA2 KILL RS,TV,Y
SET RN=1
if OUT=""
GOTO RD
if $DATA(^LA(DEB,0))
DO DBO
WRITE OUT
if OUT[$CHAR(6)
GOTO W
if OUT[$CHAR(21)
GOTO NAK
if OUT[$CHAR(3)
GOTO RD
GOTO LA2
RD SET ^LA(T,"R")=$HOROLOG
READ *X:TOUT
if '$TEST
GOTO RD
if ($TEST&($DATA(^LA(DEB,0))))
DO DBX
if X=2
GOTO RD1
+1 IF X=6
SET IN=X
DO IN
SET ^LA(T,"P3")=^LA(T,"O",0)
SET OUT=""
GOTO RD
+2 IF X=21
SET IN=X
DO IN
SET ^LA(T,"O",0)=^LA(T,"P3")
GOTO W
+3 IF X=5
SET IN=X
DO IN
GOTO LA2
+4 SET IN=X
DO IN
GOTO RD
RD1 SET TOUT=5
SET IN="["
SET CS=0
SET ^LA(T,"P")="IN"
RD2 FOR I=0:0
READ *X:TOUT
if ($TEST&($LENGTH(IN)<255))
SET IN=IN_$SELECT(X=3:"]",X=28:FS,1:$CHAR(X))
SET CS=CS+X
if (X<0!(X=3)!($LENGTH(IN)=255))
QUIT
IF $LENGTH(IN)=2
IF $EXTRACT(IN)="["
SET RT=$EXTRACT(IN,2)
+1 if $DATA(^LA(DEB,0))
DO DBI
if RT="R"
SET Y(RN)=IN
SET RN=RN+1
+2 if '$DATA(^LA(T,"I"))
DO SET
DO IN
SET LN=$LENGTH(IN)
+3 IF LN=255
IF (X'=3)
SET IN=""
GOTO RD2
+4 IF LN<255
IF (X'=3)
SET OUT=$CHAR(21)
DO OUT
GOTO W
+5 if LN=1
SET CNT=^LA(T,"I")-1
SET LRCC=$EXTRACT(^LA(T,"I",CNT),($LENGTH(^(CNT))-1),$LENGTH(^(CNT)))
+6 if LN=2
SET CNT=^LA(T,"I")-1
SET LRCC=$EXTRACT(^LA(T,"I",CNT),$LENGTH(^(CNT)))_$EXTRACT(IN,1)
+7 if LN>2
SET LRCC=$EXTRACT(IN,LN-2,LN-1)
+8 SET CS=CS-3-$ASCII(LRCC)-$ASCII(LRCC,2)#256
SET LRCC=$FIND("0123456789ABCDEF",$EXTRACT(LRCC,1))-2*16+$FIND("0123456789ABCDEF",$EXTRACT(LRCC,2))-2
SET OUT=$CHAR($SELECT(CS=LRCC:6,1:21))
+9 DO OUT
if RT="P"
GOTO P
if RT="R"
GOTO R
if RT="C"
GOTO R
if RT="M"
GOTO M
W IF $DATA(^LA("STOP",HOME))
KILL ^LA("LOCK",HOME),^LA("STOP",HOME)
GOTO H^XUS
+1 SET OUT=""
SET CNT=^LA(T,"O",0)+1
IF $DATA(^(CNT))
SET OUT=^(CNT)
SET ^(0)=CNT
SET ^LA(T,"P")="OUT"
+2 GOTO LA2
+3 ;
+4 ;
NAK SET ^LA(T,"O",0)=^LA(T,"P3")
GOTO W
M DO UPD
SET POS=$PIECE(IN,FS,6)
if $PIECE(IN,FS,2)="R"
SET ^LA(T,"C",0)=^LA(T,"P2")
SET ERC=$PIECE(IN,FS,3)
GOTO W
+1 ;
P DO UPD
IF POS=60
DO NEGR
SET POS=0
GOTO W
+1 SET REQ=$PIECE(IN,FS,4)
SET NC=$PIECE(IN,FS,5)
SET CAR=$SELECT(NC=0:"A",1:0)
+2 IF ERC=7
IF NC=2
DO NEGR
GOTO W
+3 IF ERC=7
IF NC=1
SET CAR=$PIECE(IN,FS,6)
SET CAR=$SELECT(CAR="A":"B",1:"A")
SET ERC=0
+4 IF REQ=0!('$DATA(^LA(T,"C")))
DO NEGR
GOTO W
+5 IF ^LA(T,"C")=^("C",0)
DO NEGR
KILL ^LA(T,"C")
SET ^LA(T,"P2")=0
GOTO W
+6 SET ^LA(T,"P2")=^LA(T,"C",0)
P2 SET Q=^LA(T,"C",0)+1
SET ^(0)=Q
SET C=^(Q)
IF C'["%^%"
DO P4
GOTO P2
+1 DO P4
GOTO W
P4 SET J=1
SET K=$LENGTH(C)
if $EXTRACT(C,1)=$CHAR(2)
SET J=2
SET $PIECE(C,FS1,2)=CAR
if (($EXTRACT(C,1)=$CHAR(2))&(CAR'="0"))
SET $PIECE(C,FS1,11)=1
if C["%^%"
SET K=K-3
DO CS
+1 IF C["%^%"
DO HEX
SET C=$PIECE(C,"%^%",1)_CS_$CHAR(3)
+2 SET OUT=C
DO OUT
+3 QUIT
NEGR SET OUT=$CHAR(2)_"N"_FS1_"6A"_$CHAR(3)
DO OUT
QUIT
R DO UPD
SET OUT=$CHAR(2)_"M"_FS1_"A"_FS1_FS1_"E2"_$CHAR(3)
DO OUT
if RT="C"
GOTO W
+1 SET NP=0
SET P=1
FOR I=1:1
if '$DATA(Y(I))
QUIT
SET F=0
FOR II=0:0
SET F=$FIND(Y(I),FS,F)
SET NP=NP+1
DO NX
IF F<1
SET P=2
SET F=0
QUIT
+2 SET IDE=RS(3)
SET ID=RS(4)
SET TRAY=RS(6)
SET CUP=$PIECE(TRAY,";",2)
SET TRAY=$PIECE(TRAY,";",1)
SET NS=RS(9)
SET NT=RS(11)
SET J=12
SET K=0
AG IF $DATA(TEST(RS(J)))
IF ($DATA(RS(J+3)))
IF (RS(J+3)="")
SET @TC(TEST(RS(J)),1)=RS(J+1)
+1 ;Can be changed by the cross-link code
SET J=J+4
SET K=K+1
if $DATA(RS(J))
GOTO AG
if ID<1
GOTO W
SET %H=$HOROLOG
DO YMD^%DTC
if LADT'=X
SET LADT=X
KILL %,%H
XECUTE LAGEN
if 'ISQN
GOTO W
+2 FOR I=0:0
SET I=$ORDER(TV(I))
if I<1
QUIT
if TV(I,1)]""
SET ^LAH(LWL,1,ISQN,I)=TV(I,1)
+3 GOTO W
NX IF F<1
IF ($EXTRACT(Y(I),$LENGTH(Y(I)))'="]")
SET NP=NP-1
SET RS(NP)=RS(NP)_$PIECE(Y(I),FS,P)
SET NP=NP+1
SET P=2
SET F=0
QUIT
+1 SET RS(NP)=$PIECE(Y(I),FS,P)
SET P=P+1
+2 IF F=256
SET NP=NP+1
SET RS(NP)=$PIECE(Y(I+1),FS)
SET P=2
SET F=0
+3 QUIT
IN LOCK ^LA(T)
SET CNT=^LA(T,"I")+1
SET ^("I")=CNT
SET ^("I",CNT)=IN
if CNT-100>0
KILL ^(CNT-100)
LOCK
QUIT
OUT LOCK ^LA(T)
SET O=^LA(T,"O")+1
SET ^("O")=O
SET ^("O",O)=OUT
if O-100>0
KILL ^(O-100)
LOCK
QUIT
UPD SET ^LA(T,"I",0)=^LA(T,"I")
QUIT
CS SET CS=$SELECT(J=2:0,1:CS)
FOR I=J:1:K
SET CS=CS+$ASCII(C,I)
+1 QUIT
HEX SET CS=CS#256
SET CS=$EXTRACT("0123456789ABCDEF",(CS\16+1))_$EXTRACT("0123456789ABCDEF",(CS#16+1))
QUIT
DQ KILL ^LA("LOCK",$EXTRACT($TEXT(+0),7,8))
GOTO LADIMPXX
SET if '$DATA(^LA(T,"I"))#2
SET ^LA(T,"I")=0
SET ^("I",0)=0
SETO if '$DATA(^LA(T,"O"))#2
SET ^LA(T,"O")=0
SET ^("O",0)=0
QUIT
+1 QUIT
DBO SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
SET ^(Q)="OUT: "_$SELECT($LENGTH(OUT)>1:$EXTRACT(OUT,1,230),1:"~"_$CHAR($ASCII(OUT)+64))_"%^%"_$HOROLOG
QUIT
DBX SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
SET ^(Q)="IN: ~"_$CHAR(X+64)_"%^%"_$HOROLOG
QUIT
DBI SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
SET ^(Q)="IN: "_$EXTRACT(IN,1,230)_"%^%"_$HOROLOG
QUIT
TRAP DO ^LABERR
SET T=TSK
DO SET^LAB
GOTO @("LA2^"_LANM)
