LAHTCCAD ;SLC/DLG - HITATCHI 717 THRU CCA SYSTEM BUILD DOWNLOAD FILE. ;7/20/90 09:17 ;
;;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.
S:$D(ZTQUEUED) ZTREQ="@" S T=LRINST S:'$D(^LA(T,"O")) ^("O")=0,^("O",0)=0
S (BLKN,BLK)="" F I=1:1:34 S BLK=BLK_" ",BLKN=BLKN_"0"
A F LRTRAY=LRTRAY1:0 D:$D(^LRO(68.2,LRLL,1,LRTRAY)) TRAY S LRTRAY=$O(^LRO(68.2,LRLL,1,LRTRAY)),LRCUP1=1 Q:LRTRAY'>0
S LREND=0,LRECORD=$C(4) D SEND Q
TRAY 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 LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0),LRAA=+LRL,LRAD=$P(LRL,"^",2),LRAN=$P(LRL,"^",3),X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LADOC=$P(X,"^",8),X=^LR(+X,0) I $P(X,"^",2)=2 S LRDPF=2,DFN=$P(X,"^",3) D PT^LRX,TEST
S PNM=$E(PNM,1,20) S:$D(SSN) SSN="000000"_$E(SSN,1,3)_$E(SSN,5,6)_$E(SSN,8,11) S DOB=$E(DOB,4,5)_$E(DOB,6,7)_$E(DOB,2,3) S X=LADOC D:X]"" DOC^LRX S LADOC=Y S:LADOC="" LADOC="UNKNOWN" S:$L(LADOC)>20 LADOC=$E(LADOC,1,20)
S LRAN1=$E(LRAD,4,5)_$E(LRAD,6,7)_$E(100000+LRAN,2,6),LRWRD=$E(LRWRD,1,10)
S LRECORD=$C(2)_"O"_SSN_$E(BLK,1,(20-$L(PNM)))_PNM_$E(BLK,1,(10-$L(LRWRD)))_LRWRD_$E(10000+AGE,2,5)_"Y"_SEX_DOB_$E(BLK,1,(20-$L(LADOC)))_LADOC_$E(1000000000+LRAN1,2,10)_X_$C(3) D CSUM S LRECORD=LRECORD_CSUM
SEND L ^LA(LRINST,"O") S Q=^LA(LRINST,"O")+1,^("O")=Q,^("O",Q)=LRECORD L Q
TEST S X="" F I=1:1:68 S X=X_"0"
F LRTEST=0:0 S LRTEST=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST)) Q:LRTEST'>0 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),Y1=0 S:$L(Y)>2 Y1=$E(Y),Y=$E(Y,2,3) I Y<35 D T3
Q
T3 S:Y1=0 X=$E(X,1,(Y-1))_"1"_$E(X,(Y+1),68),X=$E(X,1,(Y+33))_"1"_$E(X,(Y+35),68) S:Y1=1 X=$E(X,1,(Y-1))_"1"_$E(X,(Y+1),68) S:Y1=2 X=$E(X,1,(Y+33))_"1"_$E(X,(Y+35),68)
Q
CSUM S CSUM=0 F I=2:1:($L(LRECORD)-1) S CSUM=CSUM+$A(LRECORD,I)
S CSUM=$E(1000+(CSUM#256),2,4) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAHTCCAD 2034 printed Apr 09, 2024@20:45:18 Page 2
LAHTCCAD ;SLC/DLG - HITATCHI 717 THRU CCA SYSTEM BUILD DOWNLOAD FILE. ;7/20/90 09:17 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
+2 ;Call with LRLL = load list to build
+3 ;Call with LRTRAY1 = Starting tray number
+4 ;Call with LRLL = Auto Instrument pointer
+5 ;Call with LRFORCE=1 if send tray and cup.
+6 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET T=LRINST
if '$DATA(^LA(T,"O"))
SET ^("O")=0
SET ^("O",0)=0
+7 SET (BLKN,BLK)=""
FOR I=1:1:34
SET BLK=BLK_" "
SET BLKN=BLKN_"0"
A FOR LRTRAY=LRTRAY1:0
if $DATA(^LRO(68.2,LRLL,1,LRTRAY))
DO TRAY
SET LRTRAY=$ORDER(^LRO(68.2,LRLL,1,LRTRAY))
SET LRCUP1=1
if LRTRAY'>0
QUIT
+1 SET LREND=0
SET LRECORD=$CHAR(4)
DO SEND
QUIT
TRAY FOR LRCUP=(LRCUP1-1):0
SET LRCUP=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP))
if LRCUP'>0
QUIT
DO SAMPLE
SET LRECORD=""
+1 QUIT
SAMPLE SET LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)
SET LRAA=+LRL
SET LRAD=$PIECE(LRL,"^",2)
SET LRAN=$PIECE(LRL,"^",3)
SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LADOC=$PIECE(X,"^",8)
SET X=^LR(+X,0)
IF $PIECE(X,"^",2)=2
SET LRDPF=2
SET DFN=$PIECE(X,"^",3)
DO PT^LRX
DO TEST
+1 SET PNM=$EXTRACT(PNM,1,20)
if $DATA(SSN)
SET SSN="000000"_$EXTRACT(SSN,1,3)_$EXTRACT(SSN,5,6)_$EXTRACT(SSN,8,11)
SET DOB=$EXTRACT(DOB,4,5)_$EXTRACT(DOB,6,7)_$EXTRACT(DOB,2,3)
SET X=LADOC
if X]""
DO DOC^LRX
SET LADOC=Y
if LADOC=""
SET LADOC="UNKNOWN"
if $LENGTH(LADOC)>20
SET LADOC=$EXTRACT(LADOC,1,20)
+2 SET LRAN1=$EXTRACT(LRAD,4,5)_$EXTRACT(LRAD,6,7)_$EXTRACT(100000+LRAN,2,6)
SET LRWRD=$EXTRACT(LRWRD,1,10)
+3 SET LRECORD=$CHAR(2)_"O"_SSN_$EXTRACT(BLK,1,(20-$LENGTH(PNM)))_PNM_$EXTRACT(BLK,1,(10-$LENGTH(LRWRD)))_LRWRD_$EXTRACT(10000+AGE,2,5)_"Y"_SEX_DOB_$EXTRACT(BLK,1,(20-$LENGTH(LADOC)))_LADOC_$EXTRACT(1000000000+LRAN1,2,10)_X_$CHAR(3)
DO CSUM
SET LRECORD=LRECORD_CSUM
SEND LOCK ^LA(LRINST,"O")
SET Q=^LA(LRINST,"O")+1
SET ^("O")=Q
SET ^("O",Q)=LRECORD
LOCK
QUIT
TEST SET X=""
FOR I=1:1:68
SET X=X_"0"
+1 FOR LRTEST=0:0
SET LRTEST=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST))
if LRTEST'>0
QUIT
DO T2
+2 QUIT
T2 if '$DATA(^TMP($JOB,LRTEST))
QUIT
+1 FOR I=0:0
SET I=$ORDER(^TMP($JOB,LRTEST,I))
if I'>0
QUIT
SET Y=^(I)
SET Y1=0
if $LENGTH(Y)>2
SET Y1=$EXTRACT(Y)
SET Y=$EXTRACT(Y,2,3)
IF Y<35
DO T3
+2 QUIT
T3 if Y1=0
SET X=$EXTRACT(X,1,(Y-1))_"1"_$EXTRACT(X,(Y+1),68)
SET X=$EXTRACT(X,1,(Y+33))_"1"_$EXTRACT(X,(Y+35),68)
if Y1=1
SET X=$EXTRACT(X,1,(Y-1))_"1"_$EXTRACT(X,(Y+1),68)
if Y1=2
SET X=$EXTRACT(X,1,(Y+33))_"1"_$EXTRACT(X,(Y+35),68)
+1 QUIT
CSUM SET CSUM=0
FOR I=2:1:($LENGTH(LRECORD)-1)
SET CSUM=CSUM+$ASCII(LRECORD,I)
+1 SET CSUM=$EXTRACT(1000+(CSUM#256),2,4)
QUIT
