- LABCX4XX ;SLC/DLG - BECKMAN BIDIRECTIONAL DIRECT CONNECT INTERFACE ;8/16/90 14:53 ;
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- S:$D(ZTQUEUED) ZTREQ="@"
- S LANM=$T(+0),(TSK,T)=+$E(LANM,7,8) Q:+T<1 Q:$D(^LA("LOCK",T)) S IOP=$P(^LAB(62.4,T,0),"^",2) G:IOP="" H^XUS G ^LABCX4I
- LA2 K RES,TV,Y S A=1 G RD:OUT="" D:$D(^LA(DEB,0)) DBO W OUT G RD:$A(OUT,1)<32
- I OUT'["]" G W
- W !
- RD S:OUT["[" TOUT=$S($P(OUT,",",3)="03":180,1:15) S IN="",A=0 R *X:TOUT G:'$T TOUT D:$D(^LA(DEB,0)) DBX S IN=$C(X) D IN G RD1:IN="["
- I X=LB S ^LA(T,"P")="IN",OUT=$C(ACK),^("P1")=ETX G LA2
- I X=LBO S OUT=$C(NAK) G LA2
- I X=EOT S ^LA(T,"P")="",(^("P1"),^("P2"))=ACK,OUT="" G LA2
- I X=ENQ G LA2
- I X=NAK S ^LA(T,"O",0)=^LA(T,"P3") G W
- I X=^LA(T,"P2") S ^("P2")=$S(X=ACK:ETX,1:ACK),^LA(T,"P3")=^LA(T,"O",0),OUT="",FLA=1,^LA(T,"P")="OUT" G RD
- S OUT="" G LA2
- RD1 S TOUT=2,CK=X,FL=1,^LA(T,"P")="IN"
- RD2 F I=0:0 Q:$L(IN)=255 R *X:TOUT Q:('$T!(X=13)) S:FL CK=CK+X S IN=IN_$C(X) S:X=93 FL=0
- D:'$D(^LA(T,"I")) SET D IN,QC,DBI:$D(^LA(DEB,0)) S LN=$L(IN)
- I LN=255,(IN'["]") S IN="" G RD2
- I LN<255,(IN'["]") S OUT=$C(NAK) G LA2
- S LRCC=$S(LN=1:$E(Y(A-1),$L(Y(A-1)))_IN,LN=2:IN,1:$E(IN,LN-1,LN))
- S CK=CK+($F("0123456789ABCDEF",$E(LRCC,1))-2*16)+$F("0123456789ABCDEF",$E(LRCC,2))-2#256 S:CK OUT=$C(NAK) G:CK LA2 S OUT=$C(^LA(T,"P1")),^LA(T,"P1")=$S(^LA(T,"P1")=ACK:ETX,1:ACK)
- K TV S (TRAY,CUP,ID,IDE,RMK)="",ST=+$P(Y(1),",",2),FC=+$P(Y(1),",",3) G @ST
- 400 ;
- 403 ;
- 404 G LA2
- 401 G:FC#2 LA2 S RC=+$P(Y(1),",",$S(FC=2:4,1:5)) G:RC>0 LA2 D OUT G LA2
- 402 D HDR:FC=1,RES:FC=3,RES1:FC=11 G LA2:'(FC=1!(FC=3)!(FC=11))
- LA3 G:ID="" LA2 X LAGEN G LA2:'ISQN
- F I=0:0 S I=$O(TV(I)) Q:I<1 S:TV(I,1)]"" ^LAH(LWL,1,ISQN,I)=TV(I,1)
- S:$L(RMK) ^LAH(LWL,1,ISQN,1)=RMK G LA2
- W IF $D(^LA("STOP",T)) K ^LA("LOCK",T),^LA("STOP",T) G H^XUS
- S OUT="",CNT=^LA(T,"O",0)+1 I $D(^(CNT)) S ^(0)=CNT,OUT=^(CNT)
- S:OUT=$C(4,1) ^LA(T,"P")="PEND" G LA2
- TOUT S %H=$H D YMD^%DTC S:LADT'=X LADT=X K %,%H
- I $D(^LA(T,"O")),^LA(T,"O")>^LA(T,"O",0) G W
- I $D(^LA(T,"C")),^LA(T,"C")>^("C",0) D OUT G TOUT
- G RD Q
- QC S A=A+1,Y(A)=IN Q
- NUM S X="" F JJ=1:1:$L(V) S:$A(V,JJ)>32 X=X_$E(V,JJ)
- S V=X Q
- IN Q:IN="[" L ^LA(T,"I") S (CNT,^LA(T,"I"),^LA(T,"I",0))=^LA(T,"I")+1,^LA(T,"I",CNT)=$S($L(IN)>1:IN,1:"~"_$C(X+64)) K:CNT>100 ^LA(T,"I",CNT-100) L Q
- OUT Q:'$D(^LA(T,"C",0)) S MV="",CNT=^LA(T,"C",0)+1 I $D(^(CNT)) S ^(0)=CNT,MV=^(CNT),CT=^LA(T,"O")+1,^("O")=CT,^("O",CT)=MV K:CT>100 ^LA(T,"O",CT-100)
- Q:MV="" I MV'[$C(4),(MV'["]") G OUT
- HDR S IDE=+$P(Y(1),",",19),ID=+$P(Y(1),",",15),TRAY=+$P(Y(1),",",8),CUP=+$P(Y(1),",",9)
- S RMK=$P(Y(1),",",16)_$P(Y(1),",",17)_$P(Y(1),",",27)_$P(Y(2),",",1) F I=$L(RMK):-1:1 Q:$E(RMK,I)'=" " S RMK=$E(RMK,1,I-1)
- Q
- RES S TRAY=+$P(Y(1),",",8),CUP=+$P(Y(1),",",9),V=$P(Y(1),",",10) D NUM S TS=V,V=$P(Y(1),",",15) D NUM S:V="" V=$P(Y(1),",",23) D NUM S V=$S("*"[V:"","#"[V:"",1:V) I V]"",($D(TS(TS))#2) S @TC(TS(TS),1)=+V
- F S J=$O(^LAH(LWL,1,"B",TRAY_";"_CUP,0)) I J>0 S ID=$P(^LAH(LWL,1,J,0),"^",5)
- Q
- RES1 S TRAY=+$P(Y(1),",",5),CUP=+$P(Y(1),",",6),V=$P(Y(1),",",8) D NUM S TS=V
- S V=$P(Y(1),",",10) D NUM S:"*"[V V="" I V]"",($D(TS(TS))#2),($P(Y(1),",",11)="OK") S @TC(TS(TS),1)=+V
- G F
- DQ K ^LA("LOCK",$E($T(+0),7,8)) G LABCX4XX
- 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
- TRAP D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM)
- DBO S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="OUT: "_$S($L(OUT)>2:$E(OUT,1,230),$L(OUT)=1:"~"_$C($A(OUT)+64),1:"~"_$C($A(OUT,1)+64)_"~"_$C($A(OUT,2)+64))_"%^%"_$H Q
- DBX Q:X=91 S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: "_$S(X>31:$C(X),1:"~"_$C(X+64))_"%^%"_$H Q
- DBI S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: "_$E(IN,1,230)_"%^%"_$H Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLABCX4XX 3735 printed Feb 18, 2025@23:07:51 Page 2
- LABCX4XX ;SLC/DLG - BECKMAN BIDIRECTIONAL DIRECT CONNECT INTERFACE ;8/16/90 14:53 ;
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +2 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 SET LANM=$TEXT(+0)
- SET (TSK,T)=+$EXTRACT(LANM,7,8)
- if +T<1
- QUIT
- if $DATA(^LA("LOCK",T))
- QUIT
- SET IOP=$PIECE(^LAB(62.4,T,0),"^",2)
- if IOP=""
- GOTO H^XUS
- GOTO ^LABCX4I
- LA2 KILL RES,TV,Y
- SET A=1
- if OUT=""
- GOTO RD
- if $DATA(^LA(DEB,0))
- DO DBO
- WRITE OUT
- if $ASCII(OUT,1)<32
- GOTO RD
- +1 IF OUT'["]"
- GOTO W
- +2 WRITE !
- RD if OUT["["
- SET TOUT=$SELECT($PIECE(OUT,",",3)="03":180,1:15)
- SET IN=""
- SET A=0
- READ *X:TOUT
- if '$TEST
- GOTO TOUT
- if $DATA(^LA(DEB,0))
- DO DBX
- SET IN=$CHAR(X)
- DO IN
- if IN="["
- GOTO RD1
- +1 IF X=LB
- SET ^LA(T,"P")="IN"
- SET OUT=$CHAR(ACK)
- SET ^("P1")=ETX
- GOTO LA2
- +2 IF X=LBO
- SET OUT=$CHAR(NAK)
- GOTO LA2
- +3 IF X=EOT
- SET ^LA(T,"P")=""
- SET (^("P1"),^("P2"))=ACK
- SET OUT=""
- GOTO LA2
- +4 IF X=ENQ
- GOTO LA2
- +5 IF X=NAK
- SET ^LA(T,"O",0)=^LA(T,"P3")
- GOTO W
- +6 IF X=^LA(T,"P2")
- SET ^("P2")=$SELECT(X=ACK:ETX,1:ACK)
- SET ^LA(T,"P3")=^LA(T,"O",0)
- SET OUT=""
- SET FLA=1
- SET ^LA(T,"P")="OUT"
- GOTO RD
- +7 SET OUT=""
- GOTO LA2
- RD1 SET TOUT=2
- SET CK=X
- SET FL=1
- SET ^LA(T,"P")="IN"
- RD2 FOR I=0:0
- if $LENGTH(IN)=255
- QUIT
- READ *X:TOUT
- if ('$TEST!(X=13))
- QUIT
- if FL
- SET CK=CK+X
- SET IN=IN_$CHAR(X)
- if X=93
- SET FL=0
- +1 if '$DATA(^LA(T,"I"))
- DO SET
- DO IN
- DO QC
- if $DATA(^LA(DEB,0))
- DO DBI
- SET LN=$LENGTH(IN)
- +2 IF LN=255
- IF (IN'["]")
- SET IN=""
- GOTO RD2
- +3 IF LN<255
- IF (IN'["]")
- SET OUT=$CHAR(NAK)
- GOTO LA2
- +4 SET LRCC=$SELECT(LN=1:$EXTRACT(Y(A-1),$LENGTH(Y(A-1)))_IN,LN=2:IN,1:$EXTRACT(IN,LN-1,LN))
- +5 SET CK=CK+($FIND("0123456789ABCDEF",$EXTRACT(LRCC,1))-2*16)+$FIND("0123456789ABCDEF",$EXTRACT(LRCC,2))-2#256
- if CK
- SET OUT=$CHAR(NAK)
- if CK
- GOTO LA2
- SET OUT=$CHAR(^LA(T,"P1"))
- SET ^LA(T,"P1")=$SELECT(^LA(T,"P1")=ACK:ETX,1:ACK)
- +6 KILL TV
- SET (TRAY,CUP,ID,IDE,RMK)=""
- SET ST=+$PIECE(Y(1),",",2)
- SET FC=+$PIECE(Y(1),",",3)
- GOTO @ST
- 400 ;
- 403 ;
- 404 GOTO LA2
- 401 if FC#2
- GOTO LA2
- SET RC=+$PIECE(Y(1),",",$SELECT(FC=2:4,1:5))
- if RC>0
- GOTO LA2
- DO OUT
- GOTO LA2
- 402 if FC=1
- DO HDR
- if FC=3
- DO RES
- if FC=11
- DO RES1
- if '(FC=1!(FC=3)!(FC=11))
- GOTO LA2
- LA3 if ID=""
- GOTO LA2
- XECUTE LAGEN
- if 'ISQN
- GOTO LA2
- +1 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)
- +2 if $LENGTH(RMK)
- SET ^LAH(LWL,1,ISQN,1)=RMK
- GOTO LA2
- W IF $DATA(^LA("STOP",T))
- KILL ^LA("LOCK",T),^LA("STOP",T)
- GOTO H^XUS
- +1 SET OUT=""
- SET CNT=^LA(T,"O",0)+1
- IF $DATA(^(CNT))
- SET ^(0)=CNT
- SET OUT=^(CNT)
- +2 if OUT=$CHAR(4,1)
- SET ^LA(T,"P")="PEND"
- GOTO LA2
- TOUT SET %H=$HOROLOG
- DO YMD^%DTC
- if LADT'=X
- SET LADT=X
- KILL %,%H
- +1 IF $DATA(^LA(T,"O"))
- IF ^LA(T,"O")>^LA(T,"O",0)
- GOTO W
- +2 IF $DATA(^LA(T,"C"))
- IF ^LA(T,"C")>^("C",0)
- DO OUT
- GOTO TOUT
- +3 GOTO RD
- QUIT
- QC SET A=A+1
- SET Y(A)=IN
- QUIT
- NUM SET X=""
- FOR JJ=1:1:$LENGTH(V)
- if $ASCII(V,JJ)>32
- SET X=X_$EXTRACT(V,JJ)
- +1 SET V=X
- QUIT
- IN if IN="["
- QUIT
- LOCK ^LA(T,"I")
- SET (CNT,^LA(T,"I"),^LA(T,"I",0))=^LA(T,"I")+1
- SET ^LA(T,"I",CNT)=$SELECT($LENGTH(IN)>1:IN,1:"~"_$CHAR(X+64))
- if CNT>100
- KILL ^LA(T,"I",CNT-100)
- LOCK
- QUIT
- OUT if '$DATA(^LA(T,"C",0))
- QUIT
- SET MV=""
- SET CNT=^LA(T,"C",0)+1
- IF $DATA(^(CNT))
- SET ^(0)=CNT
- SET MV=^(CNT)
- SET CT=^LA(T,"O")+1
- SET ^("O")=CT
- SET ^("O",CT)=MV
- if CT>100
- KILL ^LA(T,"O",CT-100)
- +1 if MV=""
- QUIT
- IF MV'[$CHAR(4)
- IF (MV'["]")
- GOTO OUT
- HDR SET IDE=+$PIECE(Y(1),",",19)
- SET ID=+$PIECE(Y(1),",",15)
- SET TRAY=+$PIECE(Y(1),",",8)
- SET CUP=+$PIECE(Y(1),",",9)
- +1 SET RMK=$PIECE(Y(1),",",16)_$PIECE(Y(1),",",17)_$PIECE(Y(1),",",27)_$PIECE(Y(2),",",1)
- FOR I=$LENGTH(RMK):-1:1
- if $EXTRACT(RMK,I)'=" "
- QUIT
- SET RMK=$EXTRACT(RMK,1,I-1)
- +2 QUIT
- RES SET TRAY=+$PIECE(Y(1),",",8)
- SET CUP=+$PIECE(Y(1),",",9)
- SET V=$PIECE(Y(1),",",10)
- DO NUM
- SET TS=V
- SET V=$PIECE(Y(1),",",15)
- DO NUM
- if V=""
- SET V=$PIECE(Y(1),",",23)
- DO NUM
- SET V=$SELECT("*"[V:"","#"[V:"",1:V)
- IF V]""
- IF ($DATA(TS(TS))#2)
- SET @TC(TS(TS),1)=+V
- F SET J=$ORDER(^LAH(LWL,1,"B",TRAY_";"_CUP,0))
- IF J>0
- SET ID=$PIECE(^LAH(LWL,1,J,0),"^",5)
- +1 QUIT
- RES1 SET TRAY=+$PIECE(Y(1),",",5)
- SET CUP=+$PIECE(Y(1),",",6)
- SET V=$PIECE(Y(1),",",8)
- DO NUM
- SET TS=V
- +1 SET V=$PIECE(Y(1),",",10)
- DO NUM
- if "*"[V
- SET V=""
- IF V]""
- IF ($DATA(TS(TS))#2)
- IF ($PIECE(Y(1),",",11)="OK")
- SET @TC(TS(TS),1)=+V
- +2 GOTO F
- DQ KILL ^LA("LOCK",$EXTRACT($TEXT(+0),7,8))
- GOTO LABCX4XX
- 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
- TRAP DO ^LABERR
- SET T=TSK
- DO SET^LAB
- GOTO @("LA2^"_LANM)
- DBO SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="OUT: "_$SELECT($LENGTH(OUT)>2:$EXTRACT(OUT,1,230),$LENGTH(OUT)=1:"~"_$CHAR($ASCII(OUT)+64),1:"~"_$CHAR($ASCII(OUT,1)+64)_"~"_$CHAR($ASCII(OUT,2)+64))_"%^%"_$HOROLOG
- QUIT
- DBX if X=91
- QUIT
- SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="IN: "_$SELECT(X>31:$CHAR(X),1:"~"_$CHAR(X+64))_"%^%"_$HOROLOG
- QUIT
- DBI SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="IN: "_$EXTRACT(IN,1,230)_"%^%"_$HOROLOG
- QUIT
