LAXSYMU ;MLD/ABBOTT/SLC/RAF - AxSYM INTERFACE Utility Routine; 6/12/96 0900
;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
;
; This routine serves as general UTILITY routine for the AxSYM
; interface. While not as efficient as all code being in ONE
; routine, portability requirements must be met. /mld
;
Q ; call line tag
;
UPDT ; To LA global ($TR used to remove CTRL chars from LAFRAM)
L +^LA(INST,"I")
I '$D(^LA(INST,"I")) X $G(^LAB(62.4,INST,1)) ; runs LAXSYM (LA->LAH)
S:'$D(^LA(INST,"I"))#2 ^LA(INST,"I")=0,^("I",0)=0
S CNT=$G(^LA(INST,"I"))+1,^("I")=CNT,^("I",CNT)=$TR(LAFRAM,LANOCTL1)
K LAFRAM,X
S LAFRAME="",LARETRY=0,LALINK=0
L -^LA(INST,"I")
Q
;
CKSUM(S,MOD) ; convert string (S) to decimal num (N) then to
; hex modulo 16**MOD (def=2=256)
N I,HX,HXN,DIV,N S N=0,DIV=1 S:'$D(MOD) MOD=2
F I=1:1:$L(S) S N=N+$A(S,I) ; get ASCII chars in string S
F I=1:1:MOD S DIV=16*DIV ; get MOD value (def=16*16)
S HX=N#DIV,N=""
F Q:HX=0 S HXN=HX#16,HX=HX\16,N=$S(HXN>9:$E("ABCDEF",HXN#10+1),1:HXN)_N
S N="00000000"_N,N=$E(N,$L(N)-MOD+1,$L(N))
Q N
;
SEND(N) ; Send reply msg (ACK, NAK, etc.)
W $C(N)
D:DEBUG DEBG(N,"O")
Q
;
DEBG(A,B) ; DEBuG tool - capture all data going in & out. (Def=OFF)
; A=data that went out/came in B="I"=IN; "O"=OUT
N MSG,CT
S MSG=$S(B="I":"IN: ",1:"OUT: ")_A_" %^% "_$H
S (CT,^LA(DEB,0))=$G(^LA(DEB,0))+1,^LA(DEB,CT)=MSG
Q
;
NAK(M) ; send NAK and retry (M = error 'type', EOT, STX, etc.)
S ^LA(INST,"ERR",$H,M)=LAFRAME ; capture
S LAFRAME="",LARETRY=LARETRY+1 ; increment # retries
I LARETRY=7 D SEND(EOT),@("SET^"_LANM) Q ; too many NAK's - goto idle
I 'LALINK S LAFRNM=$S(LAFRNM:LAFRNM-1,1:7) ; LALINK=1 on 1ST frame
K LAFRAM,X
D SEND(NAK)
Q
;
LA1INIT ; Init vars only for LAXSYM
S X="TRAP^"_LANM,@^%ZOSF("TRAP"),I=0,LANOCTL1=""
S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
F S I=$O(TC(I)) Q:'I I $G(TC(I,4)) S LATEST(TC(I,4),TC(I,0))=I
F I=1:1:31 S LANOCTL1=LANOCTL1_$C(I) ; ctl chars
Q
;
; Continuation of LAPORT33 (LANM) due to size req'mts /mld
INIT ; initialize various parameters for the AxSYM
;
S (HOME,T,TSK,INST)=+$E(LANM,7,8),LANOCTL1=""
S X="TRAP^"_LANM,@^%ZOSF("TRAP"),DUZ=.5,LANOCTL2=""
S DEB="D"_INST,OUT="",BASE=0,OK=0
S TOUT=5,U="^",(LADEV,IOP)=$G(^LAB(62.4,INST,.75))
I $D(^LA(INST,"R")) D Q:$D(^LA(INST,"R"))
.S LRCHK=^LA(INST,"R") H 35 S LRCHK1=^LA(INST,"R") D
..I LRCHK'=LRCHK1 S ^LA(INST,"ERR",$H)="LAPORT"_INST_" is already running ...aborted" K LRCHK,LRCHK1 Q
..I LRCHK=LRCHK1 K LRCHK,LRCHK1,^LA(INST,"R"),^LA("LOCK","D"_INST) Q
;
H 1 ; allows calling routine to close port before opening again
I LADEV="" D Q
.S ^LA(INST,"ERR",$H)="DIRECT DEVICE field is empty! aborted"
ZIS D ^%ZIS I POP D Q
.S ^LA(INST,"ERR",$H)=LADEV_" was busy .... aborted"
;
; set READ timeout, terminating chars, max character count
S NUL=0,SOH=1,STX=2,ETX=3,EOT=4,ENQ=5,ACK=6,NAK=21,ETB=23,LF=10,CR=13
S (CNT,LARETRY,LAFRNM)=0,LATOUT=75,DEBUG=0,OK=1
S LACRLF=$C(CR)_$C(LF),LACRETX=$C(CR)_$C(ETX)
F I=3,13,23 S LANOCTL1=LANOCTL1_$C(I) ; to remove ctl chars from LAFRAM
; LANOCTL2=restricted chars - 3,4,13,23 (ETX,EOT,CR,ETB) are OK
F I=1,2,5:1:12,14:1:22,24:1:31 S LANOCTL2=LANOCTL2_$C(I)
; start fresh
K ^LA(INST,"ERR"),^LA(INST,"ERX")
I $D(^LA(DEB,0)) K ^LA(DEB) S ^LA(DEB,0)=0 ;clean out debug node
S ^LA(INST,"R")=$H,^LA("LOCK","D"_INST)=$J ; running flag
Q
;
BKGND ; Entry point to start ANY bi-directional background job /mld
N DIC,DIR,DIRUT,LRDASH,LRJOB,LRJOBIO,LRJOBN,LRJOBNM,T,X,Y,ZTSK
S IOP=0 D ^%ZIS
S $P(LRDASH,"-",IOM)=""
S DIC=62.4,DIC(0)="AEMQ",DIC("S")="I Y<99,$G(^(.75))]""""" D ^DIC K DIC
I Y<1 W !,"NO JOB SELECTED",! H 1 QUIT
S LRJOBN=+Y,LRJOBNM=$P(Y,"^",2),LRJOB="LAPORT"_LRJOBN
S (LRJOBIO,X)=$G(^LAB(62.4,LRJOBN,.75)) ; direct device field
S IOP=X,%ZIS="" D ^%ZIS
I POP D H 1 QUIT
.D HOME^%ZIS
.W !!,?3,$C(7),"Unable to open ",LRJOBIO," for instrument ",LRJOBNM,"."
.W !,?3,"This would indicate that the interface is already running.",!
D ^%ZISC
W !!
S DIR(0)="Y0",DIR("A")="Start the direct connect "_LRJOBNM_" interface now",DIR("B")="NO"
D ^DIR K DIR Q:Y'=1
S ZTRTN=LRJOB,ZTIO=LRJOBIO,ZTDTH=$H,ZTDESC="Lab Direct Connect Port"_LRJOBN
K ^LA("LOCK","D"_LRJOBN)
D ^%ZTLOAD
W !,"Lab Direct Connect Interface for ",LRJOBNM,$S($D(ZTSK):"",1:" NOT")," tasked to start",!
I $G(ZTSK) W "Task #",ZTSK,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAXSYMU 4487 printed Apr 09, 2024@20:46:06 Page 2
LAXSYMU ;MLD/ABBOTT/SLC/RAF - AxSYM INTERFACE Utility Routine; 6/12/96 0900
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
+2 ;
+3 ; This routine serves as general UTILITY routine for the AxSYM
+4 ; interface. While not as efficient as all code being in ONE
+5 ; routine, portability requirements must be met. /mld
+6 ;
+7 ; call line tag
QUIT
+8 ;
UPDT ; To LA global ($TR used to remove CTRL chars from LAFRAM)
+1 LOCK +^LA(INST,"I")
+2 ; runs LAXSYM (LA->LAH)
IF '$DATA(^LA(INST,"I"))
XECUTE $GET(^LAB(62.4,INST,1))
+3 if '$DATA(^LA(INST,"I"))#2
SET ^LA(INST,"I")=0
SET ^("I",0)=0
+4 SET CNT=$GET(^LA(INST,"I"))+1
SET ^("I")=CNT
SET ^("I",CNT)=$TRANSLATE(LAFRAM,LANOCTL1)
+5 KILL LAFRAM,X
+6 SET LAFRAME=""
SET LARETRY=0
SET LALINK=0
+7 LOCK -^LA(INST,"I")
+8 QUIT
+9 ;
CKSUM(S,MOD) ; convert string (S) to decimal num (N) then to
+1 ; hex modulo 16**MOD (def=2=256)
+2 NEW I,HX,HXN,DIV,N
SET N=0
SET DIV=1
if '$DATA(MOD)
SET MOD=2
+3 ; get ASCII chars in string S
FOR I=1:1:$LENGTH(S)
SET N=N+$ASCII(S,I)
+4 ; get MOD value (def=16*16)
FOR I=1:1:MOD
SET DIV=16*DIV
+5 SET HX=N#DIV
SET N=""
+6 FOR
if HX=0
QUIT
SET HXN=HX#16
SET HX=HX\16
SET N=$SELECT(HXN>9:$EXTRACT("ABCDEF",HXN#10+1),1:HXN)_N
+7 SET N="00000000"_N
SET N=$EXTRACT(N,$LENGTH(N)-MOD+1,$LENGTH(N))
+8 QUIT N
+9 ;
SEND(N) ; Send reply msg (ACK, NAK, etc.)
+1 WRITE $CHAR(N)
+2 if DEBUG
DO DEBG(N,"O")
+3 QUIT
+4 ;
DEBG(A,B) ; DEBuG tool - capture all data going in & out. (Def=OFF)
+1 ; A=data that went out/came in B="I"=IN; "O"=OUT
+2 NEW MSG,CT
+3 SET MSG=$SELECT(B="I":"IN: ",1:"OUT: ")_A_" %^% "_$HOROLOG
+4 SET (CT,^LA(DEB,0))=$GET(^LA(DEB,0))+1
SET ^LA(DEB,CT)=MSG
+5 QUIT
+6 ;
NAK(M) ; send NAK and retry (M = error 'type', EOT, STX, etc.)
+1 ; capture
SET ^LA(INST,"ERR",$HOROLOG,M)=LAFRAME
+2 ; increment # retries
SET LAFRAME=""
SET LARETRY=LARETRY+1
+3 ; too many NAK's - goto idle
IF LARETRY=7
DO SEND(EOT)
DO @("SET^"_LANM)
QUIT
+4 ; LALINK=1 on 1ST frame
IF 'LALINK
SET LAFRNM=$SELECT(LAFRNM:LAFRNM-1,1:7)
+5 KILL LAFRAM,X
+6 DO SEND(NAK)
+7 QUIT
+8 ;
LA1INIT ; Init vars only for LAXSYM
+1 SET X="TRAP^"_LANM
SET @^%ZOSF("TRAP")
SET I=0
SET LANOCTL1=""
+2 SET ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+3 FOR
SET I=$ORDER(TC(I))
if 'I
QUIT
IF $GET(TC(I,4))
SET LATEST(TC(I,4),TC(I,0))=I
+4 ; ctl chars
FOR I=1:1:31
SET LANOCTL1=LANOCTL1_$CHAR(I)
+5 QUIT
+6 ;
+7 ; Continuation of LAPORT33 (LANM) due to size req'mts /mld
INIT ; initialize various parameters for the AxSYM
+1 ;
+2 SET (HOME,T,TSK,INST)=+$EXTRACT(LANM,7,8)
SET LANOCTL1=""
+3 SET X="TRAP^"_LANM
SET @^%ZOSF("TRAP")
SET DUZ=.5
SET LANOCTL2=""
+4 SET DEB="D"_INST
SET OUT=""
SET BASE=0
SET OK=0
+5 SET TOUT=5
SET U="^"
SET (LADEV,IOP)=$GET(^LAB(62.4,INST,.75))
+6 IF $DATA(^LA(INST,"R"))
Begin DoDot:1
+7 SET LRCHK=^LA(INST,"R")
HANG 35
SET LRCHK1=^LA(INST,"R")
Begin DoDot:2
+8 IF LRCHK'=LRCHK1
SET ^LA(INST,"ERR",$HOROLOG)="LAPORT"_INST_" is already running ...aborted"
KILL LRCHK,LRCHK1
QUIT
+9 IF LRCHK=LRCHK1
KILL LRCHK,LRCHK1,^LA(INST,"R"),^LA("LOCK","D"_INST)
QUIT
End DoDot:2
End DoDot:1
if $DATA(^LA(INST,"R"))
QUIT
+10 ;
+11 ; allows calling routine to close port before opening again
HANG 1
+12 IF LADEV=""
Begin DoDot:1
+13 SET ^LA(INST,"ERR",$HOROLOG)="DIRECT DEVICE field is empty! aborted"
End DoDot:1
QUIT
ZIS DO ^%ZIS
IF POP
Begin DoDot:1
+1 SET ^LA(INST,"ERR",$HOROLOG)=LADEV_" was busy .... aborted"
End DoDot:1
QUIT
+2 ;
+3 ; set READ timeout, terminating chars, max character count
+4 SET NUL=0
SET SOH=1
SET STX=2
SET ETX=3
SET EOT=4
SET ENQ=5
SET ACK=6
SET NAK=21
SET ETB=23
SET LF=10
SET CR=13
+5 SET (CNT,LARETRY,LAFRNM)=0
SET LATOUT=75
SET DEBUG=0
SET OK=1
+6 SET LACRLF=$CHAR(CR)_$CHAR(LF)
SET LACRETX=$CHAR(CR)_$CHAR(ETX)
+7 ; to remove ctl chars from LAFRAM
FOR I=3,13,23
SET LANOCTL1=LANOCTL1_$CHAR(I)
+8 ; LANOCTL2=restricted chars - 3,4,13,23 (ETX,EOT,CR,ETB) are OK
+9 FOR I=1,2,5:1:12,14:1:22,24:1:31
SET LANOCTL2=LANOCTL2_$CHAR(I)
+10 ; start fresh
+11 KILL ^LA(INST,"ERR"),^LA(INST,"ERX")
+12 ;clean out debug node
IF $DATA(^LA(DEB,0))
KILL ^LA(DEB)
SET ^LA(DEB,0)=0
+13 ; running flag
SET ^LA(INST,"R")=$HOROLOG
SET ^LA("LOCK","D"_INST)=$JOB
+14 QUIT
+15 ;
BKGND ; Entry point to start ANY bi-directional background job /mld
+1 NEW DIC,DIR,DIRUT,LRDASH,LRJOB,LRJOBIO,LRJOBN,LRJOBNM,T,X,Y,ZTSK
+2 SET IOP=0
DO ^%ZIS
+3 SET $PIECE(LRDASH,"-",IOM)=""
+4 SET DIC=62.4
SET DIC(0)="AEMQ"
SET DIC("S")="I Y<99,$G(^(.75))]"""""
DO ^DIC
KILL DIC
+5 IF Y<1
WRITE !,"NO JOB SELECTED",!
HANG 1
QUIT
+6 SET LRJOBN=+Y
SET LRJOBNM=$PIECE(Y,"^",2)
SET LRJOB="LAPORT"_LRJOBN
+7 ; direct device field
SET (LRJOBIO,X)=$GET(^LAB(62.4,LRJOBN,.75))
+8 SET IOP=X
SET %ZIS=""
DO ^%ZIS
+9 IF POP
Begin DoDot:1
+10 DO HOME^%ZIS
+11 WRITE !!,?3,$CHAR(7),"Unable to open ",LRJOBIO," for instrument ",LRJOBNM,"."
+12 WRITE !,?3,"This would indicate that the interface is already running.",!
End DoDot:1
HANG 1
QUIT
+13 DO ^%ZISC
+14 WRITE !!
+15 SET DIR(0)="Y0"
SET DIR("A")="Start the direct connect "_LRJOBNM_" interface now"
SET DIR("B")="NO"
+16 DO ^DIR
KILL DIR
if Y'=1
QUIT
+17 SET ZTRTN=LRJOB
SET ZTIO=LRJOBIO
SET ZTDTH=$HOROLOG
SET ZTDESC="Lab Direct Connect Port"_LRJOBN
+18 KILL ^LA("LOCK","D"_LRJOBN)
+19 DO ^%ZTLOAD
+20 WRITE !,"Lab Direct Connect Interface for ",LRJOBNM,$SELECT($DATA(ZTSK):"",1:" NOT")," tasked to start",!
+21 IF $GET(ZTSK)
WRITE "Task #",ZTSK,!
+22 QUIT
