source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LAXSYMU.m@ 1470

Last change on this file since 1470 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1LAXSYMU ;MLD/ABBOTT/SLC/RAF - AxSYM INTERFACE Utility Routine; 6/12/96 0900
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**11,19**;Sep 27, 1994
3 ;
4 ; This routine serves as general UTILITY routine for the AxSYM
5 ; interface. While not as efficient as all code being in ONE
6 ; routine, portability requirements must be met. /mld
7 ;
8 Q ; call line tag
9 ;
10UPDT ; To LA global ($TR used to remove CTRL chars from LAFRAM)
11 L +^LA(INST,"I")
12 I '$D(^LA(INST,"I")) X $G(^LAB(62.4,INST,1)) ; runs LAXSYM (LA->LAH)
13 S:'$D(^LA(INST,"I"))#2 ^LA(INST,"I")=0,^("I",0)=0
14 S CNT=$G(^LA(INST,"I"))+1,^("I")=CNT,^("I",CNT)=$TR(LAFRAM,LANOCTL1)
15 K LAFRAM,X
16 S LAFRAME="",LARETRY=0,LALINK=0
17 L -^LA(INST,"I")
18 Q
19 ;
20CKSUM(S,MOD) ; convert string (S) to decimal num (N) then to
21 ; hex modulo 16**MOD (def=2=256)
22 N I,HX,HXN,DIV,N S N=0,DIV=1 S:'$D(MOD) MOD=2
23 F I=1:1:$L(S) S N=N+$A(S,I) ; get ASCII chars in string S
24 F I=1:1:MOD S DIV=16*DIV ; get MOD value (def=16*16)
25 S HX=N#DIV,N=""
26 F Q:HX=0 S HXN=HX#16,HX=HX\16,N=$S(HXN>9:$E("ABCDEF",HXN#10+1),1:HXN)_N
27 S N="00000000"_N,N=$E(N,$L(N)-MOD+1,$L(N))
28 Q N
29 ;
30SEND(N) ; Send reply msg (ACK, NAK, etc.)
31 W $C(N)
32 D:DEBUG DEBG(N,"O")
33 Q
34 ;
35DEBG(A,B) ; DEBuG tool - capture all data going in & out. (Def=OFF)
36 ; A=data that went out/came in B="I"=IN; "O"=OUT
37 N MSG,CT
38 S MSG=$S(B="I":"IN: ",1:"OUT: ")_A_" %^% "_$H
39 S (CT,^LA(DEB,0))=$G(^LA(DEB,0))+1,^LA(DEB,CT)=MSG
40 Q
41 ;
42NAK(M) ; send NAK and retry (M = error 'type', EOT, STX, etc.)
43 S ^LA(INST,"ERR",$H,M)=LAFRAME ; capture
44 S LAFRAME="",LARETRY=LARETRY+1 ; increment # retries
45 I LARETRY=7 D SEND(EOT),@("SET^"_LANM) Q ; too many NAK's - goto idle
46 I 'LALINK S LAFRNM=$S(LAFRNM:LAFRNM-1,1:7) ; LALINK=1 on 1ST frame
47 K LAFRAM,X
48 D SEND(NAK)
49 Q
50 ;
51LA1INIT ; Init vars only for LAXSYM
52 S X="TRAP^"_LANM,@^%ZOSF("TRAP"),I=0,LANOCTL1=""
53 S ALPHA="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
54 F S I=$O(TC(I)) Q:'I I $G(TC(I,4)) S LATEST(TC(I,4),TC(I,0))=I
55 F I=1:1:31 S LANOCTL1=LANOCTL1_$C(I) ; ctl chars
56 Q
57 ;
58 ; Continuation of LAPORT33 (LANM) due to size req'mts /mld
59INIT ; initialize various parameters for the AxSYM
60 ;
61 S (HOME,T,TSK,INST)=+$E(LANM,7,8),LANOCTL1=""
62 S X="TRAP^"_LANM,@^%ZOSF("TRAP"),DUZ=.5,LANOCTL2=""
63 S DEB="D"_INST,OUT="",BASE=0,OK=0
64 S TOUT=5,U="^",(LADEV,IOP)=$G(^LAB(62.4,INST,.75))
65 I $D(^LA(INST,"R")) D Q:$D(^LA(INST,"R"))
66 .S LRCHK=^LA(INST,"R") H 35 S LRCHK1=^LA(INST,"R") D
67 ..I LRCHK'=LRCHK1 S ^LA(INST,"ERR",$H)="LAPORT"_INST_" is already running ...aborted" K LRCHK,LRCHK1 Q
68 ..I LRCHK=LRCHK1 K LRCHK,LRCHK1,^LA(INST,"R"),^LA("LOCK","D"_INST) Q
69 ;
70 H 1 ; allows calling routine to close port before opening again
71 I LADEV="" D Q
72 .S ^LA(INST,"ERR",$H)="DIRECT DEVICE field is empty! aborted"
73ZIS D ^%ZIS I POP D Q
74 .S ^LA(INST,"ERR",$H)=LADEV_" was busy .... aborted"
75 ;
76 ; set READ timeout, terminating chars, max character count
77 S NUL=0,SOH=1,STX=2,ETX=3,EOT=4,ENQ=5,ACK=6,NAK=21,ETB=23,LF=10,CR=13
78 S (CNT,LARETRY,LAFRNM)=0,LATOUT=75,DEBUG=0,OK=1
79 S LACRLF=$C(CR)_$C(LF),LACRETX=$C(CR)_$C(ETX)
80 F I=3,13,23 S LANOCTL1=LANOCTL1_$C(I) ; to remove ctl chars from LAFRAM
81 ; LANOCTL2=restricted chars - 3,4,13,23 (ETX,EOT,CR,ETB) are OK
82 F I=1,2,5:1:12,14:1:22,24:1:31 S LANOCTL2=LANOCTL2_$C(I)
83 ; start fresh
84 K ^LA(INST,"ERR"),^LA(INST,"ERX")
85 I $D(^LA(DEB,0)) K ^LA(DEB) S ^LA(DEB,0)=0 ;clean out debug node
86 S ^LA(INST,"R")=$H,^LA("LOCK","D"_INST)=$J ; running flag
87 Q
88 ;
89BKGND ; Entry point to start ANY bi-directional background job /mld
90 N DIC,DIR,DIRUT,LRDASH,LRJOB,LRJOBIO,LRJOBN,LRJOBNM,T,X,Y,ZTSK
91 S IOP=0 D ^%ZIS
92 S $P(LRDASH,"-",IOM)=""
93 S DIC=62.4,DIC(0)="AEMQ",DIC("S")="I Y<99,$G(^(.75))]""""" D ^DIC K DIC
94 I Y<1 W !,"NO JOB SELECTED",! H 1 QUIT
95 S LRJOBN=+Y,LRJOBNM=$P(Y,"^",2),LRJOB="LAPORT"_LRJOBN
96 S (LRJOBIO,X)=$G(^LAB(62.4,LRJOBN,.75)) ; direct device field
97 S IOP=X,%ZIS="" D ^%ZIS
98 I POP D H 1 QUIT
99 .D HOME^%ZIS
100 .W !!,?3,$C(7),"Unable to open ",LRJOBIO," for instrument ",LRJOBNM,"."
101 .W !,?3,"This would indicate that the interface is already running.",!
102 D ^%ZISC
103 W !!
104 S DIR(0)="Y0",DIR("A")="Start the direct connect "_LRJOBNM_" interface now",DIR("B")="NO"
105 D ^DIR K DIR Q:Y'=1
106 S ZTRTN=LRJOB,ZTIO=LRJOBIO,ZTDTH=$H,ZTDESC="Lab Direct Connect Port"_LRJOBN
107 K ^LA("LOCK","D"_LRJOBN)
108 D ^%ZTLOAD
109 W !,"Lab Direct Connect Interface for ",LRJOBNM,$S($D(ZTSK):"",1:" NOT")," tasked to start",!
110 I $G(ZTSK) W "Task #",ZTSK,!
111 Q
Note: See TracBrowser for help on using the repository browser.