LROE2 ;DALISC/FHS - CONTINUED MORE ORDER ENTRY ;8/11/97
;;5.2;LAB SERVICE;**121,424,444**;Sep 27, 1994;Build 5
;Formerly apart of LROE1
Q15 ;from LROE1
Q:'$D(^LRO(69,LRODT,1,LRSN,0))
I $D(^LRO(69,LRODT,1,LRSN,1)),$P(^(1),"^",4)="U" W !,"This specimen has already been marked as UNCOLLECTED. Are you sure" S %=2 D YN^DICN Q:%'=1 S ^(1)=LRTIM_"^^"_DUZ,DA=LRSN,DA(1)=LRODT,DIE="^LRO(69,"_DA(1)_",1,",DR=16 D ^DIE
I M9>1 D LRSPEC^LROE1 S S1=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),S2=$P(^LAB(62,LRSAMP,0),U),S4=$P(^(0),U,3),S3=S1_$S(S1'=S2:" "_S2,1:"") W !,"Do you have the ",S3," ",S4 K S1,S2,S3,S4 S %=2 D YN^DICN G Q15:%=0 Q:%'=1
S DA=DT,LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRDPF=+$P(^LR(LRDFN,0),U,2)
IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT I '$D(LRSND) D P15^LROE1 Q:LRCDT<1
I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15^LRPHITEM G PH
I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_DUZ_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
PH G Q16:LRORD D ORDER^LROW2 G Q16A
Q16 S J=0 D CHECK^LROW2 I J D BAD^LROW2
Q16A I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
K DR S LRTSTS=0
S LRSN=0 F S LRSN=$O(LRSN(LRSN)) Q:'LRSN D Q17
I $D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5)
Q
Q17 S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^(1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^(J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D EN^DIQ:I D LRSPEC^LROE1
D OLD^LRORDST K ^TMP("LR",$J,"TMP")
S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2),^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROE2 2003 printed Oct 16, 2024@18:19:16 Page 2
LROE2 ;DALISC/FHS - CONTINUED MORE ORDER ENTRY ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,424,444**;Sep 27, 1994;Build 5
+2 ;Formerly apart of LROE1
Q15 ;from LROE1
+1 if '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+2 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^(1),"^",4)="U"
WRITE !,"This specimen has already been marked as UNCOLLECTED. Are you sure"
SET %=2
DO YN^DICN
if %'=1
QUIT
SET ^(1)=LRTIM_"^^"_DUZ
SET DA=LRSN
SET DA(1)=LRODT
SET DIE="^LRO(69,"_DA(1)_",1,"
SET DR=16
DO ^DIE
+3 IF M9>1
DO LRSPEC^LROE1
SET S1=$SELECT($DATA(^LAB(61,+LRSPEC,0)):$PIECE(^(0),U),1:"")
SET S2=$PIECE(^LAB(62,LRSAMP,0),U)
SET S4=$PIECE(^(0),U,3)
SET S3=S1_$SELECT(S1'=S2:" "_S2,1:"")
WRITE !,"Do you have the ",S3," ",S4
KILL S1,S2,S3,S4
SET %=2
DO YN^DICN
if %=0
GOTO Q15
if %'=1
QUIT
+4 SET DA=DT
SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
SET LRDPF=+$PIECE(^LR(LRDFN,0),U,2)
+5 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
SET LRSTATUS="C"
SET DA=LRODT
IF '$DATA(LRSND)
DO P15^LROE1
if LRCDT<1
QUIT
+6 IF $DATA(LRSND)
IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)="LC"
IF $DATA(^(1))
SET LRLLOC=$PIECE(^(0),U,7)
SET LROLLOC=$PIECE(^(0),U,9)
SET LRNT=$SELECT($DATA(LRNT):LRNT,$DATA(LRTIM):LRTIM,$DATA(LRCDT):+LRCDT,1:"")
DO P15^LRPHITEM
GOTO PH
+7 IF $DATA(LRSND)
NEW COMB
SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
SET ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_DUZ_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
if LRSTATUS="C"
SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
PH if LRORD
GOTO Q16
DO ORDER^LROW2
GOTO Q16A
Q16 SET J=0
DO CHECK^LROW2
IF J
DO BAD^LROW2
Q16A IF $DATA(LRLONG)
IF $DATA(LRSND)
SET LRSN=LRSND
SET ^TMP("LROE",$JOB,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
+1 KILL DR
SET LRTSTS=0
+2 SET LRSN=0
FOR
SET LRSN=$ORDER(LRSN(LRSN))
if 'LRSN
QUIT
DO Q17
+3 IF $DATA(LRLONG)
IF $DATA(LRSND)
SET LRSN=LRSND
DO LROE^LRFAST
SET X=^TMP("LROE",$JOB,"LRORD")
SET LRORD=+X
SET LRODT=$PIECE(X,"^",2)
SET LRTIM=$PIECE(X,"^",3)
SET LRLONG=""
SET PNM=$PIECE(X,"^",4)
SET SSN=$PIECE(X,"^",5)
+4 QUIT
Q17 SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,0))
SET J=$ORDER(^(1))
if '$DATA(IOM)
SET IOM=80
KILL LRSPCDSC
if J
SET LRSPCDSC=^(J,0)
if I
SET DA=LRSN
SET DA(1)=LRODT
SET DR=6
SET DIC="^LRO(69,"_LRODT_",1,"
if I
DO EN^DIQ
DO LRSPEC^LROE1
+1 DO OLD^LRORDST
KILL ^TMP("LR",$JOB,"TMP")
+2 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="C"
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2)
SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+3 QUIT
