- LAMSA ; IHS/DIR/FJE - MICROSCAN AND AUTOSCAN4 DATA ANALYZER 8/16/90 13:35 ;
- ;;5.2;LA;;NOV 01, 1997
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- ;CROSS LINK BY ID OR IDE
- LA1 S:$D(ZTQUEUED) ZTREQ="@" S LANM=$T(+0),TSK=$O(^LAB(62.4,"C",LANM,0)) Q:TSK<1
- Q:'$D(^LA(TSK,"I",0))
- K LATOP D ^LASET Q:'TSK S LROVER=1,X="TRAP^"_LANM,@^%ZOSF("TRAP"),FD="|"
- LA2 S TOUT=0,A=1 D IN G QUIT:TOUT,LA2:$E(IN)'="P" D QC
- K ORG,COMM,COMMO,LADGT,LABLI,LASPEC S (COMM,COMMO,LADRUG,LAISO,LAORG,LADNA,LAMIC,LMDR)=0,LRM=1
- S TOUT=0,BAD=0 F A=2:1 D IN,QC G LA3:TYPE="L",QUIT:TOUT
- Q
- LA3 G LA2:'$D(ORG) X LAGEN G LA2:'ISQN ;Can be changed by the cross-link code
- S LRA=$P(^LAH(LWL,1,ISQN,0),U,3,5),LRAA=+LRA,LRAD=$P(LRA,U,2)
- F I=0:0 S I=$O(ORG(I)) Q:I'>0 S I1=I,X=ORG(I) S ^LAH(LWL,1,ISQN,3,I1,0)=ORG(I) D LA4 I COMMO F J=1:1:COMMO S:$D(COMM(I1,1,J))#2 ^LAH(LWL,1,ISQN,3,I1,1,J,0)=COMM(I1,1,J)
- I COMM F I=1:1:COMM S ^LAH(LWL,1,ISQN,4,I,0)=COMM("C",I)
- G LA2
- LA4 F J=0:0 S J=$O(ORG(I,J)) Q:J'>0 S ^LAH(LWL,1,ISQN,3,I1,J)=ORG(I,J)
- Q
- QC ;QC and data record processing here
- S TYPE=" " Q:"BC"[CTRL S TYPE=$E(IN) Q:TYPE']"" I "PBRMLFC"'[TYPE Q ;These are the record types we handle
- D @TYPE Q
- P S V=$P(IN,FD,3) D NUM S LAPID=V Q
- B S V=$P(IN,FD,3) D NUM S (CUP,IDE)=V,LRSP=$S($P(IN,FD,7):$P(IN,FD,7),1:"ANY"),LASPEC=$P(IN,FD,9) Q ;Could change LRAA here
- R S LAISO=+$P(IN,FD,3),LATPN=+$P(IN,FD,5),LANOS=$P(IN,FD,9),LAORG=$P(IN,FD,12),LANORG=$P(IN,FD,13),LANYD=$P(IN,FD,23)
- S X=$O(^LAB(62.4,TSK,7,LRM,1,"C",LAORG,0)),LAORG=0 Q:X'>0 S LAORG=+^LAB(62.4,TSK,7,LRM,1,X,0),ORG(LAISO)=LAORG
- Q
- M Q:$D(ORG(LAISO))'>0 S LADNA=$P(IN,FD,3),LAMIC=$P(IN,FD,5),LANCCLS=$P(IN,FD,8)
- F I=1:1:25 S Y(I)=$P(IN,FD,I)
- D M^LAMSA1 Q
- F S X=$P(IN,FD,4) I X]"" S:"PB"[$P(IN,FD,3) COMM=COMM+1,COMM("C",COMM)=X S:$P(IN,FD,3)="R" COMMO=COMMO+1,COMM(LAISO,1,COMMO)=X,X=""
- Q
- C S COMM=COMM+1,COMM("C",COMM)=$P(IN,FD,5) Q
- Q
- L S END=$P(IN,FD,3) Q
- NUM S X="" F JJ=1:1:$L(V) S:$A(V,JJ)>32 X=X_$E(V,JJ)
- S V=X Q
- IN S CNT=^LA(TSK,"I",0)+1,CTRL="<" IF '$D(^(CNT)) S TOUT=TOUT+1 Q:TOUT>9 H 5 G IN
- S ^LA(TSK,"I",0)=CNT,IN=^(CNT),TOUT=0
- S:IN["~" CTRL=$P(IN,"~",2),IN=$P(IN,"~",1)
- Q
- OUT S CNT=^LA(TSK,"O")+1,^("O")=CNT,^("O",CNT)=OUT
- LOCK ^LA("Q") S Q=^LA("Q")+1,^("Q")=Q,^("Q",Q)=TSK LOCK
- Q
- QUIT G LA2:^LA(TSK,"I")>^("I",0) LOCK ^LA(TSK) H 1 K ^LA(TSK,"I"),^LA("LOCK",TSK)
- I $D(^LA(TSK,"O")),^("O")=^("O",0) K ^LA(TSK,"O")
- LOCK K ^TMP($J),^TMP("LA",$J)
- Q
- TRAP D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM)
- LAMSA ; IHS/DIR/FJE - MICROSCAN AND AUTOSCAN4 DATA ANALYZER 8/16/90 13:35 ;
- +1 ;;5.2;LA;;NOV 01, 1997
- +2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +3 ;CROSS LINK BY ID OR IDE
- LA1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- SET LANM=$TEXT(+0)
- SET TSK=$ORDER(^LAB(62.4,"C",LANM,0))
- IF TSK<1
- QUIT
- +1 IF '$DATA(^LA(TSK,"I",0))
- QUIT
- +2 KILL LATOP
- DO ^LASET
- IF 'TSK
- QUIT
- SET LROVER=1
- SET X="TRAP^"_LANM
- SET @^%ZOSF("TRAP")
- SET FD="|"
- LA2 SET TOUT=0
- SET A=1
- DO IN
- IF TOUT
- GOTO QUIT
- IF $EXTRACT(IN)'="P"
- GOTO LA2
- DO QC
- +1 KILL ORG,COMM,COMMO,LADGT,LABLI,LASPEC
- SET (COMM,COMMO,LADRUG,LAISO,LAORG,LADNA,LAMIC,LMDR)=0
- SET LRM=1
- +2 SET TOUT=0
- SET BAD=0
- FOR A=2:1
- DO IN
- DO QC
- IF TYPE="L"
- GOTO LA3
- IF TOUT
- GOTO QUIT
- +3 QUIT
- LA3 ;Can be changed by the cross-link code
- IF '$DATA(ORG)
- GOTO LA2
- XECUTE LAGEN
- IF 'ISQN
- GOTO LA2
- +1 SET LRA=$PIECE(^LAH(LWL,1,ISQN,0),U,3,5)
- SET LRAA=+LRA
- SET LRAD=$PIECE(LRA,U,2)
- +2 FOR I=0:0
- SET I=$ORDER(ORG(I))
- IF I'>0
- QUIT
- SET I1=I
- SET X=ORG(I)
- SET ^LAH(LWL,1,ISQN,3,I1,0)=ORG(I)
- DO LA4
- IF COMMO
- FOR J=1:1:COMMO
- IF $DATA(COMM(I1,1,J))#2
- SET ^LAH(LWL,1,ISQN,3,I1,1,J,0)=COMM(I1,1,J)
- +3 IF COMM
- FOR I=1:1:COMM
- SET ^LAH(LWL,1,ISQN,4,I,0)=COMM("C",I)
- +4 GOTO LA2
- LA4 FOR J=0:0
- SET J=$ORDER(ORG(I,J))
- IF J'>0
- QUIT
- SET ^LAH(LWL,1,ISQN,3,I1,J)=ORG(I,J)
- +1 QUIT
- QC ;QC and data record processing here
- +1 ;These are the record types we handle
- SET TYPE=" "
- IF "BC"[CTRL
- QUIT
- SET TYPE=$EXTRACT(IN)
- IF TYPE']""
- QUIT
- IF "PBRMLFC"'[TYPE
- QUIT
- +2 DO @TYPE
- QUIT
- P SET V=$PIECE(IN,FD,3)
- DO NUM
- SET LAPID=V
- QUIT
- B ;Could change LRAA here
- SET V=$PIECE(IN,FD,3)
- DO NUM
- SET (CUP,IDE)=V
- SET LRSP=$SELECT($PIECE(IN,FD,7):$PIECE(IN,FD,7),1:"ANY")
- SET LASPEC=$PIECE(IN,FD,9)
- QUIT
- R SET LAISO=+$PIECE(IN,FD,3)
- SET LATPN=+$PIECE(IN,FD,5)
- SET LANOS=$PIECE(IN,FD,9)
- SET LAORG=$PIECE(IN,FD,12)
- SET LANORG=$PIECE(IN,FD,13)
- SET LANYD=$PIECE(IN,FD,23)
- +1 SET X=$ORDER(^LAB(62.4,TSK,7,LRM,1,"C",LAORG,0))
- SET LAORG=0
- IF X'>0
- QUIT
- SET LAORG=+^LAB(62.4,TSK,7,LRM,1,X,0)
- SET ORG(LAISO)=LAORG
- +2 QUIT
- M IF $DATA(ORG(LAISO))'>0
- QUIT
- SET LADNA=$PIECE(IN,FD,3)
- SET LAMIC=$PIECE(IN,FD,5)
- SET LANCCLS=$PIECE(IN,FD,8)
- +1 FOR I=1:1:25
- SET Y(I)=$PIECE(IN,FD,I)
- +2 DO M^LAMSA1
- QUIT
- F SET X=$PIECE(IN,FD,4)
- IF X]""
- IF "PB"[$PIECE(IN,FD,3)
- SET COMM=COMM+1
- SET COMM("C",COMM)=X
- IF $PIECE(IN,FD,3)="R"
- SET COMMO=COMMO+1
- SET COMM(LAISO,1,COMMO)=X
- SET X=""
- +1 QUIT
- C SET COMM=COMM+1
- SET COMM("C",COMM)=$PIECE(IN,FD,5)
- QUIT
- +1 QUIT
- L SET END=$PIECE(IN,FD,3)
- QUIT
- NUM SET X=""
- FOR JJ=1:1:$LENGTH(V)
- IF $ASCII(V,JJ)>32
- SET X=X_$EXTRACT(V,JJ)
- +1 SET V=X
- QUIT
- IN SET CNT=^LA(TSK,"I",0)+1
- SET CTRL="<"
- IF '$DATA(^(CNT))
- SET TOUT=TOUT+1
- IF TOUT>9
- QUIT
- HANG 5
- GOTO IN
- +1 SET ^LA(TSK,"I",0)=CNT
- SET IN=^(CNT)
- SET TOUT=0
- +2 IF IN["~"
- SET CTRL=$PIECE(IN,"~",2)
- SET IN=$PIECE(IN,"~",1)
- +3 QUIT
- OUT SET CNT=^LA(TSK,"O")+1
- SET ^("O")=CNT
- SET ^("O",CNT)=OUT
- +1 LOCK ^LA("Q")
- SET Q=^LA("Q")+1
- SET ^("Q")=Q
- SET ^("Q",Q)=TSK
- LOCK
- +2 QUIT
- QUIT IF ^LA(TSK,"I")>^("I",0)
- GOTO LA2
- LOCK ^LA(TSK)
- HANG 1
- KILL ^LA(TSK,"I"),^LA("LOCK",TSK)
- +1 IF $DATA(^LA(TSK,"O"))
- IF ^("O")=^("O",0)
- KILL ^LA(TSK,"O")
- +2 LOCK
- KILL ^TMP($JOB),^TMP("LA",$JOB)
- +3 QUIT
- TRAP DO ^LABERR
- SET T=TSK
- DO SET^LAB
- GOTO @("LA2^"_LANM)
