- LABCX7XX ; IHS/DIR/FJE - BECKMAN BIDIRECTIONAL DIRECT CONNECT INTERFACE 8/16/90 14:53 COPY FOR INSTRUMENT #-- ; [ 05/14/1999 10:03 AM ]
- ;;5.2;LA;**1004**;MAY 14, 1999
- ;;5.1;LAB;;04/11/91 11:06
- 0 S LANM=$T(+0),(TSK,T)=+$E(LANM,7,8) Q:+T<1 Q:$D(^LA("LOCK",T)) S IOP=$P(^LAB(62.4,T,0),"^",2) G:IOP="" H^XUS D NOW^%DTC S DT=X K ^LA(T) D ^LABCX7I
- S X="ERR^ZU",@^%ZOSF("TRAP") ;*** JPC - MOVED HERE FROM LINE DQ (SO RESTART INSTRUMENT CAN BE USED, WHICH CALLS TOP OF ROUTINE)
- I $D(ZTSK) D KILL^%ZTLOAD K ZTSK ;*** JPC - ADDED IN CASE ITS TASKED
- LA2 K RES,TV,Y S A=1 G RD:OUT="" D:$D(^LA(DEB,0)) DBO
- I $A(OUT)<32 W OUT G RD
- I OUT["]" W OUT,! S OUT=$C(10) D:$D(^LA(DEB,0)) DBO G RD
- W OUT G TOUT
- RD S TOUT=5 S IN="",A=0 R *X:TOUT G:'$T TOUT D:$D(^LA(DEB,0)) DBX S IN=$C(X) D IN G RD1:IN="["
- I X=^LA(T,"P2") S ^("P2")=$S(X=ACK:ETX,1:ACK) ;,^LA(T,"P3")=^LA(T,"O",0)
- I X=ETX S ^LA(T,"P3")=^LA(T,"O",0)+1 G TOUT
- I X=ACK S ^LA(T,"P3")=^LA(T,"O",0)+1 G TOUT
- I X=LB S ^LA(T,"P")="IN",OUT=$C(ACK),^("P1")=ETX G LA2
- I X=LBO S OUT=$C(NAK) G LA2
- I X=EOT S ^LA(T,"P")="",(^("P1"),^("P2"))=ACK,OUT="" G LA2
- I X=ENQ G LA2
- I X=NAK D CHECK G W ; S ^LA(T,"O",0)=^LA(T,"P3") G W
- S OUT="" G LA2
- RD1 S TOUT=2,CK=X,FL=1,^LA(T,"P")="IN"
- RD2 F I=0:0 Q:$L(IN)=255 R *X:TOUT Q:('$T!(X=13)) S:FL CK=CK+X S IN=IN_$C(X) S:X=93 FL=0
- D:'$D(^LA(T,"I")) SET D IN,QC,DBI:$D(^LA(DEB,0)) S LN=$L(IN)
- I LN=255,(IN'["]") S IN="" G RD2
- I LN<255,(IN'["]") S OUT=$C(NAK) G LA2
- S OUT=$C(^LA(T,"P1")),^LA(T,"P1")=$S(^LA(T,"P1")=ACK:ETX,1:ACK)
- K TV S (TRAY,CUP,ID,IDE,RMK)="",ST=+$P(Y(1),",",2),FC=+$P(Y(1),",",3) G @ST
- 700 ;
- 703 I FC=4 S ^LAZ("ZZZ",T)=Y(1) G LA2
- 704 G LA2
- 701 G:FC#2 LA2 D:FC=2 RET D:FC=6 ^LABCX7R G:RC>0 LA2 W OUT D:$D(^LA(DEB,0)) DBO G TOUT
- 702 D HDR:FC=1,RES:FC=3,EOC:FC=5,RES2:FC=11,RES2:FC=13 ;*** JPC - 11,13
- G LA2
- W ;
- S OUT="",CNT=^LA(T,"O",0)+1 I $D(^(CNT)) S ^(0)=CNT,OUT=^(CNT)
- S:OUT=$C(4,1) ^LA(T,"P")="PEND" G LA2
- TOUT S %H=$H D YMD^%DTC S:LADT'=X LADT=X K %,%H
- I $D(^LA("STOP",T)) K ^LA("LOCK",T),^LA("STOP",T) H
- I $D(^LA(T,"O")),^LA(T,"O")>^LA(T,"O",0) G W
- I ^LA(T,"O")=^LA(T,"O",0) K ^LA(T,"O") S (^LA(T,"O"),^LA(T,"O",0))=0
- G RD
- QC S A=A+1,Y(A)=IN 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 Q:IN="[" L ^LA(T,"I") S (CNT,^LA(T,"I"),^LA(T,"I",0))=^LA(T,"I")+1,^LA(T,"I",CNT)=$S($L(IN)>1:IN,1:"~"_$C(X+64)) K:CNT>100 ^LA(T,"I",CNT-100) L Q
- DQ K ^LA("LOCK",$E($T(+0),7,8)),^LA("STOP",$E($T(+0),7,8)) G 0 ;*** JPC - KILL STOP NODE IN CASE IT WAS STOPPED WHEN NOT RUNNING
- SET S:'$D(^LA(T,"I"))#2 ^LA(T,"I")=0,^("I",0)=0
- SETO S:'$D(^LA(T,"O"))#2 ^LA(T,"O")=0,^("O",0)=0 Q
- TRAP Q ;D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM)
- DBO S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="OUT: "_$S($L(OUT)>2:$E(OUT,1,230),$L(OUT)=1:"~"_$C($A(OUT)+64),1:"~"_$C($A(OUT,1)+64)_"~"_$C($A(OUT,2)+64))_"%^%"_$H Q
- DBX Q:X=91 S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: "_$S(X>31:$C(X),1:"~"_$C(X+64))_"%^%"_$H Q
- DBI S (Q,^LA(DEB,0))=^LA(DEB,0)+1,^(Q)="IN: "_$E(IN,1,230)_"%^%"_$H Q
- HDR ;
- S TRAY=$P(Y(1),",",8) I $E(TRAY)=" " S TRAY=$E(TRAY,2)
- S CUP=$P(Y(1),",",9) I $E(CUP)=" " S CUP=$E(CUP,2)
- S ID=$E($P(Y(1),",",13),1,11),AA=$E(ID,1,3),AID=+$E(ID,8,11),AAN=0
- AAN S AAN=$O(^LRO(68,"B",AA,AAN)) I AAN I ^LRO(68,"B",AA,AAN)="" G AAN
- I AAN="" S ^LAZ("ZZZ",ID)="INVALID ACCESSION AREA" Q
- S LWL=$P(^LAB(62.4,T,0),U,4)
- ;FHL - Y2K 9/21/98 S D1=$P(Y(1),",",4),FDT=2_$E(D1,5,6)_$E(D1,3,4)_$E(D1,1,2)
- ;FHL - Y2K 9/21/98
- ;D1 appears to be in international format (DDMMYY)
- ;So with %DT="I" (international date format flag) ^%DT should
- ;convert D1 directly to fm formated date. ^%DT handles 2 digit
- ;years correctly until 2018.
- ;
- K %DT S D1=$P(Y(1),",",4),%DT="I",X=D1 D ^%DT S:Y'=-1 FDT=Y K %DT
- I Y=-1 S X="T" D ^%DT S FDT=Y
- L ^LAH(LWL) I $D(^LAH(LWL))#10=0 S ^LAH(LWL)=0
- SUB S (SUB,^LAH(LWL))=^LAH(LWL)+1 G:$D(^LAH(LWL,1,SUB)) SUB L
- S ^LAH(LWL,1,SUB,0)=TRAY_U_CUP_U_AAN_U_FDT_U_AID_"^^CX7"
- S ^LAH(LWL,1,"B",TRAY_";"_CUP,SUB)=""
- S ^LAH(LWL,1,"C",AID,SUB)=""
- Q
- RES ;
- S ID=$E($P(Y(1),",",10),1,11),AID=+$E(ID,8,11),AA=$E(ID,1,3),AAN=0
- AAN2 S AAN=$O(^LRO(68,"B",AA,AAN)) I AAN I ^LRO(68,"B",AA,AAN)="" G AAN2
- I AAN="" Q
- S LWL=$P(^LAB(62.4,T,0),U,4)
- S T1=$P($P(Y(1),",",11)," "),LO=0 F I=1:1 S LO=$O(^LAB(62.4,T,3,LO)) Q:LO="" Q:$P(^LAB(62.4,T,3,LO,0),U,6)=T1 ;**JPC - T1 CHANGE TO $P(... " ") TO ALLOW FOR 4 CHAR NAMES
- I '$D(SUB) S SUB=0 F S SUB=$O(^LAH(LWL,1,"C",AID,SUB)) Q:SUB="" S T0=$G(^LAH(LWL,1,SUB,0)) Q:$P(T0,U,3)=AAN ;**JPC - WITH MULT ACCN AREAS, NEED TO VERIFY CORRECT SUB
- Q:SUB=""
- I LO="" S ^LAZ("ZZZ",ID)=T1_" NOT IN THE AUTO INSTRUMENT FILE" Q ;JPC FIXED SPELLING OF INSTRUMENT
- S T2=$P($P(^LAB(62.4,T,3,LO,1),"(",2),",",1)
- S RES=$P(Y(1),",",16) F I=1:1:8 I $E(RES)=" " S RES=$E(RES,2,$L(RES))
- S ^LAH(LWL,1,SUB,T2)=RES
- Q
- EOC ;end of cup record, clean up LA(T,"I")
- I ^LA(T,"I")=^LA(T,"I",0) K ^LA(T,"I") S (^LA(T,"I"),^LA(T,"I",0))=0
- S ID=$E($P(Y(1),",",7),1,11) K ^LAZ(ID) Q
- ;
- RES2 ; *** JPC - ADDED RES2 TO PROCESS SPECIAL CALC AND TIMED URINE
- ; PARAM 3 IN AUTO INSTR SHOULD MATCH NAMES ON CX7
- Q:$P(Y(1),",",12)'="OK" ;check status--quit if not valid calc
- S ID=$E($P(Y(1),",",9),1,11),AID=+$E(ID,8,11),AA=$E(ID,1,3),AAN=0
- AAN21 S AAN=$O(^LRO(68,"B",AA,AAN)) I AAN I ^LRO(68,"B",AA,AAN)="" G AAN21
- I AAN="" Q
- S LWL=$P(^LAB(62.4,T,0),U,4)
- S T1=$P(Y(1),",",11),LO=0 F I=20:-1:2 Q:$E(T1,I)'=" " S T1=$E(T1,1,I-1)
- F I=1:1 S LO=$O(^LAB(62.4,T,3,LO)) Q:LO="" Q:$P(^LAB(62.4,T,3,LO,0),U,4)=T1
- I '$D(SUB) S SUB=0 F S SUB=$O(^LAH(LWL,1,"C",AID,SUB)) Q:SUB="" S T0=$G(^LAH(LWL,1,SUB,0)) Q:$P(T0,U,3)=AAN
- Q:SUB=""
- I LO="" S ^LAZ("ZZZ",ID)=T1_" NOT IN THE AUTO INSTRUMENT FILE" Q
- S T2=$P($P(^LAB(62.4,T,3,LO,1),"(",2),",",1)
- S RES=$P(Y(1),",",13) F I=1:1:8 I $E(RES)=" " S RES=$E(RES,2,$L(RES))
- S ^LAH(LWL,1,SUB,T2)=RES
- Q
- ;
- CHECK ;come here on NAK
- S CK=CNT-1 I ^LA(T,"I",CK)'="~U" S ^LA(T,"O",0)=^LA(T,"P3")-1 Q ;***JPC - SUBTRACT 1 FROM COUNTER IN P3 NODE
- S CT=^LA(T,"O",0) I ^(CT)["[" S NID=$P(^(CT),",",9),^LAZ("ZZZ",NID)="Response to Host Query, Device "_T_", Failed"
- F I=(CT+1):1 Q:'$D(^LA(T,"O",I)) Q:$E(^LA(T,"O",I))="["
- I I>^LA(T,"O") S I=^LA(T,"O")+1 ;***JPC - ADD 1 FOR NEXT LINE
- S ^LA(T,"O",0)=I-1 K CK,CT,NID Q ;***JPC - SUBTRACT 1
- RET ;Capture return code from 701-02. Report on error list.
- S RC=$P(Y(1),",",4) I $E(RC)=" " S RC=$E(RC,2)
- S SID=$E($P(Y(1),",",8),1,11) I RC=0 K ^LAZ("ZZZ",SID),SID S RC=1 Q
- S ^LAZ("ZZZ",SID)=^LAZ("ZZZERROR",RC) K SID Q
- LABCX7XX ; IHS/DIR/FJE - BECKMAN BIDIRECTIONAL DIRECT CONNECT INTERFACE 8/16/90 14:53 COPY FOR INSTRUMENT #-- ; [ 05/14/1999 10:03 AM ]
- +1 ;;5.2;LA;**1004**;MAY 14, 1999
- +2 ;;5.1;LAB;;04/11/91 11:06
- 0 SET LANM=$TEXT(+0)
- SET (TSK,T)=+$EXTRACT(LANM,7,8)
- IF +T<1
- QUIT
- IF $DATA(^LA("LOCK",T))
- QUIT
- SET IOP=$PIECE(^LAB(62.4,T,0),"^",2)
- IF IOP=""
- GOTO H^XUS
- DO NOW^%DTC
- SET DT=X
- KILL ^LA(T)
- DO ^LABCX7I
- +1 ;*** JPC - MOVED HERE FROM LINE DQ (SO RESTART INSTRUMENT CAN BE USED, WHICH CALLS TOP OF ROUTINE)
- SET X="ERR^ZU"
- SET @^%ZOSF("TRAP")
- +2 ;*** JPC - ADDED IN CASE ITS TASKED
- IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- LA2 KILL RES,TV,Y
- SET A=1
- IF OUT=""
- GOTO RD
- IF $DATA(^LA(DEB,0))
- DO DBO
- +1 IF $ASCII(OUT)<32
- WRITE OUT
- GOTO RD
- +2 IF OUT["]"
- WRITE OUT,!
- SET OUT=$CHAR(10)
- IF $DATA(^LA(DEB,0))
- DO DBO
- GOTO RD
- +3 WRITE OUT
- GOTO TOUT
- RD SET TOUT=5
- SET IN=""
- SET A=0
- READ *X:TOUT
- IF '$TEST
- GOTO TOUT
- IF $DATA(^LA(DEB,0))
- DO DBX
- SET IN=$CHAR(X)
- DO IN
- IF IN="["
- GOTO RD1
- +1 ;,^LA(T,"P3")=^LA(T,"O",0)
- IF X=^LA(T,"P2")
- SET ^("P2")=$SELECT(X=ACK:ETX,1:ACK)
- +2 IF X=ETX
- SET ^LA(T,"P3")=^LA(T,"O",0)+1
- GOTO TOUT
- +3 IF X=ACK
- SET ^LA(T,"P3")=^LA(T,"O",0)+1
- GOTO TOUT
- +4 IF X=LB
- SET ^LA(T,"P")="IN"
- SET OUT=$CHAR(ACK)
- SET ^("P1")=ETX
- GOTO LA2
- +5 IF X=LBO
- SET OUT=$CHAR(NAK)
- GOTO LA2
- +6 IF X=EOT
- SET ^LA(T,"P")=""
- SET (^("P1"),^("P2"))=ACK
- SET OUT=""
- GOTO LA2
- +7 IF X=ENQ
- GOTO LA2
- +8 ; S ^LA(T,"O",0)=^LA(T,"P3") G W
- IF X=NAK
- DO CHECK
- GOTO W
- +9 SET OUT=""
- GOTO LA2
- RD1 SET TOUT=2
- SET CK=X
- SET FL=1
- SET ^LA(T,"P")="IN"
- RD2 FOR I=0:0
- IF $LENGTH(IN)=255
- QUIT
- READ *X:TOUT
- IF ('$TEST!(X=13))
- QUIT
- IF FL
- SET CK=CK+X
- SET IN=IN_$CHAR(X)
- IF X=93
- SET FL=0
- +1 IF '$DATA(^LA(T,"I"))
- DO SET
- DO IN
- DO QC
- IF $DATA(^LA(DEB,0))
- DO DBI
- SET LN=$LENGTH(IN)
- +2 IF LN=255
- IF (IN'["]")
- SET IN=""
- GOTO RD2
- +3 IF LN<255
- IF (IN'["]")
- SET OUT=$CHAR(NAK)
- GOTO LA2
- +4 SET OUT=$CHAR(^LA(T,"P1"))
- SET ^LA(T,"P1")=$SELECT(^LA(T,"P1")=ACK:ETX,1:ACK)
- +5 KILL TV
- SET (TRAY,CUP,ID,IDE,RMK)=""
- SET ST=+$PIECE(Y(1),",",2)
- SET FC=+$PIECE(Y(1),",",3)
- GOTO @ST
- 700 ;
- 703 IF FC=4
- SET ^LAZ("ZZZ",T)=Y(1)
- GOTO LA2
- 704 GOTO LA2
- 701 IF FC#2
- GOTO LA2
- IF FC=2
- DO RET
- IF FC=6
- DO ^LABCX7R
- IF RC>0
- GOTO LA2
- WRITE OUT
- IF $DATA(^LA(DEB,0))
- DO DBO
- GOTO TOUT
- 702 ;*** JPC - 11,13
- IF FC=1
- DO HDR
- IF FC=3
- DO RES
- IF FC=5
- DO EOC
- IF FC=11
- DO RES2
- IF FC=13
- DO RES2
- +1 GOTO LA2
- W ;
- +1 SET OUT=""
- SET CNT=^LA(T,"O",0)+1
- IF $DATA(^(CNT))
- SET ^(0)=CNT
- SET OUT=^(CNT)
- +2 IF OUT=$CHAR(4,1)
- SET ^LA(T,"P")="PEND"
- GOTO LA2
- TOUT SET %H=$HOROLOG
- DO YMD^%DTC
- IF LADT'=X
- SET LADT=X
- KILL %,%H
- +1 IF $DATA(^LA("STOP",T))
- KILL ^LA("LOCK",T),^LA("STOP",T)
- HANG
- +2 IF $DATA(^LA(T,"O"))
- IF ^LA(T,"O")>^LA(T,"O",0)
- GOTO W
- +3 IF ^LA(T,"O")=^LA(T,"O",0)
- KILL ^LA(T,"O")
- SET (^LA(T,"O"),^LA(T,"O",0))=0
- +4 GOTO RD
- QC SET A=A+1
- SET Y(A)=IN
- 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 IF IN="["
- QUIT
- LOCK ^LA(T,"I")
- SET (CNT,^LA(T,"I"),^LA(T,"I",0))=^LA(T,"I")+1
- SET ^LA(T,"I",CNT)=$SELECT($LENGTH(IN)>1:IN,1:"~"_$CHAR(X+64))
- IF CNT>100
- KILL ^LA(T,"I",CNT-100)
- LOCK
- QUIT
- DQ ;*** JPC - KILL STOP NODE IN CASE IT WAS STOPPED WHEN NOT RUNNING
- KILL ^LA("LOCK",$EXTRACT($TEXT(+0),7,8)),^LA("STOP",$EXTRACT($TEXT(+0),7,8))
- GOTO 0
- SET IF '$DATA(^LA(T,"I"))#2
- SET ^LA(T,"I")=0
- SET ^("I",0)=0
- SETO IF '$DATA(^LA(T,"O"))#2
- SET ^LA(T,"O")=0
- SET ^("O",0)=0
- QUIT
- TRAP ;D ^LABERR S T=TSK D SET^LAB G @("LA2^"_LANM)
- QUIT
- DBO SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="OUT: "_$SELECT($LENGTH(OUT)>2:$EXTRACT(OUT,1,230),$LENGTH(OUT)=1:"~"_$CHAR($ASCII(OUT)+64),1:"~"_$CHAR($ASCII(OUT,1)+64)_"~"_$CHAR($ASCII(OUT,2)+64))_"%^%"_$HOROLOG
- QUIT
- DBX IF X=91
- QUIT
- SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="IN: "_$SELECT(X>31:$CHAR(X),1:"~"_$CHAR(X+64))_"%^%"_$HOROLOG
- QUIT
- DBI SET (Q,^LA(DEB,0))=^LA(DEB,0)+1
- SET ^(Q)="IN: "_$EXTRACT(IN,1,230)_"%^%"_$HOROLOG
- QUIT
- HDR ;
- +1 SET TRAY=$PIECE(Y(1),",",8)
- IF $EXTRACT(TRAY)=" "
- SET TRAY=$EXTRACT(TRAY,2)
- +2 SET CUP=$PIECE(Y(1),",",9)
- IF $EXTRACT(CUP)=" "
- SET CUP=$EXTRACT(CUP,2)
- +3 SET ID=$EXTRACT($PIECE(Y(1),",",13),1,11)
- SET AA=$EXTRACT(ID,1,3)
- SET AID=+$EXTRACT(ID,8,11)
- SET AAN=0
- AAN SET AAN=$ORDER(^LRO(68,"B",AA,AAN))
- IF AAN
- IF ^LRO(68,"B",AA,AAN)=""
- GOTO AAN
- +1 IF AAN=""
- SET ^LAZ("ZZZ",ID)="INVALID ACCESSION AREA"
- QUIT
- +2 SET LWL=$PIECE(^LAB(62.4,T,0),U,4)
- +3 ;FHL - Y2K 9/21/98 S D1=$P(Y(1),",",4),FDT=2_$E(D1,5,6)_$E(D1,3,4)_$E(D1,1,2)
- +4 ;FHL - Y2K 9/21/98
- +5 ;D1 appears to be in international format (DDMMYY)
- +6 ;So with %DT="I" (international date format flag) ^%DT should
- +7 ;convert D1 directly to fm formated date. ^%DT handles 2 digit
- +8 ;years correctly until 2018.
- +9 ;
- +10 KILL %DT
- SET D1=$PIECE(Y(1),",",4)
- SET %DT="I"
- SET X=D1
- DO ^%DT
- IF Y'=-1
- SET FDT=Y
- KILL %DT
- +11 IF Y=-1
- SET X="T"
- DO ^%DT
- SET FDT=Y
- +12 LOCK ^LAH(LWL)
- IF $DATA(^LAH(LWL))#10=0
- SET ^LAH(LWL)=0
- SUB SET (SUB,^LAH(LWL))=^LAH(LWL)+1
- IF $DATA(^LAH(LWL,1,SUB))
- GOTO SUB
- LOCK
- +1 SET ^LAH(LWL,1,SUB,0)=TRAY_U_CUP_U_AAN_U_FDT_U_AID_"^^CX7"
- +2 SET ^LAH(LWL,1,"B",TRAY_";"_CUP,SUB)=""
- +3 SET ^LAH(LWL,1,"C",AID,SUB)=""
- +4 QUIT
- RES ;
- +1 SET ID=$EXTRACT($PIECE(Y(1),",",10),1,11)
- SET AID=+$EXTRACT(ID,8,11)
- SET AA=$EXTRACT(ID,1,3)
- SET AAN=0
- AAN2 SET AAN=$ORDER(^LRO(68,"B",AA,AAN))
- IF AAN
- IF ^LRO(68,"B",AA,AAN)=""
- GOTO AAN2
- +1 IF AAN=""
- QUIT
- +2 SET LWL=$PIECE(^LAB(62.4,T,0),U,4)
- +3 ;**JPC - T1 CHANGE TO $P(... " ") TO ALLOW FOR 4 CHAR NAMES
- SET T1=$PIECE($PIECE(Y(1),",",11)," ")
- SET LO=0
- FOR I=1:1
- SET LO=$ORDER(^LAB(62.4,T,3,LO))
- IF LO=""
- QUIT
- IF $PIECE(^LAB(62.4,T,3,LO,0),U,6)=T1
- QUIT
- +4 ;**JPC - WITH MULT ACCN AREAS, NEED TO VERIFY CORRECT SUB
- IF '$DATA(SUB)
- SET SUB=0
- FOR
- SET SUB=$ORDER(^LAH(LWL,1,"C",AID,SUB))
- IF SUB=""
- QUIT
- SET T0=$GET(^LAH(LWL,1,SUB,0))
- IF $PIECE(T0,U,3)=AAN
- QUIT
- +5 IF SUB=""
- QUIT
- +6 ;JPC FIXED SPELLING OF INSTRUMENT
- IF LO=""
- SET ^LAZ("ZZZ",ID)=T1_" NOT IN THE AUTO INSTRUMENT FILE"
- QUIT
- +7 SET T2=$PIECE($PIECE(^LAB(62.4,T,3,LO,1),"(",2),",",1)
- +8 SET RES=$PIECE(Y(1),",",16)
- FOR I=1:1:8
- IF $EXTRACT(RES)=" "
- SET RES=$EXTRACT(RES,2,$LENGTH(RES))
- +9 SET ^LAH(LWL,1,SUB,T2)=RES
- +10 QUIT
- EOC ;end of cup record, clean up LA(T,"I")
- +1 IF ^LA(T,"I")=^LA(T,"I",0)
- KILL ^LA(T,"I")
- SET (^LA(T,"I"),^LA(T,"I",0))=0
- +2 SET ID=$EXTRACT($PIECE(Y(1),",",7),1,11)
- KILL ^LAZ(ID)
- QUIT
- +3 ;
- RES2 ; *** JPC - ADDED RES2 TO PROCESS SPECIAL CALC AND TIMED URINE
- +1 ; PARAM 3 IN AUTO INSTR SHOULD MATCH NAMES ON CX7
- +2 ;check status--quit if not valid calc
- IF $PIECE(Y(1),",",12)'="OK"
- QUIT
- +3 SET ID=$EXTRACT($PIECE(Y(1),",",9),1,11)
- SET AID=+$EXTRACT(ID,8,11)
- SET AA=$EXTRACT(ID,1,3)
- SET AAN=0
- AAN21 SET AAN=$ORDER(^LRO(68,"B",AA,AAN))
- IF AAN
- IF ^LRO(68,"B",AA,AAN)=""
- GOTO AAN21
- +1 IF AAN=""
- QUIT
- +2 SET LWL=$PIECE(^LAB(62.4,T,0),U,4)
- +3 SET T1=$PIECE(Y(1),",",11)
- SET LO=0
- FOR I=20:-1:2
- IF $EXTRACT(T1,I)'=" "
- QUIT
- SET T1=$EXTRACT(T1,1,I-1)
- +4 FOR I=1:1
- SET LO=$ORDER(^LAB(62.4,T,3,LO))
- IF LO=""
- QUIT
- IF $PIECE(^LAB(62.4,T,3,LO,0),U,4)=T1
- QUIT
- +5 IF '$DATA(SUB)
- SET SUB=0
- FOR
- SET SUB=$ORDER(^LAH(LWL,1,"C",AID,SUB))
- IF SUB=""
- QUIT
- SET T0=$GET(^LAH(LWL,1,SUB,0))
- IF $PIECE(T0,U,3)=AAN
- QUIT
- +6 IF SUB=""
- QUIT
- +7 IF LO=""
- SET ^LAZ("ZZZ",ID)=T1_" NOT IN THE AUTO INSTRUMENT FILE"
- QUIT
- +8 SET T2=$PIECE($PIECE(^LAB(62.4,T,3,LO,1),"(",2),",",1)
- +9 SET RES=$PIECE(Y(1),",",13)
- FOR I=1:1:8
- IF $EXTRACT(RES)=" "
- SET RES=$EXTRACT(RES,2,$LENGTH(RES))
- +10 SET ^LAH(LWL,1,SUB,T2)=RES
- +11 QUIT
- +12 ;
- CHECK ;come here on NAK
- +1 ;***JPC - SUBTRACT 1 FROM COUNTER IN P3 NODE
- SET CK=CNT-1
- IF ^LA(T,"I",CK)'="~U"
- SET ^LA(T,"O",0)=^LA(T,"P3")-1
- QUIT
- +2 SET CT=^LA(T,"O",0)
- IF ^(CT)["["
- SET NID=$PIECE(^(CT),",",9)
- SET ^LAZ("ZZZ",NID)="Response to Host Query, Device "_T_", Failed"
- +3 FOR I=(CT+1):1
- IF '$DATA(^LA(T,"O",I))
- QUIT
- IF $EXTRACT(^LA(T,"O",I))="["
- QUIT
- +4 ;***JPC - ADD 1 FOR NEXT LINE
- IF I>^LA(T,"O")
- SET I=^LA(T,"O")+1
- +5 ;***JPC - SUBTRACT 1
- SET ^LA(T,"O",0)=I-1
- KILL CK,CT,NID
- QUIT
- RET ;Capture return code from 701-02. Report on error list.
- +1 SET RC=$PIECE(Y(1),",",4)
- IF $EXTRACT(RC)=" "
- SET RC=$EXTRACT(RC,2)
- +2 SET SID=$EXTRACT($PIECE(Y(1),",",8),1,11)
- IF RC=0
- KILL ^LAZ("ZZZ",SID),SID
- SET RC=1
- QUIT
- +3 SET ^LAZ("ZZZ",SID)=^LAZ("ZZZERROR",RC)
- KILL SID
- QUIT
