- LADIMPXX ; IHS/DIR/FJE - DIMENSION DIRECT CONNECT INTERFACE 8/16/90 14:15 ;
- ;;5.2;LA;;NOV 01, 1997
- ;;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)
- LADIMPXX ; IHS/DIR/FJE - DIMENSION DIRECT CONNECT INTERFACE 8/16/90 14:15 ;
- +1 ;;5.2;LA;;NOV 01, 1997
- +2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +3 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)
