LRMILL ;SLC/DLG - BUILD LOAD LIST FOR MICROSCAN ;4/4/89 21:38 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
INSERT ;Add a sample to next cup
D LRINST G END:LRINST<1,END:LRDAA<1 W !,"Select only from the ",$P(^LRO(68,LRDAA,0),U)," accession area"
S LRACC=1 D ^LRWU4 K LRACC G FINISH:LRAN<1 I LRDAA'=LRAA W !,"Sorry but this accession is in the wrong group" G IN2
IN2 D SHOW D WHATEST G IN7:'$D(X),FINISH:X=U
IN5 X LRTRANS I '$D(^LRO(68.2,LRINST,1,LRTRAY,1,0)) S ^(0)="^68.22PA^^"
D SETONE W !!," >> ADDED <<"
IN7 R !!,"Next Accession NUMBER: ",LRAN:DTIME G FINISH:'$T!(LRAN["^")!(LRAN'>0) I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) G IN2
I LRAN["?" W !,"Enter just the number part of the accession" G IN7
W !,$C(7),"This accesion doesn't exist" G IN7
Q
NOPE W !," OPERATION NOT COMPLETE" ;Drop thru finish
FINISH L +^LRO(68.2,LRINST) S ^LRO(68.2,LRINST,3)=0,$P(^(2),U,4,5)=LRTRAY_U_LRCUP L -^LRO(68.2,LRINST)
END K A,DIC,I,LRDAA,LRFULL,LRDFN,LRDPF,LRFULL,LRIX,LRTSTS,LRTX,LRWPROF,LRWRD,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,X,Y,Z,LRINST,%,LRPROF,LRTRAY,LRCUP,LRAA,LRAD
K AGE,DFN,DOB,K,PNM,SEX,T,D,G,LRAN,LREXEC,LRLLOC,SSN,X9
Q
LRINST ;Get loadlist data
S U="^" D DT^LRX S LRAD=DT K ^TMP("LR",$J,"T"),DIC,LRHOLD,LRTSTS
S DIC="^LRO(68.2,",DIC(0)="AEMZ" D ^DIC S LRINST=+Y Q:Y<1 L +^LRO(68.2,LRINST,3)
I $S($D(^LRO(68.2,LRINST,3)):$P(^(3),U,1),1:0) W !,"Load list is busy now, Please try later." S LRINST=-1 L -^LRO(68.2,LRINST,3) Q
S $P(^LRO(68.2,LRINST,3),U,1)=1 L -^LRO(68.2,LRINST,3)
S LRTRANS=+$P(Y(0),U,2),LRTYPE=+$P(Y(0),U,3),LRFULL=$P(Y(0),U,5),LRINSTIT=+$P(Y(0),U,7),LRMAXCUP=+$P(Y(0),U,4),Y(2)=$S($D(^LRO(68.2,LRINST,2)):^(2),1:""),LRTRAY=+$P(Y(2),U,4),LRCUP=+$P(Y(2),U,5)
S LRTRANS=$S($D(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1"),LRINSTIT=$S($D(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
S:'LRTYPE LRTRAY=1 S LRWPROF=+$O(^LRO(68.2,LRINST,10,0)),LRDAA=$S($D(^LRO(68.2,LRINST,10,LRWPROF,0)):$P(^(0),U,2),1:0)
S ^LRO(68.2,LRINST,1,0)="^68.21^"_LRTRAY_U_LRTRAY,^(LRTRAY,0)=LRTRAY_U_DT_U_DUZ_U_LRDAA
Q
SETONE ;Set tests into cup and update accession
S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_LRWPROF_U_LRSPEC
F I=0:0 S I=$O(X(I)) Q:I="" S LRIX=G2(I),LRTX=G2(I,0) D MV2
S DA=LRCUP,DA(1)=LRTRAY,DA(2)=LRINST,DR="5",DIE="^LRO(68.2,LRINST,1,LRTRAY,1," D ^DIE
Q
MV2 S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,LRIX,0)=LRTX,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRIX,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP
Q
WHATEST ;
S LRSPEC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
K X,G2 S G2=0 F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 I +^(I,0),'$P(^(0),U,3) S G2=G2+1,G2(G2)=I,G2(G2,0)=+^(0)
I G2<1 W !,"NO TESTS FREE TO ADD" K G2 Q
S G4="$P(^LAB(60,+G2(I,0),0),U,1)",G1="What test(s) to add?" D GROUP^LRWU2
Q
SHOW ;Show the patient
S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:-1) Q:LRDFN<1 S X=^LR(LRDFN,0)
S LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,PNM,?40,SSN Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMILL 2952 printed Sep 23, 2025@19:52:45 Page 2
LRMILL ;SLC/DLG - BUILD LOAD LIST FOR MICROSCAN ;4/4/89 21:38 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
INSERT ;Add a sample to next cup
+1 DO LRINST
if LRINST<1
GOTO END
if LRDAA<1
GOTO END
WRITE !,"Select only from the ",$PIECE(^LRO(68,LRDAA,0),U)," accession area"
+2 SET LRACC=1
DO ^LRWU4
KILL LRACC
if LRAN<1
GOTO FINISH
IF LRDAA'=LRAA
WRITE !,"Sorry but this accession is in the wrong group"
GOTO IN2
IN2 DO SHOW
DO WHATEST
if '$DATA(X)
GOTO IN7
if X=U
GOTO FINISH
IN5 XECUTE LRTRANS
IF '$DATA(^LRO(68.2,LRINST,1,LRTRAY,1,0))
SET ^(0)="^68.22PA^^"
+1 DO SETONE
WRITE !!," >> ADDED <<"
IN7 READ !!,"Next Accession NUMBER: ",LRAN:DTIME
if '$TEST!(LRAN["^")!(LRAN'>0)
GOTO FINISH
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
GOTO IN2
+1 IF LRAN["?"
WRITE !,"Enter just the number part of the accession"
GOTO IN7
+2 WRITE !,$CHAR(7),"This accesion doesn't exist"
GOTO IN7
+3 QUIT
NOPE ;Drop thru finish
WRITE !," OPERATION NOT COMPLETE"
FINISH LOCK +^LRO(68.2,LRINST)
SET ^LRO(68.2,LRINST,3)=0
SET $PIECE(^(2),U,4,5)=LRTRAY_U_LRCUP
LOCK -^LRO(68.2,LRINST)
END KILL A,DIC,I,LRDAA,LRFULL,LRDFN,LRDPF,LRFULL,LRIX,LRTSTS,LRTX,LRWPROF,LRWRD,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,X,Y,Z,LRINST,%,LRPROF,LRTRAY,LRCUP,LRAA,LRAD
+1 KILL AGE,DFN,DOB,K,PNM,SEX,T,D,G,LRAN,LREXEC,LRLLOC,SSN,X9
+2 QUIT
LRINST ;Get loadlist data
+1 SET U="^"
DO DT^LRX
SET LRAD=DT
KILL ^TMP("LR",$JOB,"T"),DIC,LRHOLD,LRTSTS
+2 SET DIC="^LRO(68.2,"
SET DIC(0)="AEMZ"
DO ^DIC
SET LRINST=+Y
if Y<1
QUIT
LOCK +^LRO(68.2,LRINST,3)
+3 IF $SELECT($DATA(^LRO(68.2,LRINST,3)):$PIECE(^(3),U,1),1:0)
WRITE !,"Load list is busy now, Please try later."
SET LRINST=-1
LOCK -^LRO(68.2,LRINST,3)
QUIT
+4 SET $PIECE(^LRO(68.2,LRINST,3),U,1)=1
LOCK -^LRO(68.2,LRINST,3)
+5 SET LRTRANS=+$PIECE(Y(0),U,2)
SET LRTYPE=+$PIECE(Y(0),U,3)
SET LRFULL=$PIECE(Y(0),U,5)
SET LRINSTIT=+$PIECE(Y(0),U,7)
SET LRMAXCUP=+$PIECE(Y(0),U,4)
SET Y(2)=$SELECT($DATA(^LRO(68.2,LRINST,2)):^(2),1:"")
SET LRTRAY=+$PIECE(Y(2),U,4)
SET LRCUP=+$PIECE(Y(2),U,5)
+6 SET LRTRANS=$SELECT($DATA(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1")
SET LRINSTIT=$SELECT($DATA(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
+7 if 'LRTYPE
SET LRTRAY=1
SET LRWPROF=+$ORDER(^LRO(68.2,LRINST,10,0))
SET LRDAA=$SELECT($DATA(^LRO(68.2,LRINST,10,LRWPROF,0)):$PIECE(^(0),U,2),1:0)
+8 SET ^LRO(68.2,LRINST,1,0)="^68.21^"_LRTRAY_U_LRTRAY
SET ^(LRTRAY,0)=LRTRAY_U_DT_U_DUZ_U_LRDAA
+9 QUIT
SETONE ;Set tests into cup and update accession
+1 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_LRWPROF_U_LRSPEC
+2 FOR I=0:0
SET I=$ORDER(X(I))
if I=""
QUIT
SET LRIX=G2(I)
SET LRTX=G2(I,0)
DO MV2
+3 SET DA=LRCUP
SET DA(1)=LRTRAY
SET DA(2)=LRINST
SET DR="5"
SET DIE="^LRO(68.2,LRINST,1,LRTRAY,1,"
DO ^DIE
+4 QUIT
MV2 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,LRIX,0)=LRTX
SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRIX,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP
+1 QUIT
WHATEST ;
+1 SET LRSPEC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
+2 KILL X,G2
SET G2=0
FOR I=0:0
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<1
QUIT
IF +^(I,0)
IF '$PIECE(^(0),U,3)
SET G2=G2+1
SET G2(G2)=I
SET G2(G2,0)=+^(0)
+3 IF G2<1
WRITE !,"NO TESTS FREE TO ADD"
KILL G2
QUIT
+4 SET G4="$P(^LAB(60,+G2(I,0),0),U,1)"
SET G1="What test(s) to add?"
DO GROUP^LRWU2
+5 QUIT
SHOW ;Show the patient
+1 SET LRDFN=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:-1)
if LRDFN<1
QUIT
SET X=^LR(LRDFN,0)
+2 SET LRDPF=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
DO PT^LRX
WRITE !,PNM,?40,SSN
QUIT
+3 QUIT
