- 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
