- LADIMD ;SLC/DLG - DIMINESION BUILD DOWNLOAD FILE. ;10/17/90 12:51 ;
- ;;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="@"
- I $D(^LA(LRINST,"C")),(^LA(LRINST,"C")=^LA(LRINST,"C",0)) K ^LA(LRINST,"C")
- I '$D(^LA(LRINST,"C")) D SETC
- A S F=$O(^LAB(61,"B","CSF",0)),X=^LAB(69.9,1,1),LRFLUID=$P(X,"^",3,4)_"^"_$P(X,"^",2)_"^"_F,FS=$C(28)
- ;S LRURG="" F I="ROUTINE","STAT","ASAP" S LRURG=LRURG_$O(^LAB(62.05,"B",I,0))
- S LRURG="" F I="ROUTINE","EMERGENCY","OUTPATIENT" S LRURG=LRURG_$O(^LAB(62.05,"B",I,0))
- 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="" 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) D PNM
- S F=$P(LRL,"^",5),F=$S($P(LRFLUID,"^",1)=F:1,$P(LRFLUID,"^",3)=F:3,$P(LRFLUID,"^",2)=F:2,$P(LRFLUID,"^",4)=F:4,1:0) ; not 4 fluids don't send
- I 'F W:'$D(ZTQUEUED) !,"Accession not correct collection sample: ",LRACC Q
- D TEST S LRECORD=$C(2)_"D"_FS_"0"_FS_"0"_FS_"A"_FS_$E(SSN_" "_$P(PNM,","),1,27)_FS_LRAN_FS_F_FS_FS_LRPRIO_FS_"1"_FS_"0"_FS_"1"_FS_LRTN_FS
- F I=1:1:LRTN S LRECORD=LRECORD_X(I) I I'=LRTN,((9+$L(LRECORD))>255) D OUT
- S LRECORD=LRECORD_"%^%" D OUT Q
- TEST K X S LRTN=0 F LRTEST=0:0 S LRTEST=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST)) Q:LRTEST'>0 S LRPRIO=$P(^(LRTEST,0),"^",2),LRPRIO=$F(LRURG,LRPRIO)-2 S:LRPRIO<0 LRPRIO=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) S LRTN=LRTN+1,X(LRTN)=Y_FS
- 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),LRACC=^(.2),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
- OUT S Q=^LA(LRINST,"C")+1,^("C")=Q,^("C",Q)=LRECORD,LRECORD="" Q
- SETC L ^LA(LRINST) S ^LA(LRINST,"C")=0,^("C",0)=0 L Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLADIMD 2158 printed Feb 18, 2025@23:08:30 Page 2
- LADIMD ;SLC/DLG - DIMINESION BUILD DOWNLOAD FILE. ;10/17/90 12:51 ;
- +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="@"
- +7 IF $DATA(^LA(LRINST,"C"))
- IF (^LA(LRINST,"C")=^LA(LRINST,"C",0))
- KILL ^LA(LRINST,"C")
- +8 IF '$DATA(^LA(LRINST,"C"))
- DO SETC
- A SET F=$ORDER(^LAB(61,"B","CSF",0))
- SET X=^LAB(69.9,1,1)
- SET LRFLUID=$PIECE(X,"^",3,4)_"^"_$PIECE(X,"^",2)_"^"_F
- SET FS=$CHAR(28)
- +1 ;S LRURG="" F I="ROUTINE","STAT","ASAP" S LRURG=LRURG_$O(^LAB(62.05,"B",I,0))
- +2 SET LRURG=""
- FOR I="ROUTINE","EMERGENCY","OUTPATIENT"
- SET LRURG=LRURG_$ORDER(^LAB(62.05,"B",I,0))
- +3 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
- +4 SET LREND=""
- 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)
- DO PNM
- +1 ; not 4 fluids don't send
- SET F=$PIECE(LRL,"^",5)
- SET F=$SELECT($PIECE(LRFLUID,"^",1)=F:1,$PIECE(LRFLUID,"^",3)=F:3,$PIECE(LRFLUID,"^",2)=F:2,$PIECE(LRFLUID,"^",4)=F:4,1:0)
- +2 IF 'F
- if '$DATA(ZTQUEUED)
- WRITE !,"Accession not correct collection sample: ",LRACC
- QUIT
- +3 DO TEST
- SET LRECORD=$CHAR(2)_"D"_FS_"0"_FS_"0"_FS_"A"_FS_$EXTRACT(SSN_" "_$PIECE(PNM,","),1,27)_FS_LRAN_FS_F_FS_FS_LRPRIO_FS_"1"_FS_"0"_FS_"1"_FS_LRTN_FS
- +4 FOR I=1:1:LRTN
- SET LRECORD=LRECORD_X(I)
- IF I'=LRTN
- IF ((9+$LENGTH(LRECORD))>255)
- DO OUT
- +5 SET LRECORD=LRECORD_"%^%"
- DO OUT
- QUIT
- TEST KILL X
- SET LRTN=0
- FOR LRTEST=0:0
- SET LRTEST=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST))
- if LRTEST'>0
- QUIT
- SET LRPRIO=$PIECE(^(LRTEST,0),"^",2)
- SET LRPRIO=$FIND(LRURG,LRPRIO)-2
- if LRPRIO<0
- SET LRPRIO=0
- DO T2
- +1 QUIT
- T2 if '$DATA(^TMP($JOB,LRTEST))
- QUIT
- FOR I=0:0
- SET I=$ORDER(^TMP($JOB,LRTEST,I))
- if I'>0
- QUIT
- SET Y=^(I)
- SET LRTN=LRTN+1
- SET X(LRTN)=Y_FS
- +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 LRACC=^(.2)
- 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
- OUT SET Q=^LA(LRINST,"C")+1
- SET ^("C")=Q
- SET ^("C",Q)=LRECORD
- SET LRECORD=""
- QUIT
- SETC LOCK ^LA(LRINST)
- SET ^LA(LRINST,"C")=0
- SET ^("C",0)=0
- LOCK
- QUIT
