- LAEPXD ; IHS/DIR/FJE - ABBOTT EPX BUILD DOWNLOAD FILE. 7/20/90 08:20 ;
- ;;5.2;LA;;NOV 01, 1997
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- ;Call with LRLL = load list to build
- ;Call with LRTRAY1 = Starting tray number
- ;Call with LRLL = Auto Instrument pointer
- ;Call with LRFORCE=1 if send tray and cup.
- A S:$D(ZTQUEUED) ZTREQ="@" S T=LRINST D SET S LRECORD="100010#",F=1 D SEN S LRECORD="140011A#",F=1 D SEN ;TEST LIST BY NAME AND AUTO SEND
- F LRTRAY=LRTRAY1:0 D:$D(^LRO(68.2,LRLL,1,LRTRAY)) TRAY S LRTRAY=$O(^LRO(68.2,LRLL,1,LRTRAY)) Q:LRTRAY'>0 S LRCUP1=1
- S LREND=1 Q
- TRAY I LRCUP1=1 S LRECORD="120013C"_$E(100+LRTRAY,2,3)_"#",F=1 D SEN ;CLEAR TRAY INFORMATION
- F LRCUP=LRCUP1-1:0 S LRCUP=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP)) Q:LRCUP'>0 D SAMPLE S LRECORD=""
- Q
- SAMPLE S STAT="N",LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0),LRAA=+LRL,LRAD=$P(LRL,"^",2),LRAN=$P(LRL,"^",3) D PNM,TEST S L=NT*8+97
- S LRECORD="11"_$E(10000+L,2,5)_$E(LRAN_" ",1,20)_STAT_"N"
- S LRECORD=LRECORD_$E(SSN_" ",1,20)_" "_$E(100+LRTRAY,2,3)_$E(100+LRCUP,2,3)_" "_$E(1000+NT,2,4)
- I X]"" S F=1 F I=1:1:NT S L=$L(LRECORD)+8 S:L<255 LRECORD=LRECORD_$E($P(X,"^",I)_" ",1,8) I L>252 D SEN S LRECORD="",F=0
- S LRECORD=LRECORD_"#" D SEN ;SEND DATA
- Q
- TEST S NT=0,X="" F LRTEST=0:0 S LRTEST=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST)) Q:LRTEST'>0 S STAT=$S($P(^(LRTEST,0),U,2)=1:"Y",1:"N") D T2
- Q
- T2 Q:'$D(^TMP($J,LRTEST)) F I=0:0 S I=$O(^TMP($J,LRTEST,I)) Q:I'>0 S Y=^(I) S:X'[Y NT=NT+1,$P(X,"^",NT)=Y ;Don't repete a test
- Q
- PNM ;Get patient name and last 4 from an accession.
- S PNM="" Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S X=^(0),X=^LR(+X,0) I $P(X,"^",2)=2 S DFN=$P(X,"^",3) D PT^LRX S SSN=$E(SSN,1,3)_$E(SSN,5,6)_$E(SSN,8,11)
- Q
- SEN S:F=1 SUM=$A(LRECORD,1) F II=$S(F:2,1:1):1:$L(LRECORD) S M=SUM,N=$A(LRECORD,II),B=64,SUM=0 X "F JJ=1:1:7 S K=M\B,L=N\B,O=$S(K=L:0,1:1),SUM=SUM*2+O,M=M#B,N=N#B,B=B\2"
- Q:$E(LRECORD,$L(LRECORD))'="#"
- S SUM=SUM#128,X=SUM\16 D HEX S LRECORD=LRECORD_X,X=SUM#16 D HEX S LRECORD=LRECORD_X
- L ^LA(LRINST,"O") S (Q,^LA(LRINST,"O"))=^LA(LRINST,"O")+1,^("O",Q)=LRECORD L
- Q
- HEX S X=$E("0123456789ABCDEF",(X+1)) Q
- SET S:'$D(^LA(T,"O"))#2 ^LA(T,"O")=0,^("O",0)=0 Q
- LAEPXD ; IHS/DIR/FJE - ABBOTT EPX BUILD DOWNLOAD FILE. 7/20/90 08:20 ;
- +1 ;;5.2;LA;;NOV 01, 1997
- +2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- +3 ;Call with LRLL = load list to build
- +4 ;Call with LRTRAY1 = Starting tray number
- +5 ;Call with LRLL = Auto Instrument pointer
- +6 ;Call with LRFORCE=1 if send tray and cup.
- A ;TEST LIST BY NAME AND AUTO SEND
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- SET T=LRINST
- DO SET
- SET LRECORD="100010#"
- SET F=1
- DO SEN
- SET LRECORD="140011A#"
- SET F=1
- DO SEN
- +1 FOR LRTRAY=LRTRAY1:0
- IF $DATA(^LRO(68.2,LRLL,1,LRTRAY))
- DO TRAY
- SET LRTRAY=$ORDER(^LRO(68.2,LRLL,1,LRTRAY))
- IF LRTRAY'>0
- QUIT
- SET LRCUP1=1
- +2 SET LREND=1
- QUIT
- TRAY ;CLEAR TRAY INFORMATION
- IF LRCUP1=1
- SET LRECORD="120013C"_$EXTRACT(100+LRTRAY,2,3)_"#"
- SET F=1
- DO SEN
- +1 FOR LRCUP=LRCUP1-1:0
- SET LRCUP=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP))
- IF LRCUP'>0
- QUIT
- DO SAMPLE
- SET LRECORD=""
- +2 QUIT
- SAMPLE SET STAT="N"
- SET LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)
- SET LRAA=+LRL
- SET LRAD=$PIECE(LRL,"^",2)
- SET LRAN=$PIECE(LRL,"^",3)
- DO PNM
- DO TEST
- SET L=NT*8+97
- +1 SET LRECORD="11"_$EXTRACT(10000+L,2,5)_$EXTRACT(LRAN_" ",1,20)_STAT_"N"
- +2 SET LRECORD=LRECORD_$EXTRACT(SSN_" ",1,20)_" "_$EXTRACT(100+LRTRAY,2,3)_$EXTRACT(100+LRCUP,2,3)_" "_$EXTRACT(1000+NT,2,4)
- +3 IF X]""
- SET F=1
- FOR I=1:1:NT
- SET L=$LENGTH(LRECORD)+8
- IF L<255
- SET LRECORD=LRECORD_$EXTRACT($PIECE(X,"^",I)_" ",1,8)
- IF L>252
- DO SEN
- SET LRECORD=""
- SET F=0
- +4 ;SEND DATA
- SET LRECORD=LRECORD_"#"
- DO SEN
- +5 QUIT
- TEST SET NT=0
- SET X=""
- FOR LRTEST=0:0
- SET LRTEST=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST))
- IF LRTEST'>0
- QUIT
- SET STAT=$SELECT($PIECE(^(LRTEST,0),U,2)=1:"Y",1:"N")
- DO T2
- +1 QUIT
- T2 ;Don't repete a test
- IF '$DATA(^TMP($JOB,LRTEST))
- QUIT
- FOR I=0:0
- SET I=$ORDER(^TMP($JOB,LRTEST,I))
- IF I'>0
- QUIT
- SET Y=^(I)
- IF X'[Y
- SET NT=NT+1
- SET $PIECE(X,"^",NT)=Y
- +1 QUIT
- PNM ;Get patient name and last 4 from an accession.
- +1 SET PNM=""
- IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- QUIT
- SET X=^(0)
- SET X=^LR(+X,0)
- IF $PIECE(X,"^",2)=2
- SET DFN=$PIECE(X,"^",3)
- DO PT^LRX
- SET SSN=$EXTRACT(SSN,1,3)_$EXTRACT(SSN,5,6)_$EXTRACT(SSN,8,11)
- +2 QUIT
- SEN IF F=1
- SET SUM=$ASCII(LRECORD,1)
- FOR II=$SELECT(F:2,1:1):1:$LENGTH(LRECORD)
- SET M=SUM
- SET N=$ASCII(LRECORD,II)
- SET B=64
- SET SUM=0
- XECUTE "F JJ=1:1:7 S K=M\B,L=N\B,O=$S(K=L:0,1:1),SUM=SUM*2+O,M=M#B,N=N#B,B=B\2"
- +1 IF $EXTRACT(LRECORD,$LENGTH(LRECORD))'="#"
- QUIT
- +2 SET SUM=SUM#128
- SET X=SUM\16
- DO HEX
- SET LRECORD=LRECORD_X
- SET X=SUM#16
- DO HEX
- SET LRECORD=LRECORD_X
- +3 LOCK ^LA(LRINST,"O")
- SET (Q,^LA(LRINST,"O"))=^LA(LRINST,"O")+1
- SET ^("O",Q)=LRECORD
- LOCK
- +4 QUIT
- HEX SET X=$EXTRACT("0123456789ABCDEF",(X+1))
- QUIT
- SET IF '$DATA(^LA(T,"O"))#2
- SET ^LA(T,"O")=0
- SET ^("O",0)=0
- QUIT