LROW2 ;VA/SLC/CJS - TEST & SAMPLE VERIFICATION ;8/11/97
;;5.2;LR;**1003,1011,1013,1015,1018,1019,1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 121,290
;
COL S $P(^LRO(69,LRODT,1,LRSN,0),U,2)=DUZ
Q
;
REST ;from LRFAST, LROE1, LROW
I '$D(LRNCWL),'$D(LRORDER) K %ZIS S IOP="P",%ZIS="N" D ^%ZIS K %ZIS,IOP S:'POP LRORDER=ION I POP S %ZIS="NQ",%ZIS("A")="ORDER COPY DEVICE:" D ^%ZIS S:'POP LRORDER=ION I POP S IOP="HOME" D ^%ZIS
S LRLLOC=$P(LRSNO,U,7),LRSSP=-1
I $D(LRADDTST) S LRORD=+LRADDTST,LRADDTST="" G PAST
D ORDER
;
PAST ; EP
S J=0 D CHECK:$D(LRADDTST) G BAD:J K LRXS S LRCS=0 F J=0:0 S LRCS=$O(LRXST(LRCS)) Q:LRCS<1 S T=0 F S T=$O(LRXST(LRCS,T)) Q:T<1 S LRXS(LRCS,LRXST(LRCS,T),T)=""
S LRSSP=0 F S LRSSP=$O(LRXS(LRSSP)) Q:LRSSP<1 S LRSPEC=0 F S LRSPEC=$O(LRXS(LRSSP,LRSPEC)) Q:LRSPEC<1 D DUP^LROW2A
W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
D:'$D(ZTQUEUED) ASKATORD^BLRAAORU(LRORD)
; ----- END IHS/OIT/MKK - LR*5.2*1030
Q
;
ORDER ;from LRMIBL, LROE1, LRORD1, LRQCLOG
N LRYR
S LRYR=$E(DT,1,3)_"0000" I '$D(^LRO(69,LRYR,2)) S ^LRO(69,LRYR,0)=LRYR,^(2)=0,^LRO(69,"B",LRYR,LRYR)="" ;HAPPY NEW YEAR!
;
NEXT ; EP
L +^LRO(69,LRYR,2) S LRORD=1+^LRO(69,LRYR,2) F Q:'$D(^LRO(69,"C",LRORD)) S LRORD=LRORD+1
S ^LRO(69,LRYR,2)=LRORD L -^LRO(69,LRYR,2)
S J=0 D CHECK G NEXT:J
Q:$G(LRQUIET)
W:'$D(ZTQUEUED) !,"LAB Order number: ",LRORD
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
CHECK ;from LROE1
S D=0 F S D=$O(^LRO(69,"C",LRORD,D)) Q:D<1 D C2
Q
;
C2 S S=0 F S S=$O(^LRO(69,"C",LRORD,D,S)) Q:S<1 I $D(^LRO(69,D,1,S,0)),LRDFN'=+^(0) S J=1 Q
Q
;
BAD ;from LROE1
W !,"The ORDER NUMBER is in use, contact the site manager.",$C(7),!,"This order has been CANCELED, you will need to re-order.",! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
Q
;
DUPL ;from LROW1
S LREND=1 W !,"Since this test, collection sample, and site/specimen has already",!,"been requested on this order, it will NOT be duplicated.",$C(7),!,"If you really need a duplicate, place a separate order."
Q
;
TCOM ;from LROW1
S LRCCOM="~For Test: "_$P(^LAB(60,+LRTEST(LRTSTN),0),U)_" "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_" "_$P(^LAB(61,LRSPEC,0),U) W !,LRCCOM
D RCS^LRORD2
Q
;
% R %:DTIME S:'$T DTOUT=1 Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
;
OR ;OE/RR 2.5
; Q ;Following logic not required - 2.5 is obsolete version
Q:$$VER^LR7OU1>2.5 ; Some RPMS sites may be at 2.5 -- IHS/MSC/MKK - LR*5.2*1031
;
S LRORIFN=$P(LRTEST(LRI),"^",7) I 'LRORIFN D SET^LROR S $P(LRTEST(LRI),"^",7)=LRORIFN Q
S ORIFN=LRORIFN,ORETURN("ORPK")=LRODT_"^"_LRSN_"^"_LRTN D RETURN^ORX:ORIFN
Q
LROW2 ;VA/SLC/CJS - TEST & SAMPLE VERIFICATION ;8/11/97
+1 ;;5.2;LR;**1003,1011,1013,1015,1018,1019,1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 121,290
+4 ;
COL SET $PIECE(^LRO(69,LRODT,1,LRSN,0),U,2)=DUZ
+1 QUIT
+2 ;
REST ;from LRFAST, LROE1, LROW
+1 IF '$DATA(LRNCWL)
IF '$DATA(LRORDER)
KILL %ZIS
SET IOP="P"
SET %ZIS="N"
DO ^%ZIS
KILL %ZIS,IOP
IF 'POP
SET LRORDER=ION
IF POP
SET %ZIS="NQ"
SET %ZIS("A")="ORDER COPY DEVICE:"
DO ^%ZIS
IF 'POP
SET LRORDER=ION
IF POP
SET IOP="HOME"
DO ^%ZIS
+2 SET LRLLOC=$PIECE(LRSNO,U,7)
SET LRSSP=-1
+3 IF $DATA(LRADDTST)
SET LRORD=+LRADDTST
SET LRADDTST=""
GOTO PAST
+4 DO ORDER
+5 ;
PAST ; EP
+1 SET J=0
IF $DATA(LRADDTST)
DO CHECK
IF J
GOTO BAD
KILL LRXS
SET LRCS=0
FOR J=0:0
SET LRCS=$ORDER(LRXST(LRCS))
IF LRCS<1
QUIT
SET T=0
FOR
SET T=$ORDER(LRXST(LRCS,T))
IF T<1
QUIT
SET LRXS(LRCS,LRXST(LRCS,T),T)=""
+2 SET LRSSP=0
FOR
SET LRSSP=$ORDER(LRXS(LRSSP))
IF LRSSP<1
QUIT
SET LRSPEC=0
FOR
SET LRSPEC=$ORDER(LRXS(LRSSP,LRSPEC))
IF LRSPEC<1
QUIT
DO DUP^LROW2A
+3 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+4 ;
+5 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+6 IF '$DATA(ZTQUEUED)
DO ASKATORD^BLRAAORU(LRORD)
+7 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+8 QUIT
+9 ;
ORDER ;from LRMIBL, LROE1, LRORD1, LRQCLOG
+1 NEW LRYR
+2 ;HAPPY NEW YEAR!
SET LRYR=$EXTRACT(DT,1,3)_"0000"
IF '$DATA(^LRO(69,LRYR,2))
SET ^LRO(69,LRYR,0)=LRYR
SET ^(2)=0
SET ^LRO(69,"B",LRYR,LRYR)=""
+3 ;
NEXT ; EP
+1 LOCK +^LRO(69,LRYR,2)
SET LRORD=1+^LRO(69,LRYR,2)
FOR
IF '$DATA(^LRO(69,"C",LRORD))
QUIT
SET LRORD=LRORD+1
+2 SET ^LRO(69,LRYR,2)=LRORD
LOCK -^LRO(69,LRYR,2)
+3 SET J=0
DO CHECK
IF J
GOTO NEXT
+4 IF $GET(LRQUIET)
QUIT
+5 IF '$DATA(ZTQUEUED)
WRITE !,"LAB Order number: ",LRORD
+6 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+8 ;
CHECK ;from LROE1
+1 SET D=0
FOR
SET D=$ORDER(^LRO(69,"C",LRORD,D))
IF D<1
QUIT
DO C2
+2 QUIT
+3 ;
C2 SET S=0
FOR
SET S=$ORDER(^LRO(69,"C",LRORD,D,S))
IF S<1
QUIT
IF $DATA(^LRO(69,D,1,S,0))
IF LRDFN'=+^(0)
SET J=1
QUIT
+1 QUIT
+2 ;
BAD ;from LROE1
+1 WRITE !,"The ORDER NUMBER is in use, contact the site manager.",$CHAR(7),!,"This order has been CANCELED, you will need to re-order.",!
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+2 QUIT
+3 ;
DUPL ;from LROW1
+1 SET LREND=1
WRITE !,"Since this test, collection sample, and site/specimen has already",!,"been requested on this order, it will NOT be duplicated.",$CHAR(7),!,"If you really need a duplicate, place a separate order."
+2 QUIT
+3 ;
TCOM ;from LROW1
+1 SET LRCCOM="~For Test: "_$PIECE(^LAB(60,+LRTEST(LRTSTN),0),U)_" "_$PIECE(^LAB(62,LRSAMP,0),U)
IF $PIECE(^(0),U)'=$PIECE(^LAB(61,LRSPEC,0),U)
SET LRCCOM=LRCCOM_" "_$PIECE(^LAB(61,LRSPEC,0),U)
WRITE !,LRCCOM
+2 DO RCS^LRORD2
+3 QUIT
+4 ;
% READ %:DTIME
IF '$TEST
SET DTOUT=1
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 ;
OR ;OE/RR 2.5
+1 ; Q ;Following logic not required - 2.5 is obsolete version
+2 ; Some RPMS sites may be at 2.5 -- IHS/MSC/MKK - LR*5.2*1031
IF $$VER^LR7OU1>2.5
QUIT
+3 ;
+4 SET LRORIFN=$PIECE(LRTEST(LRI),"^",7)
IF 'LRORIFN
DO SET^LROR
SET $PIECE(LRTEST(LRI),"^",7)=LRORIFN
QUIT
+5 SET ORIFN=LRORIFN
SET ORETURN("ORPK")=LRODT_"^"_LRSN_"^"_LRTN
IF ORIFN
DO RETURN^ORX
+6 QUIT
