LAPORT33 ;MLD/ABBOTT/SLC/RAF - AxSYM BIDRECTIONAL INTERFACE ; 6/12/96 0900
;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
;
; This routine LOOSELY follows the LAPORTXX template. However, this
; routine works ONLY for Abbott's AxSYM machine, and should comply
; with ASTM communication protocols. This pgm will run continuously
; as a background job until the system is taken down OR ^LA("STOP",INST)
; global flag is set. /mld
;
N LARETRY,LATOUT,LATEMP,LAFRAME,LAFRAM,LAEND,LACS,LAFRNUM,LADEV
N LAFRNM,LALINK,LACRLF,LACRETX,LANOCTL1,LANOCTL2,LADATA,LANM
N I,J,T,X,Y,INST,DEB,HOME,BASE,OUT,TOUT,PAR,TSK,NODE,OK,DEBUG,CNT
N NUL,SOH,STX,ETX,EOT,ENQ,ACK,NAK,ETB,LF,CR ; *control chars*
;
S LANM=$T(+0),(HOME,T)=+$E(LANM,7,8) Q:+T<1 Q:$D(^LA("LOCK","D"_T))
; init req'd params
D INIT^LAXSYMU I 'OK QUIT ; chk ^LA(INST,"ERR",$H) for err msg
;
PH1 ; PHase1 - idle/establish link (wait for AxSYM to send data)
S LADATA=$$GETCH I DEBUG D DEBG^LAXSYMU(LADATA,"I")
I LADATA=-1 G @($$CHK) ; idle - chk flags
I LADATA'=ENQ G PH1 ; read until ENQ rec'd
; AxSYM ready to send data so init vars, ACK and drop to PH2
S LAFRAME="",LARETRY=0,LATOUT=15,LAFRNM=0,LALINK=1
D SEND^LAXSYMU(ACK)
;
PH2 ; PHase2 - transfer data (build frame)
S LADATA=$$GETCH
I LADATA=-1 D SET G PH1 ; timed out - goto idle
S LAFRAME=LAFRAME_$C(LADATA) ; build frame
I $L(LAFRAME)>247 D NAK^LAXSYMU("SIZE") G:LARETRY<7 PH2 D SET G PH1
I LADATA=LF G PH3 ; LF=complete frame
I LADATA=EOT G PH3 ; no more data
G PH2
;
PH3 ; PHase3 (validate frame)
D:DEBUG DEBG^LAXSYMU(LAFRAME,"I") ; debug
S X=LAFRAME
I $F(X,$C(EOT)) D SET G PH1 ; EOT not allowed in txt
I $A(X)'=STX D SET G PH1 ; 1st char must be STX
; txt must end w/ ETX or ETB
S LAEND=$S($F(X,$C(ETX)):$F(X,$C(ETX)),1:$F(X,$C(ETB)))
I 'LAEND D NAK^LAXSYMU("LAEND") G PH2:LARETRY<7 D SET G PH1
;
S LAFRAM=$E(X,2,LAEND-1) ; get msg txt
; chk frame numbering sequence
S LAFRNUM=+LAFRAM,LAFRNM=$S(LAFRNM<7:LAFRNM+1,1:0)
I LAFRNM'=LAFRNUM D NAK^LAXSYMU("NUMSQNC") G PH2:LARETRY<7 D SET G PH1
I LAFRNUM'=(LAFRNUM#8) D NAK^LAXSYMU("FRNUM") G PH2:LARETRY<7 D SET G PH1
; chk restricted control chars in txt
I LAFRAM'=$TR(LAFRAM,LANOCTL2) D NAK^LAXSYMU("CTL") G PH2:LARETRY<7 D SET G PH1
; sent checksum must = received checksum
S LACS=$E(X,LAEND,LAEND+1) ; get passed cksum
I LACS'=$$CKSUM^LAXSYMU(LAFRAM) D NAK^LAXSYMU("CKSUM") G PH2:LARETRY<7 D SET G PH1
; chk for CR_LF terminating chars - timeout if NULL, NAK for all others
I $P(X,(LACRETX_LACS),2)="" D SET G PH1
I $P(X,(LACRETX_LACS),2)'=LACRLF D NAK^LAXSYMU("LACRLF") G PH2
;
D UPDT^LAXSYMU,SEND^LAXSYMU(ACK) ; frame OK - save & ACK
G PH2 ; get nxt frame
;
GETCH() ; read 1 char at a time. Returns Ascii value of terminating char
S ^LA(INST,"R")=$H
R *LATEMP:LATOUT
S DEBUG=$D(^LA(DEB,0)) ; debug on? (def=off)
Q LATEMP
;
CHK() ; Chk flags - Returns LINE TAG to branch to
S ^LA(INST,"R")=$H,LATOUT=30 ; update run-time flag
I $D(^LA(INST,"HQ")) S NODE="HQ" Q "DWNLD^LAXSYMDL" ; host query
I $D(^LA(INST,"Q")) S NODE="O" Q "DWNLD^LAXSYMDL" ; d/l l/w list
I '$D(^LA("STOP",INST)) Q "PH1" ; continue
Q "OUT" ; STOP = shutdown
;
SET ; Re-init vars
H 5 ; allow LAXSYM to catch up
K LAFRAM,X,LALINK,LAFRNM
S LATOUT=5,LAFRAME=""
Q:$$CHK["HQ"
H 13 ; force timeout & return to idle
Q
;
OUT ; Main Exit - remove flags, close port
K ^LA("STOP",INST),^LA(INST),^LA("LOCK","D"_INST)
D ^%ZISC
Q
;
TRAP ; Error Trap
D ^LABERR S T=TSK
D SET^LAB G PH1
Q
;
DQ ;Entry point to task job
S LANM=$T(+0),HOME=$E(LANM,7,8) Q:HOME=""!(HOME>99)
I $D(^LAB(62.4,HOME,0)),$L($P(^(0),"^",2)) S ZTIO=$P(^(0),"^",2),ZTRTN=LANM,ZTDTH=$H,ZTDESC="START LAB DIRECT CONNECT PORT "_HOME K ^LA("LOCK","D"_HOME) D ^%ZTLOAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAPORT33 3839 printed Dec 13, 2024@01:44:01 Page 2
LAPORT33 ;MLD/ABBOTT/SLC/RAF - AxSYM BIDRECTIONAL INTERFACE ; 6/12/96 0900
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
+2 ;
+3 ; This routine LOOSELY follows the LAPORTXX template. However, this
+4 ; routine works ONLY for Abbott's AxSYM machine, and should comply
+5 ; with ASTM communication protocols. This pgm will run continuously
+6 ; as a background job until the system is taken down OR ^LA("STOP",INST)
+7 ; global flag is set. /mld
+8 ;
+9 NEW LARETRY,LATOUT,LATEMP,LAFRAME,LAFRAM,LAEND,LACS,LAFRNUM,LADEV
+10 NEW LAFRNM,LALINK,LACRLF,LACRETX,LANOCTL1,LANOCTL2,LADATA,LANM
+11 NEW I,J,T,X,Y,INST,DEB,HOME,BASE,OUT,TOUT,PAR,TSK,NODE,OK,DEBUG,CNT
+12 ; *control chars*
NEW NUL,SOH,STX,ETX,EOT,ENQ,ACK,NAK,ETB,LF,CR
+13 ;
+14 SET LANM=$TEXT(+0)
SET (HOME,T)=+$EXTRACT(LANM,7,8)
if +T<1
QUIT
if $DATA(^LA("LOCK","D"_T))
QUIT
+15 ; init req'd params
+16 ; chk ^LA(INST,"ERR",$H) for err msg
DO INIT^LAXSYMU
IF 'OK
QUIT
+17 ;
PH1 ; PHase1 - idle/establish link (wait for AxSYM to send data)
+1 SET LADATA=$$GETCH
IF DEBUG
DO DEBG^LAXSYMU(LADATA,"I")
+2 ; idle - chk flags
IF LADATA=-1
GOTO @($$CHK)
+3 ; read until ENQ rec'd
IF LADATA'=ENQ
GOTO PH1
+4 ; AxSYM ready to send data so init vars, ACK and drop to PH2
+5 SET LAFRAME=""
SET LARETRY=0
SET LATOUT=15
SET LAFRNM=0
SET LALINK=1
+6 DO SEND^LAXSYMU(ACK)
+7 ;
PH2 ; PHase2 - transfer data (build frame)
+1 SET LADATA=$$GETCH
+2 ; timed out - goto idle
IF LADATA=-1
DO SET
GOTO PH1
+3 ; build frame
SET LAFRAME=LAFRAME_$CHAR(LADATA)
+4 IF $LENGTH(LAFRAME)>247
DO NAK^LAXSYMU("SIZE")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+5 ; LF=complete frame
IF LADATA=LF
GOTO PH3
+6 ; no more data
IF LADATA=EOT
GOTO PH3
+7 GOTO PH2
+8 ;
PH3 ; PHase3 (validate frame)
+1 ; debug
if DEBUG
DO DEBG^LAXSYMU(LAFRAME,"I")
+2 SET X=LAFRAME
+3 ; EOT not allowed in txt
IF $FIND(X,$CHAR(EOT))
DO SET
GOTO PH1
+4 ; 1st char must be STX
IF $ASCII(X)'=STX
DO SET
GOTO PH1
+5 ; txt must end w/ ETX or ETB
+6 SET LAEND=$SELECT($FIND(X,$CHAR(ETX)):$FIND(X,$CHAR(ETX)),1:$FIND(X,$CHAR(ETB)))
+7 IF 'LAEND
DO NAK^LAXSYMU("LAEND")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+8 ;
+9 ; get msg txt
SET LAFRAM=$EXTRACT(X,2,LAEND-1)
+10 ; chk frame numbering sequence
+11 SET LAFRNUM=+LAFRAM
SET LAFRNM=$SELECT(LAFRNM<7:LAFRNM+1,1:0)
+12 IF LAFRNM'=LAFRNUM
DO NAK^LAXSYMU("NUMSQNC")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+13 IF LAFRNUM'=(LAFRNUM#8)
DO NAK^LAXSYMU("FRNUM")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+14 ; chk restricted control chars in txt
+15 IF LAFRAM'=$TRANSLATE(LAFRAM,LANOCTL2)
DO NAK^LAXSYMU("CTL")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+16 ; sent checksum must = received checksum
+17 ; get passed cksum
SET LACS=$EXTRACT(X,LAEND,LAEND+1)
+18 IF LACS'=$$CKSUM^LAXSYMU(LAFRAM)
DO NAK^LAXSYMU("CKSUM")
if LARETRY<7
GOTO PH2
DO SET
GOTO PH1
+19 ; chk for CR_LF terminating chars - timeout if NULL, NAK for all others
+20 IF $PIECE(X,(LACRETX_LACS),2)=""
DO SET
GOTO PH1
+21 IF $PIECE(X,(LACRETX_LACS),2)'=LACRLF
DO NAK^LAXSYMU("LACRLF")
GOTO PH2
+22 ;
+23 ; frame OK - save & ACK
DO UPDT^LAXSYMU
DO SEND^LAXSYMU(ACK)
+24 ; get nxt frame
GOTO PH2
+25 ;
GETCH() ; read 1 char at a time. Returns Ascii value of terminating char
+1 SET ^LA(INST,"R")=$HOROLOG
+2 READ *LATEMP:LATOUT
+3 ; debug on? (def=off)
SET DEBUG=$DATA(^LA(DEB,0))
+4 QUIT LATEMP
+5 ;
CHK() ; Chk flags - Returns LINE TAG to branch to
+1 ; update run-time flag
SET ^LA(INST,"R")=$HOROLOG
SET LATOUT=30
+2 ; host query
IF $DATA(^LA(INST,"HQ"))
SET NODE="HQ"
QUIT "DWNLD^LAXSYMDL"
+3 ; d/l l/w list
IF $DATA(^LA(INST,"Q"))
SET NODE="O"
QUIT "DWNLD^LAXSYMDL"
+4 ; continue
IF '$DATA(^LA("STOP",INST))
QUIT "PH1"
+5 ; STOP = shutdown
QUIT "OUT"
+6 ;
SET ; Re-init vars
+1 ; allow LAXSYM to catch up
HANG 5
+2 KILL LAFRAM,X,LALINK,LAFRNM
+3 SET LATOUT=5
SET LAFRAME=""
+4 if $$CHK["HQ"
QUIT
+5 ; force timeout & return to idle
HANG 13
+6 QUIT
+7 ;
OUT ; Main Exit - remove flags, close port
+1 KILL ^LA("STOP",INST),^LA(INST),^LA("LOCK","D"_INST)
+2 DO ^%ZISC
+3 QUIT
+4 ;
TRAP ; Error Trap
+1 DO ^LABERR
SET T=TSK
+2 DO SET^LAB
GOTO PH1
+3 QUIT
+4 ;
DQ ;Entry point to task job
+1 SET LANM=$TEXT(+0)
SET HOME=$EXTRACT(LANM,7,8)
if HOME=""!(HOME>99)
QUIT
+2 IF $DATA(^LAB(62.4,HOME,0))
IF $LENGTH($PIECE(^(0),"^",2))
SET ZTIO=$PIECE(^(0),"^",2)
SET ZTRTN=LANM
SET ZTDTH=$HOROLOG
SET ZTDESC="START LAB DIRECT CONNECT PORT "_HOME
KILL ^LA("LOCK","D"_HOME)
DO ^%ZTLOAD
+3 QUIT
