- 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 Mar 13, 2025@20:47:22 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
