LROE ;DALOI/CJS/FHS-LAB ORDER ENTRY AND ACCESSION ;8/11/97
;;5.2;LAB SERVICE;**1003,100,121,1006,201,1013,221,1018,1021,263,1027,286,360,1031,423,1034,1035,1036,1038,432,1039**;NOV 01, 1997;Build 32
;;5.2;LAB SERVICE;**100,121,201,221,263,286,360,423,432**;Sep 27, 1994;Build 2
;
K LRORIFN,LRNATURE,LREND,LRORDRR
S LRLWC="WC"
D ^LRPARAM
I $G(LREND) S LREND=0 Q
L5 ;
NEXT ;from LROE1
K DIR
I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
I '$D(^LRO(69,DT,1,0)) S ^LRO(69,DT,0)=DT,^LRO(69,DT,1,0)="^69.01PA^^",^LRO(69,"B",DT,DT)=""
I $D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D
. W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
. S DIR("A")=" Are you sure you want to continue",DIR(0)="Y",DIR("B")="No"
I $T D ^DIR G END:$D(DIRUT) I Y'=1 W !,"OK, try later." Q
S X="T-7",%DT="" D ^%DT S LRTM7=+Y
;W @IOF
D BLRRL ; IHS/cmi/maw 9/9/2004 added check for ship manifest
K DIC,LRSND,LRSN
W !!,"Select Order number: " R LRORD:DTIME Q:LRORD["^"!(LRORD[".")!($D(LRLONG)&(LRORD=""))
W @IOF S M9=0 G QUICK^LROE1:LRORD=""
I $L(LRORD)>8 W !,"The order number entered is too long." H 1 G NEXT
S:LRORD?.N LRORD=+LRORD IF LRORD'?.N D QMSG G NEXT
I '$D(^LRO(69,"C",LRORD)) W !!?10,"No order exist with that number ",$C(7),! G NEXT
S (LRCHK,LRNONE)=1,(M9,LRODT)=0
F S LRODT=+$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S DA=0 F S DA=$O(^LRO(69,"C",LRORD,LRODT,DA)) Q:DA<1 S LRCHK=LRCHK-1 S:LRNONE'=2 LRNONE=0 D LROE2
I DOD'="" S Y=DOD D DD^LRX W !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF W !
I DOD'="" D I Y=0!($D(DIRUT)) K DIRUT,DTOUT,DUOUT,Y D KVAR^LRX G NEXT
. K Y
. S DIR(0)="Y"
. S DIR("A")="Do you wish to continue with this accession [Yes/No]"
. S DIR("T")=120
. D ^DIR K DIR
I LRNONE=2,LRCHK<1 W !,"The order has already been partially accessioned." H 1
I LRNONE=2,LRCHK>0 W !,"The order has already been accessioned." H 1 G NEXT
I LRNONE=1 W !,"No order exists with that number." H 1 G NEXT
I '$$GOT(LRORD,LRODT) G NEXT ;W !!,"All tests for this order have been canceled.",!,"Are you sure you want to accession it" S %=1 D YN^DICN I %'=1 G NEXT
K DIR S DIR("A")="Is this the correct order",DIR(0)="Y"
S DIR("B")="Yes"
D ^DIR K DIR
I $D(DIRUT)!(Y'=1) K LRSN G NEXT
L +^LRO(69,"C",LRORD):$G(DILOCKTM,3)
I '$T W !?5,"Someone else is editing this Order",!!,$C(7) G NEXT
K %DT
S LRSTATUS="C",%DT("B")=""
D TIME K %DT
D:$G(LRCDT)<1 UNL69 G NEXT:LRCDT<1
S LRTIM=+LRCDT
;S:'$P(^LRO(69,LRODT,1,LRSN,0),U,8) $P(^(0),U,8)=LRTIM
S LRUN=$P(LRCDT,U,2) K LRCDT,LRSN
MORE I M9>1 K DIR S DIR("A")="Do you have the entire order",DIR(0)="Y" D ^DIR K DIR S:Y=1 M9=0
I $D(DIRUT) D UNL69 G NEXT
S YYYLRORD=LRORD ; IHS/OIT/MKK - LR*5.2*1030
S (LRODT,LRSND)=0
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S LRSND=0
. F S LRSND=$O(^LRO(69,"C",LRORD,LRODT,LRSND)) Q:LRSND<1 D
. . I $D(^LRO(69,LRODT,1,LRSND,1)),$P(^(1),U,4)="C" Q
. . S LRSN(LRSND)=LRSND,LRSN=LRSND
. . K LRAA D Q15^LROE2 K LRSN
D TASK,UNL69
D ORDNSTOR^BLRAAORU(YYYLRORD) K YYYLRORD ; IHS/OIT/MKK - LR*5.2*1030 - Store Ask-At-Order Questions
G NEXT
;
;
LROE2 ;
I '$D(^LRO(69,LRODT,1,DA,0)) Q
I $D(^LRO(69,LRODT,1,DA,1)) D
. I $P(^LRO(69,LRODT,1,DA,1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1 Q
. I $P(^LRO(69,LRODT,1,DA,0),U,4)="LC",$P(^LRO(69,LRODT,1,DA,1),U,4)="" S LRNONE=2,LRCHK=LRCHK+1
;
K LRSN
S (LRSN,LRSN(DA))=+DA
I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
; S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
S M9=$G(M9)+1
S LRZX=$G(^LRO(69,LRODT,1,LRSN,0))
S LRDFN=+LRZX
S LRDPF=$P($G(^LR(LRDFN,0)),U,2),DFN=$P($G(^(0)),U,3)
D PT^LRX
W !,PNM,?30,HRCN
S LRWRDS=LRWRD
;----- END IHS MODIFICATIONS LR*5.2*1027
;
W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
Q
;
;
QMSG W !,"Enter the order entry number assigned when the test was ordered."
W:'$D(LRLONG) !,"If the test has not been ordered, type the RETURN key to order the test."
W !,"To exit, type the ""^"" key and RETURN key."
Q
;
;
YN R X:DTIME S:'$T DTOUT=1 Q:X=""!(X["N")!(X["Y")
W !,"Answer 'Y' or 'N': " G YN
;
;
EN ;
LROEN S LRNCWL=1
D LROE,END K LRNCWL
Q
;
;
EN01 ; ENTER ORDER # THEN ENTER DATA
STAT ;
D ^LRPARAM
I '$D(LRLABKY) W !!?10,"You do not have the proper security Keys",! Q
;
; Select peforming laboratory
S X=$$SELPL^LRVERA(DUZ(2))
I X<1 D END Q
I X'=DUZ(2) N LRPL S LRPL=X
;
S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ACCORD",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/1/97
;
S LRLONG="",LRPANEL=0,LROESTAT=""
S %H=$H-60 D YMD^LRX S LRTM60=9999999-X
D LROE K LRTM60,LRLONG,LREND,LROESTAT
D END
Q
;
;
TIME ;from LROE1, LRORD1
; S %DT="SET" W !,"Collection Date@Time: ",$S($D(%DT("B")):%DT("B"),1:"NOW"),"//" R X:DTIME I '$T!(X="^") S LRCDT=-1 Q
; S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
I $P(XQY0,U)="LRQUICK" D
. S %DT="SET" W !,"Collection Date@Time: " R X:DTIME I '$T!(X="^")!(X="") S LRCDT=-1
I $P(XQY0,U)'="LRQUICK" D
. S %DT="SET" W !,"Collection Date@Time: ",$S($D(%DT("B")):%DT("B"),1:"NOW"),"//" R X:DTIME I '$T!(X="^") S LRCDT=-1 Q
. S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
I $G(LRCDT)<0 Q
S X=$$UP^XLFSTR(X)
I $E($G(X))'["N",$G(X)'["U",$G(X)'["@" W !!,?4,"Need Time also." G TIME
; ----- END IHS/MSC/MKK - LR*5.2*1038
;
W:X["?" !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
I X["@U",$P(X,"@U",2)="" S X=$P(X,"@U",1) D ^%DT G TIME:Y<1 S LRCDT=+Y_"^1" Q
S:X="U" LRCDT=DT_"^1"
I X'="U" D ^%DT D:X'["?" TIME1 G TIME:X["?" S LRCDT=+Y_"^" G TIME:Y'["."
Q
;
TIME1 S X1=X,Y1=Y D TIME2 S X=X1,Y=Y1 K X1,Y1
Q
;
TIME2 S X="N",%DT="ST" D ^%DT Q:Y1'>Y F W !,"You have specified a collection time in the future. Are you sure" S %=2 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o."
S:%'=1 X="?" S X1=X
Q
;
;
TASK ;
I $D(LRLABLIO),$D(LRLBL) S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")="" D ^%ZTLOAD
K LRLBL
I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ),LRCSQ
I $D(LRCSQ),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
Q
;
;
END K DIR,DIRUT,GOT
D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
Q
;
;
GOT(ORD,ODT) ;See if all tests have been canceled
N I,SN,ODT
S (GOT,ODT,SN)=0
F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 D
. S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT) D
. . Q:'$D(^LRO(69,ODT,1,SN,0))
. . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
Q GOT
;
;
UNL69 ;
L -^LRO(69,"C",+$G(LRORD))
Q
;
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
;cmi/anch/maw REF LAB
;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
K BLRINS,BLRDXS ;cmi/7/1/2010 reference lab ledi variables
K BLRASFLG ;P1034
Q:$G(BLRGUI)
Q:'$G(^BLRSITE(DUZ(2),"RL")) ;reference lab not set up
Q:$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
;I $D(^TMP("BLRRL",$J)) D
I $G(LRORD),$O(^BLRRLO("B",LRORD,0)) D ;p1034
. N OI
. S OI=$O(^BLRRLO("B",LRORD,0))
. Q:'$D(^BLRRLO(OI,3,0)) ;not accessioned yet
. ;W !,"Printing Shipping Manifests for Reference Lab..." ;1036 moved to BLRRLEVN
. ;D PRT^BLRSHPM
. D SHIPMAN^BLRRLEVN(LRORD,0,0) ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
K BLRINS,BLRASFLG,BLRDXS ;p1035
Q
;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021
LROE ;DALOI/CJS/FHS-LAB ORDER ENTRY AND ACCESSION ;8/11/97
+1 ;;5.2;LAB SERVICE;**1003,100,121,1006,201,1013,221,1018,1021,263,1027,286,360,1031,423,1034,1035,1036,1038,432,1039**;NOV 01, 1997;Build 32
+2 ;;5.2;LAB SERVICE;**100,121,201,221,263,286,360,423,432**;Sep 27, 1994;Build 2
+3 ;
+4 KILL LRORIFN,LRNATURE,LREND,LRORDRR
+5 SET LRLWC="WC"
+6 DO ^LRPARAM
+7 IF $GET(LREND)
SET LREND=0
QUIT
L5 ;
NEXT ;from LROE1
+1 KILL DIR
+2 IF $DATA(LROESTAT)
IF $PIECE(LRPARAM,U,14)
DO ^LRCAPV
IF $GET(LREND)
KILL LRLONG,LRPANEL
QUIT
+3 SET (LRODT,X,DT)=$$DT^XLFDT()
SET LRODT0=$$FMTE^XLFDT(DT,5)
+4 IF '$DATA(^LRO(69,DT,1,0))
SET ^LRO(69,DT,0)=DT
SET ^LRO(69,DT,1,0)="^69.01PA^^"
SET ^LRO(69,"B",DT,DT)=""
+5 IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=+$PIECE(^("RO"),U)
Begin DoDot:1
+6 WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!
+7 SET DIR("A")=" Are you sure you want to continue"
SET DIR(0)="Y"
SET DIR("B")="No"
End DoDot:1
+8 IF $TEST
DO ^DIR
IF $DATA(DIRUT)
GOTO END
IF Y'=1
WRITE !,"OK, try later."
QUIT
+9 SET X="T-7"
SET %DT=""
DO ^%DT
SET LRTM7=+Y
+10 ;W @IOF
+11 ; IHS/cmi/maw 9/9/2004 added check for ship manifest
DO BLRRL
+12 KILL DIC,LRSND,LRSN
+13 WRITE !!,"Select Order number: "
READ LRORD:DTIME
IF LRORD["^"!(LRORD[".")!($DATA(LRLONG)&(LRORD=""))
QUIT
+14 WRITE @IOF
SET M9=0
IF LRORD=""
GOTO QUICK^LROE1
+15 IF $LENGTH(LRORD)>8
WRITE !,"The order number entered is too long."
HANG 1
GOTO NEXT
+16 IF LRORD?.N
SET LRORD=+LRORD
IF LRORD'?.N
DO QMSG
GOTO NEXT
+17 IF '$DATA(^LRO(69,"C",LRORD))
WRITE !!?10,"No order exist with that number ",$CHAR(7),!
GOTO NEXT
+18 SET (LRCHK,LRNONE)=1
SET (M9,LRODT)=0
+19 FOR
SET LRODT=+$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+20 SET DA=0
FOR
SET DA=$ORDER(^LRO(69,"C",LRORD,LRODT,DA))
IF DA<1
QUIT
SET LRCHK=LRCHK-1
IF LRNONE'=2
SET LRNONE=0
DO LROE2
End DoDot:1
+21 IF DOD'=""
SET Y=DOD
DO DD^LRX
WRITE !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF
WRITE !
+22 IF DOD'=""
Begin DoDot:1
+23 KILL Y
+24 SET DIR(0)="Y"
+25 SET DIR("A")="Do you wish to continue with this accession [Yes/No]"
+26 SET DIR("T")=120
+27 DO ^DIR
KILL DIR
End DoDot:1
IF Y=0!($DATA(DIRUT))
KILL DIRUT,DTOUT,DUOUT,Y
DO KVAR^LRX
GOTO NEXT
+28 IF LRNONE=2
IF LRCHK<1
WRITE !,"The order has already been partially accessioned."
HANG 1
+29 IF LRNONE=2
IF LRCHK>0
WRITE !,"The order has already been accessioned."
HANG 1
GOTO NEXT
+30 IF LRNONE=1
WRITE !,"No order exists with that number."
HANG 1
GOTO NEXT
+31 ;W !!,"All tests for this order have been canceled.",!,"Are you sure you want to accession it" S %=1 D YN^DICN I %'=1 G NEXT
IF '$$GOT(LRORD,LRODT)
GOTO NEXT
+32 KILL DIR
SET DIR("A")="Is this the correct order"
SET DIR(0)="Y"
+33 SET DIR("B")="Yes"
+34 DO ^DIR
KILL DIR
+35 IF $DATA(DIRUT)!(Y'=1)
KILL LRSN
GOTO NEXT
+36 LOCK +^LRO(69,"C",LRORD):$GET(DILOCKTM,3)
+37 IF '$TEST
WRITE !?5,"Someone else is editing this Order",!!,$CHAR(7)
GOTO NEXT
+38 KILL %DT
+39 SET LRSTATUS="C"
SET %DT("B")=""
+40 DO TIME
KILL %DT
+41 IF $GET(LRCDT)<1
DO UNL69
IF LRCDT<1
GOTO NEXT
+42 SET LRTIM=+LRCDT
+43 ;S:'$P(^LRO(69,LRODT,1,LRSN,0),U,8) $P(^(0),U,8)=LRTIM
+44 SET LRUN=$PIECE(LRCDT,U,2)
KILL LRCDT,LRSN
MORE IF M9>1
KILL DIR
SET DIR("A")="Do you have the entire order"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y=1
SET M9=0
+1 IF $DATA(DIRUT)
DO UNL69
GOTO NEXT
+2 ; IHS/OIT/MKK - LR*5.2*1030
SET YYYLRORD=LRORD
+3 SET (LRODT,LRSND)=0
+4 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+5 SET LRSND=0
+6 FOR
SET LRSND=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSND))
IF LRSND<1
QUIT
Begin DoDot:2
+7 IF $DATA(^LRO(69,LRODT,1,LRSND,1))
IF $PIECE(^(1),U,4)="C"
QUIT
+8 SET LRSN(LRSND)=LRSND
SET LRSN=LRSND
+9 KILL LRAA
DO Q15^LROE2
KILL LRSN
End DoDot:2
End DoDot:1
+10 DO TASK
DO UNL69
+11 ; IHS/OIT/MKK - LR*5.2*1030 - Store Ask-At-Order Questions
DO ORDNSTOR^BLRAAORU(YYYLRORD)
KILL YYYLRORD
+12 GOTO NEXT
+13 ;
+14 ;
LROE2 ;
+1 IF '$DATA(^LRO(69,LRODT,1,DA,0))
QUIT
+2 IF $DATA(^LRO(69,LRODT,1,DA,1))
Begin DoDot:1
+3 IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)="C"
SET LRNONE=2
SET LRCHK=LRCHK+1
QUIT
+4 IF $PIECE(^LRO(69,LRODT,1,DA,0),U,4)="LC"
IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)=""
SET LRNONE=2
SET LRCHK=LRCHK+1
End DoDot:1
+5 ;
+6 KILL LRSN
+7 SET (LRSN,LRSN(DA))=+DA
+8 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+9 ; S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
+10 ;
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
+12 SET M9=$GET(M9)+1
+13 SET LRZX=$GET(^LRO(69,LRODT,1,LRSN,0))
+14 SET LRDFN=+LRZX
+15 SET LRDPF=$PIECE($GET(^LR(LRDFN,0)),U,2)
SET DFN=$PIECE($GET(^(0)),U,3)
+16 DO PT^LRX
+17 WRITE !,PNM,?30,HRCN
+18 SET LRWRDS=LRWRD
+19 ;----- END IHS MODIFICATIONS LR*5.2*1027
+20 ;
+21 WRITE ?45,"Requesting location: ",$PIECE(LRZX,U,7)
SET Y=$PIECE(LRZX,U,5)
DO DD^LRX
WRITE !,"Date/Time Ordered: ",Y,?45,"By: ",$SELECT($DATA(^VA(200,+$PIECE(LRZX,U,2),0)):$PIECE(^(0),U),1:"")
+22 SET LRSVSN=LRSN
DO ORDER^LROS
SET LRSN=LRSVSN
+23 QUIT
+24 ;
+25 ;
QMSG WRITE !,"Enter the order entry number assigned when the test was ordered."
+1 IF '$DATA(LRLONG)
WRITE !,"If the test has not been ordered, type the RETURN key to order the test."
+2 WRITE !,"To exit, type the ""^"" key and RETURN key."
+3 QUIT
+4 ;
+5 ;
YN READ X:DTIME
IF '$TEST
SET DTOUT=1
IF X=""!(X["N")!(X["Y")
QUIT
+1 WRITE !,"Answer 'Y' or 'N': "
GOTO YN
+2 ;
+3 ;
EN ;
LROEN SET LRNCWL=1
+1 DO LROE
DO END
KILL LRNCWL
+2 QUIT
+3 ;
+4 ;
EN01 ; ENTER ORDER # THEN ENTER DATA
STAT ;
+1 DO ^LRPARAM
+2 IF '$DATA(LRLABKY)
WRITE !!?10,"You do not have the proper security Keys",!
QUIT
+3 ;
+4 ; Select peforming laboratory
+5 SET X=$$SELPL^LRVERA(DUZ(2))
+6 IF X<1
DO END
QUIT
+7 IF X'=DUZ(2)
NEW LRPL
SET LRPL=X
+8 ;
+9 ;IHS/OIRM TUC/AAB 2/1/97
IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
SET BLROPT="ACCORD"
SET BLROPT(0)=$PIECE(XQY0,U)
+10 ;
+11 SET LRLONG=""
SET LRPANEL=0
SET LROESTAT=""
+12 SET %H=$HOROLOG-60
DO YMD^LRX
SET LRTM60=9999999-X
+13 DO LROE
KILL LRTM60,LRLONG,LREND,LROESTAT
+14 DO END
+15 QUIT
+16 ;
+17 ;
TIME ;from LROE1, LRORD1
+1 ; S %DT="SET" W !,"Collection Date@Time: ",$S($D(%DT("B")):%DT("B"),1:"NOW"),"//" R X:DTIME I '$T!(X="^") S LRCDT=-1 Q
+2 ; S:X="" X=$S($D(%DT("B")):%DT("B"),1:"N")
+3 ;
+4 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
+5 IF $PIECE(XQY0,U)="LRQUICK"
Begin DoDot:1
+6 SET %DT="SET"
WRITE !,"Collection Date@Time: "
READ X:DTIME
IF '$TEST!(X="^")!(X="")
SET LRCDT=-1
End DoDot:1
+7 IF $PIECE(XQY0,U)'="LRQUICK"
Begin DoDot:1
+8 SET %DT="SET"
WRITE !,"Collection Date@Time: ",$SELECT($DATA(%DT("B")):%DT("B"),1:"NOW"),"//"
READ X:DTIME
IF '$TEST!(X="^")
SET LRCDT=-1
QUIT
+9 IF X=""
SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"N")
End DoDot:1
+10 IF $GET(LRCDT)<0
QUIT
+11 SET X=$$UP^XLFSTR(X)
+12 IF $EXTRACT($GET(X))'["N"
IF $GET(X)'["U"
IF $GET(X)'["@"
WRITE !!,?4,"Need Time also."
GOTO TIME
+13 ; ----- END IHS/MSC/MKK - LR*5.2*1038
+14 ;
+15 IF X["?"
WRITE !!,"You may enter ""T@U"" or just ""U"", for Today at Unknown time",!!
+16 IF X["@U"
IF $PIECE(X,"@U",2)=""
SET X=$PIECE(X,"@U",1)
DO ^%DT
IF Y<1
GOTO TIME
SET LRCDT=+Y_"^1"
QUIT
+17 IF X="U"
SET LRCDT=DT_"^1"
+18 IF X'="U"
DO ^%DT
IF X'["?"
DO TIME1
IF X["?"
GOTO TIME
SET LRCDT=+Y_"^"
IF Y'["."
GOTO TIME
+19 QUIT
+20 ;
TIME1 SET X1=X
SET Y1=Y
DO TIME2
SET X=X1
SET Y=Y1
KILL X1,Y1
+1 QUIT
+2 ;
TIME2 SET X="N"
SET %DT="ST"
DO ^%DT
IF Y1'>Y
QUIT
FOR
WRITE !,"You have specified a collection time in the future. Are you sure"
SET %=2
DO YN^DICN
IF %
QUIT
WRITE !,"Answer 'Y'es or 'N'o."
+1 IF %'=1
SET X="?"
SET X1=X
+2 QUIT
+3 ;
+4 ;
TASK ;
+1 IF $DATA(LRLABLIO)
IF $DATA(LRLBL)
SET ZTRTN="ENT^LRLABLD"
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB LABELS"
SET ZTIO=LRLABLIO
SET ZTSAVE("LRLBL(")=""
DO ^%ZTLOAD
+2 KILL LRLBL
+3 IF $DATA(LRCSQ)
IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
KILL ^XTMP("LRCAP",LRCSQ,DUZ),LRCSQ
+4 IF $DATA(LRCSQ)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
DO STD^LRCAPV
+5 DO STOP^LRCAPV
KILL LRCOM,LRSPCDSC,LRCCOM,LRTCOM
+6 QUIT
+7 ;
+8 ;
END KILL DIR,DIRUT,GOT
+1 DO ^LRORDK
DO LROEND^LRORDK
DO STOP^LRCAPV
+2 QUIT
+3 ;
+4 ;
GOT(ORD,ODT) ;See if all tests have been canceled
+1 NEW I,SN,ODT
+2 SET (GOT,ODT,SN)=0
+3 FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
IF ODT<1
QUIT
Begin DoDot:1
+4 SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
IF SN<1!(GOT)
QUIT
Begin DoDot:2
+5 IF '$DATA(^LRO(69,ODT,1,SN,0))
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,I))
IF I<1
QUIT
IF $DATA(^(I,0))
IF '$PIECE(^(0),"^",11)
SET GOT=1
QUIT
End DoDot:2
End DoDot:1
+7 QUIT GOT
+8 ;
+9 ;
UNL69 ;
+1 LOCK -^LRO(69,"C",+$GET(LRORD))
+2 QUIT
+3 ;
+4 ;
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
+1 ;cmi/anch/maw REF LAB
+2 ;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
+3 ;cmi/7/1/2010 reference lab ledi variables
KILL BLRINS,BLRDXS
+4 ;P1034
KILL BLRASFLG
+5 IF $GET(BLRGUI)
QUIT
+6 ;reference lab not set up
IF '$GET(^BLRSITE(DUZ(2),"RL"))
QUIT
+7 IF $PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,22)
QUIT
+8 ;I $D(^TMP("BLRRL",$J)) D
+9 ;p1034
IF $GET(LRORD)
IF $ORDER(^BLRRLO("B",LRORD,0))
Begin DoDot:1
+10 NEW OI
+11 SET OI=$ORDER(^BLRRLO("B",LRORD,0))
+12 ;not accessioned yet
IF '$DATA(^BLRRLO(OI,3,0))
QUIT
+13 ;W !,"Printing Shipping Manifests for Reference Lab..." ;1036 moved to BLRRLEVN
+14 ;D PRT^BLRSHPM
+15 ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
DO SHIPMAN^BLRRLEVN(LRORD,0,0)
End DoDot:1
+16 ;p1035
KILL BLRINS,BLRASFLG,BLRDXS
+17 QUIT
+18 ;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021
