LADKERM2 ;SLC/RWF/DLG - BUILD A KERMIT FILE TO SEND ;2/8/90 14:50 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
;Call with X=data, LAKTYPE=record type, TSK=instrument #
;Files the records in ^LA(TSK,"O",n)
Q
L1 S:'$D(LAKRM) LAKRM=94,LAKSEQ=0 S:LAKTYPE="S" LAKSEQ=0
I LAKTYPE'="S" D POUND:X["#",QCTRL:X?.E1C.E
F IX2=0:0 D L2 Q:X']""
Q
L2 S LAKSPK=$C(LAKSEQ+32)_LAKTYPE_$E(X,1,+LAKRM),X=$E(X,LAKRM+1,299)
D SPACK^LADKERMI S LAKSEQ=LAKSEQ+1#64
L ^LA(TSK) S O=^LA(TSK,"O")+1,^("O")=O,^("O",O)=LAKSPK L
Q
POUND F I=2:1 S I=$F(X,"#",I) Q:I<1 S X=$E(X,1,I-2)_"#"_$E(X,I-1,999)
Q
QCTRL F I=2:1 Q:I>$L(X) I $A(X,I)<32 S X=$E(X,1,I-1)_"#"_$C($A(X,I)+32)_$E(X,I+1,999)
Q
START ;A call is made to here once to do setup.
S LAKTYPE="S",X="~} @-#N1" D L1
Q
END ;At the end of data a call is made to here.
S LAKTYPE="Z",X="" D L1 S LAKTYPE="B",X="" D L1,SEND L G QUIT
Q
SEND L ^LA(TSK,"P") Q:$S($D(^LA(TSK,"P")):$P(^("P"),"^",2),1:"QUIT")'="QUIT" Q:^LA(TSK,"O")'>^LA(TSK,"O",0)
S ^LA(TSK,"P")="KERMIT^OUT",^("P3")=0,T=TSK L ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=T L
Q
DATA ;A call is made to here for each record in the load list.
S LAKTYPE="D" D L1 Q
Q
NEXT ;Finish old file start new.
I LAKTYPE'="S" S LAKTYPE="Z" D L1
S LAKTYPE="F",X="S "_LRFILE D L1
Q
QUIT K C,CHKSUM,LAKRM,LAKSEQ,LAKSPK,LAKTYPE,X,O
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLADKERM2 1361 printed Dec 13, 2024@01:42:10 Page 2
LADKERM2 ;SLC/RWF/DLG - BUILD A KERMIT FILE TO SEND ;2/8/90 14:50 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
+2 ;Call with X=data, LAKTYPE=record type, TSK=instrument #
+3 ;Files the records in ^LA(TSK,"O",n)
+4 QUIT
L1 if '$DATA(LAKRM)
SET LAKRM=94
SET LAKSEQ=0
if LAKTYPE="S"
SET LAKSEQ=0
+1 IF LAKTYPE'="S"
if X["#"
DO POUND
if X?.E1C.E
DO QCTRL
+2 FOR IX2=0:0
DO L2
if X']""
QUIT
+3 QUIT
L2 SET LAKSPK=$CHAR(LAKSEQ+32)_LAKTYPE_$EXTRACT(X,1,+LAKRM)
SET X=$EXTRACT(X,LAKRM+1,299)
+1 DO SPACK^LADKERMI
SET LAKSEQ=LAKSEQ+1#64
+2 LOCK ^LA(TSK)
SET O=^LA(TSK,"O")+1
SET ^("O")=O
SET ^("O",O)=LAKSPK
LOCK
+3 QUIT
POUND FOR I=2:1
SET I=$FIND(X,"#",I)
if I<1
QUIT
SET X=$EXTRACT(X,1,I-2)_"#"_$EXTRACT(X,I-1,999)
+1 QUIT
QCTRL FOR I=2:1
if I>$LENGTH(X)
QUIT
IF $ASCII(X,I)<32
SET X=$EXTRACT(X,1,I-1)_"#"_$CHAR($ASCII(X,I)+32)_$EXTRACT(X,I+1,999)
+1 QUIT
START ;A call is made to here once to do setup.
+1 SET LAKTYPE="S"
SET X="~} @-#N1"
DO L1
+2 QUIT
END ;At the end of data a call is made to here.
+1 SET LAKTYPE="Z"
SET X=""
DO L1
SET LAKTYPE="B"
SET X=""
DO L1
DO SEND
LOCK
GOTO QUIT
+2 QUIT
SEND LOCK ^LA(TSK,"P")
if $SELECT($DATA(^LA(TSK,"P"))
QUIT
if ^LA(TSK,"O")'>^LA(TSK,"O",0)
QUIT
+1 SET ^LA(TSK,"P")="KERMIT^OUT"
SET ^("P3")=0
SET T=TSK
LOCK ^LA("Q")
SET Q=^LA("Q")+1
SET ^("Q")=Q
SET ^("Q",Q)=T
LOCK
+2 QUIT
DATA ;A call is made to here for each record in the load list.
+1 SET LAKTYPE="D"
DO L1
QUIT
+2 QUIT
NEXT ;Finish old file start new.
+1 IF LAKTYPE'="S"
SET LAKTYPE="Z"
DO L1
+2 SET LAKTYPE="F"
SET X="S "_LRFILE
DO L1
+3 QUIT
QUIT KILL C,CHKSUM,LAKRM,LAKSEQ,LAKSPK,LAKTYPE,X,O
+1 QUIT
