LROW1 ;SLC/CJS - TEST & SAMP ;8/11/97
;;5.2;LAB SERVICE;**55,100,121,128**;Sep 27, 1994
K LRSAME,DIC,LRTEST,LRSAMP,LRXST,LRCCOM,LRGCOM S LRTSTN=0 S:'$D(LRCOM) LRCOM=0
L2 K LRNEDC,LROUT K:'$G(LRNN) LRURG ;LRNN=1 when coming from LRFAST
S DIC="^LAB(60,",DIC(0)="AEMOQ" S DIC("S")="I $L($P(^(0),U,4)),""BI""[$P(^(0),U,3)" S:LRLWC="LC"!(LRLWC="I") DIC("S")=DIC("S")_",$P(^(0),U,9)"
D ^DIC S:X="^^" DIROUT=1 S:Y<1&$D(LRADDTST) LRADDTST=LRADDTST_"^OUT" Q:Y<1 S LRTY=+Y
NOASK ;from LROR
S LRTSTN=LRTSTN+1,LRTEST(LRTSTN)=LRTY,LRY=$S($D(LRURG):+LRURG,1:$P(^LAB(60,LRTY,0),U,18)),H=+$P(^(0),U,16) G L3:LRY
I '$D(LROUTINE) K DIC S DIC="^LAB(62.05,",DIC(0)="AEQF",DIC("B")="ROUTINE",DIC("S")="I '$P(^(0),U,3),Y'<"_H S:LRLWC="LC" DIC("S")=DIC("S")_" I $P(^(0),U,2)" F I=0:0 D ^DIC S LRY=+Y Q:LRY>0 W " no '^' allowed"
I $D(LROUTINE) S LRY=LROUTINE
L3 ;
S LRY=+LRY,LRTEST(LRTSTN)=LRTEST(LRTSTN)_"^"_$S(LRY'=-1:LRY,1:$P(^LAB(69.9,1,3),U,2))
I $G(LRORIFN),$$VER^LR7OU1 S $P(LRTEST(LRTSTN),"^",7)=LRORIFN ;OE/RR 2.5
S LRCSN=0,LRSPEC=$S($D(LRSAME):+LRSAME,1:""),LRSAMP=$S($D(LRSAME):+$P(LRSAME,U,2),1:"")
K DIC,LRCS,LRCSX,H
W !,"For "_$P(^LAB(60,+LRTEST(LRTSTN),0),"^")_" "
I LRLWC="LC" S LRCSN=1,LRCS(1)=$P(^LAB(60,+LRTEST(LRTSTN),0),U,9),LRCSX(+LRCS(1))=1 G W18
S J=$O(^LAB(60,+LRTEST(LRTSTN),3,0)) G W12:J<1 S LRCSN=1,LRUNQ=+$P(^LAB(60,+LRTEST(LRTSTN),0),U,8),LRCS(1)=+^(3,J,0),LRCSX(+^(0))=1 S X=$P(^LAB(62,LRCS(LRCSN),0),U),X1=$P(^(0),U,3)
W:'$D(LRSAME)!LRUNQ X," ",X1
G W18:LRUNQ
G W18B:$D(LRSAME)
I LRCSN=1 W !,"Correct sample" S %=1 D YN^DICN G W18:%=1
S J=0 F S J=$O(^LAB(60,+LRTEST(LRTSTN),3,J)) Q:J<1 S:'$D(LRCSX(+^LAB(60,+LRTEST(LRTSTN),3,J,0))) LRCSN=LRCSN+1,LRCS(LRCSN)=+^(0),LRCSX(+^(0))=J
G W12:LRCSN<2
F I=1:1:LRCSN W !,I," ",$P(^LAB(62,LRCS(I),0),U)," ",$P(^(0),U,3)
R !,"Choose one: ",X:DTIME IF X?.N&(X>0)&(X<(LRCSN+1)) S LRCSN=+X W " ",$P(^LAB(62,LRCS(LRCSN),0),U) G W18
W12 K DUOUT,DTOUT S LRNEDC=1,DIC="^LAB(62,",DIC(0)="AEFMOQ" D ^DIC I $D(DUOUT)!$D(DTOUT) S LRTSTN=LRTSTN-1 G L2
G W12:Y<1 S LRCSN=1,LRCS(1)=+Y
W18 S (LRSPEC,Y)=$P(^LAB(62,+LRCS(LRCSN),0),U,2) I LRUNKNOW=+Y,'$D(LRLABKY) W !,"Unknown is not allowed." G W12
W18A I 'LRSPEC S DIC="^LAB(61,",DIC(0)="EMOQ",D="E" R !,"Select SITE/SPECIMEN: ",X:DTIME D IX^DIC:X="?" G W18A:X="?" D ^DIC K DIC I $D(DUOUT)!$D(DTOUT)!(X="") K DTOUT,DUOUT S LRTSTN=LRTSTN-1 G L2
I LRUNKNOW=+Y,'$D(LRLABKY) W !,"Unknown is not allowed." G W18
G W18:Y<1 S LRSPEC=+Y
MAX ;
S LRMAX1=0,LRMAX2=0 I $O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)) S LRMAX2=+$P(^LAB(60,LRTY,3,$O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,5) I LRMAX2 D NEW^LRORD2A I $D(LRDAX),%'["Y" S LRTSTN=LRTSTN-1 G L2
I 'LRMAX2,$D(TT(LRTY,LRSPEC)),$D(^LAB(60,LRTY,3,"B",+LRCS(LRCSN))) S LRMAX1=+$P(^LAB(60,LRTY,3,$O(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,7)
I 'LRMAX2,LRMAX1,$D(TT(LRTY,LRSPEC)) I TT(LRTY,LRSPEC)'<LRMAX1 D EN1^LRORDD K LRMAX1 I %'["Y" K LRTEST(LRTSTN) S LRTSTN=LRTSTN-1 G L2
W18B F I=0:0 S I=$O(T(LRTY,I)) Q:I="" Q:LRSPEC=T(LRTY,I)
I '$D(LRSAME) S (LRSAMP(LRTSTN),LRSAMP)=+LRCS(LRCSN),LRCSP=+$O(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
I $D(LRSAME) K LRCS S LRCSN=1,LRSAMP=+$P(LRSAME,U,2),LRSAMP(LRTSTN)=LRSAMP,LRCS(LRCSN)=LRSAMP,LRCSP=+$O(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
I $D(LRADDTST) N I,GOT D
. N LRODT,LRSN S (GOT,LRODT)=0 F S LRODT=$O(^LRO(69,"C",+LRADDTST,LRODT)) Q:LRODT<1 D Q:GOT
.. S LRSN=0 F S LRSN=$O(^LRO(69,"C",+LRADDTST,LRODT,LRSN)) Q:LRSN<1 D Q:GOT
... I $P($G(^LRO(69,LRODT,1,LRSN,0)),"^",3)=+LRSAMP,$D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTEST(LRTSTN))) S I=$O(^(+LRTEST(LRTSTN),0)) I I,$D(^LRO(69,LRODT,1,LRSN,2,I,0)),'$P(^(0),"^",11) D
.... W !!,$C(7),"<<DUPLICATE TEST NOT ALLOWED>>",!?5,$P(^LAB(60,+LRTEST(LRTSTN),0),"^")_" has already been requested on this order.",!! K LRTEST(LRTSTN) S LRTSTN=LRTSTN-1,GOT=1 Q
I $D(LRADDTST),$G(GOT) G L2
I '$D(LRLABKY) S DIC="^LAB(60,",DA=+LRTEST(LRTSTN),DR=6 D EN^DIQ S DIC="WARD REMARKS: " S DR=0 F S DR=$O(^LAB(60,DA,3,LRCSP,1,DR)) Q:DR'>0 W !," ",DIC,^(DR,0) S DIC=""
G ^LROW1A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROW1 4066 printed Dec 13, 2024@02:19:07 Page 2
LROW1 ;SLC/CJS - TEST & SAMP ;8/11/97
+1 ;;5.2;LAB SERVICE;**55,100,121,128**;Sep 27, 1994
+2 KILL LRSAME,DIC,LRTEST,LRSAMP,LRXST,LRCCOM,LRGCOM
SET LRTSTN=0
if '$DATA(LRCOM)
SET LRCOM=0
L2 ;LRNN=1 when coming from LRFAST
KILL LRNEDC,LROUT
if '$GET(LRNN)
KILL LRURG
+1 SET DIC="^LAB(60,"
SET DIC(0)="AEMOQ"
SET DIC("S")="I $L($P(^(0),U,4)),""BI""[$P(^(0),U,3)"
if LRLWC="LC"!(LRLWC="I")
SET DIC("S")=DIC("S")_",$P(^(0),U,9)"
+2 DO ^DIC
if X="^^"
SET DIROUT=1
if Y<1&$DATA(LRADDTST)
SET LRADDTST=LRADDTST_"^OUT"
if Y<1
QUIT
SET LRTY=+Y
NOASK ;from LROR
+1 SET LRTSTN=LRTSTN+1
SET LRTEST(LRTSTN)=LRTY
SET LRY=$SELECT($DATA(LRURG):+LRURG,1:$PIECE(^LAB(60,LRTY,0),U,18))
SET H=+$PIECE(^(0),U,16)
if LRY
GOTO L3
+2 IF '$DATA(LROUTINE)
KILL DIC
SET DIC="^LAB(62.05,"
SET DIC(0)="AEQF"
SET DIC("B")="ROUTINE"
SET DIC("S")="I '$P(^(0),U,3),Y'<"_H
if LRLWC="LC"
SET DIC("S")=DIC("S")_" I $P(^(0),U,2)"
FOR I=0:0
DO ^DIC
SET LRY=+Y
if LRY>0
QUIT
WRITE " no '^' allowed"
+3 IF $DATA(LROUTINE)
SET LRY=LROUTINE
L3 ;
+1 SET LRY=+LRY
SET LRTEST(LRTSTN)=LRTEST(LRTSTN)_"^"_$SELECT(LRY'=-1:LRY,1:$PIECE(^LAB(69.9,1,3),U,2))
+2 ;OE/RR 2.5
IF $GET(LRORIFN)
IF $$VER^LR7OU1
SET $PIECE(LRTEST(LRTSTN),"^",7)=LRORIFN
+3 SET LRCSN=0
SET LRSPEC=$SELECT($DATA(LRSAME):+LRSAME,1:"")
SET LRSAMP=$SELECT($DATA(LRSAME):+$PIECE(LRSAME,U,2),1:"")
+4 KILL DIC,LRCS,LRCSX,H
+5 WRITE !,"For "_$PIECE(^LAB(60,+LRTEST(LRTSTN),0),"^")_" "
+6 IF LRLWC="LC"
SET LRCSN=1
SET LRCS(1)=$PIECE(^LAB(60,+LRTEST(LRTSTN),0),U,9)
SET LRCSX(+LRCS(1))=1
GOTO W18
+7 SET J=$ORDER(^LAB(60,+LRTEST(LRTSTN),3,0))
if J<1
GOTO W12
SET LRCSN=1
SET LRUNQ=+$PIECE(^LAB(60,+LRTEST(LRTSTN),0),U,8)
SET LRCS(1)=+^(3,J,0)
SET LRCSX(+^(0))=1
SET X=$PIECE(^LAB(62,LRCS(LRCSN),0),U)
SET X1=$PIECE(^(0),U,3)
+8 if '$DATA(LRSAME)!LRUNQ
WRITE X," ",X1
+9 if LRUNQ
GOTO W18
+10 if $DATA(LRSAME)
GOTO W18B
+11 IF LRCSN=1
WRITE !,"Correct sample"
SET %=1
DO YN^DICN
if %=1
GOTO W18
+12 SET J=0
FOR
SET J=$ORDER(^LAB(60,+LRTEST(LRTSTN),3,J))
if J<1
QUIT
if '$DATA(LRCSX(+^LAB(60,+LRTEST(LRTSTN),3,J,0)))
SET LRCSN=LRCSN+1
SET LRCS(LRCSN)=+^(0)
SET LRCSX(+^(0))=J
+13 if LRCSN<2
GOTO W12
+14 FOR I=1:1:LRCSN
WRITE !,I," ",$PIECE(^LAB(62,LRCS(I),0),U)," ",$PIECE(^(0),U,3)
+15 READ !,"Choose one: ",X:DTIME
IF X?.N&(X>0)&(X<(LRCSN+1))
SET LRCSN=+X
WRITE " ",$PIECE(^LAB(62,LRCS(LRCSN),0),U)
GOTO W18
W12 KILL DUOUT,DTOUT
SET LRNEDC=1
SET DIC="^LAB(62,"
SET DIC(0)="AEFMOQ"
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
SET LRTSTN=LRTSTN-1
GOTO L2
+1 if Y<1
GOTO W12
SET LRCSN=1
SET LRCS(1)=+Y
W18 SET (LRSPEC,Y)=$PIECE(^LAB(62,+LRCS(LRCSN),0),U,2)
IF LRUNKNOW=+Y
IF '$DATA(LRLABKY)
WRITE !,"Unknown is not allowed."
GOTO W12
W18A IF 'LRSPEC
SET DIC="^LAB(61,"
SET DIC(0)="EMOQ"
SET D="E"
READ !,"Select SITE/SPECIMEN: ",X:DTIME
if X="?"
DO IX^DIC
if X="?"
GOTO W18A
DO ^DIC
KILL DIC
IF $DATA(DUOUT)!$DATA(DTOUT)!(X="")
KILL DTOUT,DUOUT
SET LRTSTN=LRTSTN-1
GOTO L2
+1 IF LRUNKNOW=+Y
IF '$DATA(LRLABKY)
WRITE !,"Unknown is not allowed."
GOTO W18
+2 if Y<1
GOTO W18
SET LRSPEC=+Y
MAX ;
+1 SET LRMAX1=0
SET LRMAX2=0
IF $ORDER(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0))
SET LRMAX2=+$PIECE(^LAB(60,LRTY,3,$ORDER(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,5)
IF LRMAX2
DO NEW^LRORD2A
IF $DATA(LRDAX)
IF %'["Y"
SET LRTSTN=LRTSTN-1
GOTO L2
+2 IF 'LRMAX2
IF $DATA(TT(LRTY,LRSPEC))
IF $DATA(^LAB(60,LRTY,3,"B",+LRCS(LRCSN)))
SET LRMAX1=+$PIECE(^LAB(60,LRTY,3,$ORDER(^LAB(60,LRTY,3,"B",+LRCS(LRCSN),0)),0),U,7)
+3 IF 'LRMAX2
IF LRMAX1
IF $DATA(TT(LRTY,LRSPEC))
IF TT(LRTY,LRSPEC)'<LRMAX1
DO EN1^LRORDD
KILL LRMAX1
IF %'["Y"
KILL LRTEST(LRTSTN)
SET LRTSTN=LRTSTN-1
GOTO L2
W18B FOR I=0:0
SET I=$ORDER(T(LRTY,I))
if I=""
QUIT
if LRSPEC=T(LRTY,I)
QUIT
+1 IF '$DATA(LRSAME)
SET (LRSAMP(LRTSTN),LRSAMP)=+LRCS(LRCSN)
SET LRCSP=+$ORDER(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
+2 IF $DATA(LRSAME)
KILL LRCS
SET LRCSN=1
SET LRSAMP=+$PIECE(LRSAME,U,2)
SET LRSAMP(LRTSTN)=LRSAMP
SET LRCS(LRCSN)=LRSAMP
SET LRCSP=+$ORDER(^LAB(60,+LRTEST(LRTSTN),3,"B",+LRSAMP,0))
+3 IF $DATA(LRADDTST)
NEW I,GOT
Begin DoDot:1
+4 NEW LRODT,LRSN
SET (GOT,LRODT)=0
FOR
SET LRODT=$ORDER(^LRO(69,"C",+LRADDTST,LRODT))
if LRODT<1
QUIT
Begin DoDot:2
+5 SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",+LRADDTST,LRODT,LRSN))
if LRSN<1
QUIT
Begin DoDot:3
+6 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",3)=+LRSAMP
IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",+LRTEST(LRTSTN)))
SET I=$ORDER(^(+LRTEST(LRTSTN),0))
IF I
IF $DATA(^LRO(69,LRODT,1,LRSN,2,I,0))
IF '$PIECE(^(0),"^",11)
Begin DoDot:4
+7 WRITE !!,$CHAR(7),"<<DUPLICATE TEST NOT ALLOWED>>",!?5,$PIECE(^LAB(60,+LRTEST(LRTSTN),0),"^")_" has already been requested on this order.",!!
KILL LRTEST(LRTSTN)
SET LRTSTN=LRTSTN-1
SET GOT=1
QUIT
End DoDot:4
End DoDot:3
if GOT
QUIT
End DoDot:2
if GOT
QUIT
End DoDot:1
+8 IF $DATA(LRADDTST)
IF $GET(GOT)
GOTO L2
+9 IF '$DATA(LRLABKY)
SET DIC="^LAB(60,"
SET DA=+LRTEST(LRTSTN)
SET DR=6
DO EN^DIQ
SET DIC="WARD REMARKS: "
SET DR=0
FOR
SET DR=$ORDER(^LAB(60,DA,3,LRCSP,1,DR))
if DR'>0
QUIT
WRITE !," ",DIC,^(DR,0)
SET DIC=""
+10 GOTO ^LROW1A
