- LAMIVTLX ;SLC/DLG/DALISC/PAC - VITEK LITERAL PROTOCOL CONTROLLER ;
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**12**;Sep 27, 1994
- ;;
- ;Call with T set to Instrument data is to/from
- ; P1= RESET POINT FOR INCOMING RECORDS,
- ; P3=Reset point FOR RECORDS SENT
- S OSTX=$C(2),OETX=$C(3),OEDT=$C(4),OENQ=$C(5),OACK=$C(6),ONAK=$C(21)
- RCHK K LATYPE S:IN'["~" LATYPE="X" S:'$D(LATYPE) LATYPE=$E(IN,$F(IN,"~"))
- Q:"BCDEFUX^]"'[LATYPE
- S LATYPE=$S(LATYPE="]":"GS",LATYPE="^":"RS",LATYPE="B":"RS",1:LATYPE)
- S OLDTYPE=LATYPE D @LATYPE
- ;,^LA(T,"I")=^LA(T,"I")+1 D @LATYPE
- ;I LATYPE="B" G RCHK
- Q
- B ; ~B RECEIVED STX 2
- D RS Q ; S OUT="",%=OUT Q
- C ; ~C RECEIVED ETX 3
- Q
- D ; ~D RECEIVED EOT 4
- I OLDTYPE="X" D CKSUM S OUT=$S(LASUM=LASUM1:$C(6),1:$C(21)) Q
- I $D(^LA(T,"O",0)),^LA(T,"O")'=^LA(T,"O",0) S K=1 D OUT Q
- Q
- E ; ~E RECEIVED ENQ 5
- ;S OUT=$C(6),%=OUT
- S ^LA(T,"P1")=CNT+2,OUT=$C(6),%=OUT
- ;I ^LA(T,"O",^LA(T,"P3"))[$C(29) S ^LA(T,"O",0)=^LA(T,"P2") L ^LA(T) S Q=^LA("Q")+1,^("Q")=Q,^LA("Q",Q)=T L ;OUTPUT WAS HUNG RESET FOR RETRANSMISSION
- S T=T-BASE Q
- ;
- F ;~F RECEIVED ACK 6
- S O=^LA(T,"O",0),^LA(T,"P3")=$S(^LA(T,"O",O)[$C(2):O+1,1:O) S K=1 D OUT
- Q
- GS ; ~] GS RECORD NEXT RECORD SHOULD BE X TYPE LENGTH 2 ? 35
- D CKSUM Q ;S OUT=OACK,%=OACK Q
- RS ; ~^ RECEIVED RS DATA PACKET 30
- D CKSUM Q
- U ; ~U RECEIVED NAK 21
- S ^LA(T,"O",0)=^LA(T,"P3"),K=1 D OUT Q ;RECEIVED NAK
- X ;RECEIVED GS CKSUM PACKET/?
- ;D CKSUM I $L(IN)=2,$E(IN,2)="D" S OUT=$C(6),%=OUT,^LA(T,"P1")=CNT+1 S T=T-BASE K LASUM,LASUM1 Q
- D CKSUM I $L(IN)=2 S OUT=$S(LASUM=LASUM1:$C(6),1:$C(6)),%=OUT S:LASUM=LASUM1 ^LA(T,"P1")=CNT+1 S T=T-BASE K LASUM,LASUM1 Q ;RECEIVED GS CKSUM PACKET
- S ^LA(T,"P1")=CNT+1
- Q
- CKSUM S:'$D(LASUM) LASUM=0
- S LASUM=$S(LATYPE="RS":30,LATYPE="GS":29,LATYPE="X":23,1:0)+LASUM
- ;I LATYPE="X",($L(IN)>2) F I=1:1:$L(IN) S LASUM=LASUM+$A(IN,I)
- ;I LATYPE="X",($L(IN)=2)
- I LATYPE="X" S LASUM=LASUM-23,LASUM=LASUM#256,LASUM1=$F("0123456789abcdef",$E(IN,1))-2*16+($F("0123456789abcdef",$E(IN,2))-2)
- Q
- OUT D NEXT Q:'$D(^LA(T,"O",O)) Q:%[$C(29) ;Q:%[$C(4) Q:%[$C(5)
- S K=K+1 G OUT Q
- NEXT S O=^LA(T,"O",0)+K Q:'$D(^(O)) S %=^(O)
- L ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T L Q
- ACK S LASUM1=$F("0123456789abcdef",$E(IN,121))-2*16+($F("0123456789abcdef",$E(IN,122))-2)
- S LASUM=0 F I=1:1:120 S LASUM=LASUM+(255-$A(IN,I)+1)
- S LASUM=LASUM#256,OUT=$S(LASUM=LASUM1:$C(6),1:$C(21)),%=OUT S T=T-BASE Q
- ;S LASUM=LASUM#256,OUT=$C(6),%=OUT S T=T-BASE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIVTLX 2487 printed Feb 18, 2025@23:10:01 Page 2
- LAMIVTLX ;SLC/DLG/DALISC/PAC - VITEK LITERAL PROTOCOL CONTROLLER ;
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12**;Sep 27, 1994
- +2 ;;
- +3 ;Call with T set to Instrument data is to/from
- +4 ; P1= RESET POINT FOR INCOMING RECORDS,
- +5 ; P3=Reset point FOR RECORDS SENT
- +6 SET OSTX=$CHAR(2)
- SET OETX=$CHAR(3)
- SET OEDT=$CHAR(4)
- SET OENQ=$CHAR(5)
- SET OACK=$CHAR(6)
- SET ONAK=$CHAR(21)
- RCHK KILL LATYPE
- if IN'["~"
- SET LATYPE="X"
- if '$DATA(LATYPE)
- SET LATYPE=$EXTRACT(IN,$FIND(IN,"~"))
- +1 if "BCDEFUX^]"'[LATYPE
- QUIT
- +2 SET LATYPE=$SELECT(LATYPE="]":"GS",LATYPE="^":"RS",LATYPE="B":"RS",1:LATYPE)
- +3 SET OLDTYPE=LATYPE
- DO @LATYPE
- +4 ;,^LA(T,"I")=^LA(T,"I")+1 D @LATYPE
- +5 ;I LATYPE="B" G RCHK
- +6 QUIT
- B ; ~B RECEIVED STX 2
- +1 ; S OUT="",%=OUT Q
- DO RS
- QUIT
- C ; ~C RECEIVED ETX 3
- +1 QUIT
- D ; ~D RECEIVED EOT 4
- +1 IF OLDTYPE="X"
- DO CKSUM
- SET OUT=$SELECT(LASUM=LASUM1:$CHAR(6),1:$CHAR(21))
- QUIT
- +2 IF $DATA(^LA(T,"O",0))
- IF ^LA(T,"O")'=^LA(T,"O",0)
- SET K=1
- DO OUT
- QUIT
- +3 QUIT
- E ; ~E RECEIVED ENQ 5
- +1 ;S OUT=$C(6),%=OUT
- +2 SET ^LA(T,"P1")=CNT+2
- SET OUT=$CHAR(6)
- SET %=OUT
- +3 ;I ^LA(T,"O",^LA(T,"P3"))[$C(29) S ^LA(T,"O",0)=^LA(T,"P2") L ^LA(T) S Q=^LA("Q")+1,^("Q")=Q,^LA("Q",Q)=T L ;OUTPUT WAS HUNG RESET FOR RETRANSMISSION
- +4 SET T=T-BASE
- QUIT
- +5 ;
- F ;~F RECEIVED ACK 6
- +1 SET O=^LA(T,"O",0)
- SET ^LA(T,"P3")=$SELECT(^LA(T,"O",O)[$CHAR(2):O+1,1:O)
- SET K=1
- DO OUT
- +2 QUIT
- GS ; ~] GS RECORD NEXT RECORD SHOULD BE X TYPE LENGTH 2 ? 35
- +1 ;S OUT=OACK,%=OACK Q
- DO CKSUM
- QUIT
- RS ; ~^ RECEIVED RS DATA PACKET 30
- +1 DO CKSUM
- QUIT
- U ; ~U RECEIVED NAK 21
- +1 ;RECEIVED NAK
- SET ^LA(T,"O",0)=^LA(T,"P3")
- SET K=1
- DO OUT
- QUIT
- X ;RECEIVED GS CKSUM PACKET/?
- +1 ;D CKSUM I $L(IN)=2,$E(IN,2)="D" S OUT=$C(6),%=OUT,^LA(T,"P1")=CNT+1 S T=T-BASE K LASUM,LASUM1 Q
- +2 ;RECEIVED GS CKSUM PACKET
- DO CKSUM
- IF $LENGTH(IN)=2
- SET OUT=$SELECT(LASUM=LASUM1:$CHAR(6),1:$CHAR(6))
- SET %=OUT
- if LASUM=LASUM1
- SET ^LA(T,"P1")=CNT+1
- SET T=T-BASE
- KILL LASUM,LASUM1
- QUIT
- +3 SET ^LA(T,"P1")=CNT+1
- +4 QUIT
- CKSUM if '$DATA(LASUM)
- SET LASUM=0
- +1 SET LASUM=$SELECT(LATYPE="RS":30,LATYPE="GS":29,LATYPE="X":23,1:0)+LASUM
- +2 ;I LATYPE="X",($L(IN)>2) F I=1:1:$L(IN) S LASUM=LASUM+$A(IN,I)
- +3 ;I LATYPE="X",($L(IN)=2)
- +4 IF LATYPE="X"
- SET LASUM=LASUM-23
- SET LASUM=LASUM#256
- SET LASUM1=$FIND("0123456789abcdef",$EXTRACT(IN,1))-2*16+($FIND("0123456789abcdef",$EXTRACT(IN,2))-2)
- +5 QUIT
- OUT ;Q:%[$C(4) Q:%[$C(5)
- DO NEXT
- if '$DATA(^LA(T,"O",O))
- QUIT
- if %[$CHAR(29)
- QUIT
- +1 SET K=K+1
- GOTO OUT
- QUIT
- NEXT SET O=^LA(T,"O",0)+K
- if '$DATA(^(O))
- QUIT
- SET %=^(O)
- +1 LOCK ^LA("Q")
- SET Q=^LA("Q")+1
- SET ^("Q")=Q
- SET ^("Q",Q)=T
- LOCK
- QUIT
- ACK SET LASUM1=$FIND("0123456789abcdef",$EXTRACT(IN,121))-2*16+($FIND("0123456789abcdef",$EXTRACT(IN,122))-2)
- +1 SET LASUM=0
- FOR I=1:1:120
- SET LASUM=LASUM+(255-$ASCII(IN,I)+1)
- +2 SET LASUM=LASUM#256
- SET OUT=$SELECT(LASUM=LASUM1:$CHAR(6),1:$CHAR(21))
- SET %=OUT
- SET T=T-BASE
- QUIT
- +3 ;S LASUM=LASUM#256,OUT=$C(6),%=OUT S T=T-BASE
- +4 QUIT
