LRCE ;DALOI/JMC - LOOK-UP ON CENTRAL ENTRY # ; 12/20/17 8:51am
;;5.2;LAB SERVICE;**28,76,103,121,153,210,202,263,350,416,486,498**;Sep 27, 1994;Build 7
;
EN ;
N CAN,ORD
S (LRSTOP,LRFLAG1,LRFLG,LRSN1,LRNOP)=0
K DIRUT,SSN,LRORD
W !!
S DIR("A")="Order Number or UID: ",DIR(0)="FOA"
S DIR("?",1)="Enter a whole number for the order number, enter the universal identifier"
S DIR("?",2)="(UID), or press Return to find the order number by Patient.",DIR("?")="Enter '^' to Exit."
D ^DIR
I $G(SSN)&(Y="") G END
I Y="" D ^LROS G:'$G(SSN) END G EN
NEXT I $D(DIRUT) G END
D UNIV
S LRORD=+Y
I LRORD?.AP!(LRORD<1) D G EN
. W !,"Enter a whole number for the order number."
S LRORD=+LRORD
K DIR,X,Y,DIRUT
IF $O(^LRO(69,"C",LRORD,0))<1 W " NUMBER NOT FOUND" G LRCE
I $D(LRADDTST),$$CAN(LRORD) D G EN
. W !!,?5,"This order has been canceled."
. W !,?5,"Tests WILL NOT be added. A new order must be placed."
DIS ;
W @IOF
I $D(LRADDTST) D
. W !!?15,"LISTING OF DATES "
. S (CNT,LRODT)=0
. F A=0:0 S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT="" D
.. D CHKPAGE Q:$G(LRSTOP)
.. S CNT=CNT+1
.. W !?5,CNT,?10,$$FMTE^XLFDT(LRODT,"5FM")
Q:$G(LRSTOP) K CNT,A
S LRODT=0
F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1!($G(LRSTOP)) D I $D(LRADDTST),+LRADDTST Q
. D LR2
I $D(LRADDTST) G LRCE:LRADDTST="" G END
I '$D(LRADDTST) G EN
Q
;
CAN(ORD) ;See if all tests have been canceled
N I,SN,ODT,LRSTR
S (CAN,ODT,SN)=1
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!('CAN) 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 Q:'CAN D
. . . S LRSTR=$G(^LRO(69,ODT,1,SN,2,I,0)) Q:LRSTR=""
. . . ;check for "canceled by" and "canceled" status
. . . I '$P(LRSTR,"^",11),$P(LRSTR,U,9)'="CA" S CAN=0
Q CAN
;
ADDTST ;
N LRADDTST
S LRADDTST="" D EN
S LRRSTAT=160
I LRADDTST D ^LRORD
D END,ADDEND
Q
;
;
ADDEND ;
K LRCLCTR,LRCLST,LRDFN,LRDPF,LRDRWTM,LRFLAG1,LRFLG
K LRLLOC,LRLOC,LRODT,LROLLOC,LRORDRR,LRPRAC,LRRB
K LRRSITE,LRSD,LRDN,LRSTOP,LRTREA,LRSN,LRTSN,LRTSP,PNM,SSN,DOB,SEX
K TYPE,LRRSTAT,LRNOP,LRSN1
K X,Y,I
Q
;
;
LR2 ;
Q:$G(LRSTOP)
D CHKPAGE
Q:$G(LRSTOP)
S LRSN=0
F S LRSN=+$O(^LRO(69,"C",+$G(LRORD),+$G(LRODT),LRSN)) Q:LRSN<1!($G(LRSTOP)) D PT I $D(LRADDTST),+LRADDTST Q
Q
;
;
UNIV ; see if entry is UID
N LRAA,LRAD,LRAN I $D(^LRO(68,"C",X)) S LRAA=$O(^LRO(68,"C",X,0)) I LRAA S LRAD=$O(^LRO(68,"C",X,LRAA,0)) I LRAD S LRAN=$O(^LRO(68,"C",X,LRAA,LRAD,0)) I LRAN S Y=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
Q
;
;
CHKPAGE ;
Q:$G(LRSTOP)
Q:$Y<(IOSL-2)
K DIR
S DIR(0)="E"
D ^DIR
I $D(DUOUT)!($D(DIRUT)) S LRSTOP=1 Q
W @IOF
W !
Q
;
;
PT ;
D CHKPAGE
Q:$G(LRSTOP)!($G(LRFLG))
S LROR=$S($D(^LRO(69,LRODT,1,LRSN,0)):^(0),1:-1)
S LRDFN=+LROR
I LRDFN<1 W " NO PATIENT" Q
S LRWHOE=+$P(LROR,U,2)
S LRWHOE=$S($D(^VA(200,LRWHOE,0)):$P(^(0),U),1:"")
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
H 1
HEAD ;
D CHKPAGE
Q:$G(LRSTOP)
W !!,"ORDER #: ",LRORD,?20,"PAT: ",PNM," SSN: ",SSN,!
D CHKPAGE
Q:$G(LRSTOP)
D LRGLIN^LRX
W !
S LRCTYP=$P(LROR,U,4)
I (LRWHOE'="")!(LRCTYP'="") D
. I LRWHOE'="" W "WHO ENTERED: ",$E(LRWHOE,1,25) K LRWHOE
. W:LRCTYP'="" ?40,"TYPE OF COLLECTION: ",LRCTYP
I $D(^LRO(69,LRODT,1,LRSN,1)) D
. S LRCLCTR=$P(^LRO(69,LRODT,1,LRSN,1),U,3),LRCLST=$P(^(1),U,4)
. S:LRCLCTR'="" LRCLCTR=$P($G(^VA(200,+LRCLCTR,0)),U)
. W ! D CHKPAGE Q:$G(LRSTOP)
. W:LRCLCTR'="" " COLLECTOR : ",$E(LRCLCTR,1,25)
. W:LRCLST'="" ?40,"COLLECTION STATUS: ",LRCLST
Q:$G(LRSTOP)
;
S LRDRWTM=$S($D(^LRO(69,LRODT,1,LRSN,1)):+^(1),1:"")
S:LRDRWTM LRDRWTM=$$FMTE^XLFDT(LRDRWTM,"ZM")
S LRLOC=+$P(LROR,U,9),LRLOC=$P($G(^SC(LRLOC,0)),U)
I (LRDRWTM'="")!(LRLOC'="") D
. W ! D CHKPAGE Q:$G(LRSTOP)
. W:LRDRWTM'="" " DRAW TIME: ",LRDRWTM
. I LRDRWTM="",$P(LROR,"^",8) W "TO BE DRAWN: ",$$FMTE^XLFDT($P(LROR,U,8),"ZM")
. W:LRLOC'="" ?40,"ORDERING LOCATION: ",$E(LRLOC,1,20)
Q:$G(LRSTOP)
;
W ! D CHKPAGE Q:$G(LRSTOP)
I $G(^LRO(69,LRODT,1,LRSN,3)) W " LAB ARRIVAL: ",$$FMTE^XLFDT(+$G(^(3)),"ZM")
I LRDPF=2 W:LRWRD'="" ?40,"WARD: ",LRWRD
W:$P(LROR,U,3) !," SPECIMEN: " D CHKPAGE Q:$G(LRSTOP)
W:$P(LROR,U,3) $S($D(^LAB(62,$P(LROR,U,3),0)):$P(^(0),U),1:"??")
S L=+$P(^LRO(69,LRODT,1,LRSN,0),U,6) I L D
. S LRMD=$S($D(^VA(200,L,0)):$P(^(0),U),1:L)
. W ?40,"PROVIDER: ",$E(LRMD,1,30)
W:$G(^LRO(69,LRODT,1,LRSN,"PCE")) !,?5,"Visit Number(s): ",$G(^("PCE"))
;
S I=0
TST D CHKPAGE
Q:$G(LRSTOP)
F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 D
. D CHKPAGE Q:$G(LRSTOP)
. S LRNOPMSG=0
. D TEST D CHKPAGE Q:$G(LRSTOP)
D CHKPAGE
Q:$G(LRSTOP)
I $D(^LRO(69,LRODT,1,LRSN,1)),$L($P(^(1),U,6)) D
. W !,"COMMENT: ",$P(^LRO(69,LRODT,1,LRSN,1),U,6) D CHKPAGE Q:$G(LRSTOP)
S I=0
F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 W !,?3,^(I,0) D CHKPAGE Q:$G(LRSTOP)
Q:$G(LRSTOP)
NXT S X=$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)
I X="C"!($G(LRNOPMSG)) W !,"Order has already been accessioned."
I LRNOP,'$D(LRLABKY) D Q
. I $G(LRNOPMSG) W !,"Tests have been accessioned, call the lab to add tests to the same order."
I '$D(LRADDTST) Q
I X="M" W !?5,"This Order was Merged " Q
I '$G(LRRSTAT) S LRRSTAT=160
SEL W !,"Is this the one"
S %=1,LRNOP=0 K LRORDRR,LRRSITE,LRSD,LRTSP
D YN^DICN
I %'=1 S (LRFLG1,LRNOP)=0 Q
S LRADDTST=$S(%=1:LRORD,1:"")
Q:$G(LRSTOP)!('$G(LRADDTST))
I %=1 D
. N X,X0,I,DIC,DA
. S X0=^LRO(69,LRODT,1,LRSN,0),LRLWC=$P(X0,"^",4)
. S LRFLG=1
. S LRPRAC=$P(X0,"^",6),LRLLOC=$P(X0,"^",7),LROLLOC=$P(X0,U,9)
. Q:LRLWC'="R" S LRRSITE("SDT")=$P(X0,U,5)
. S DIC("A")="*Select Original Ordered Test "
. S DA=LRSN,DA(1)=LRODT,DIC("S")="I $G(^(.3))"
. S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DIC(0)="AQEZNM"
. D ^DIC I Y<1 S LRADDTST="" Q
. S LRTSP=$P(Y,U,2),X=$G(^LRO(69,LRODT,1,LRSN,2,+Y,.3))
. Q:'$P(X,U,2) S (LRSD("RPSITE"),LRRSITE("RSITE"))=$P(X,U,2)_U_$P(^LRO(69,LRODT,1,LRSN,0),U,7)
. S LRRSITE("RPSITE")=$P(X,U,3)
. S LRSD("RUID")=$P(X,U,5)
. ;LRRSITE("IDTYPE") needs to be set so that
. ;all UID fields are set correctly in file 69
. ;see SET3^LRX (line below added in LR*5.2*498)
. S LRRSITE("IDTYPE")=1
. S LRORDRR="R"
Q
;
;
LUPT ;
K DFN,DIC S DIC(0)="EMQ"
D ^LRDPA
Q:DFN<1!$D(DUOUT)
;
LU1 ;
W !,"Order date to start from: T//" R X:DTIME
I '$T!(X["^") QUIT
S %DT="E",X=$S(X="":"T",1:X)
D ^%DT
G:Y<1 LU1 S Y=Y-1
S LRODT=Y F S LRODT=$O(^LRO(69,LRODT)) Q:LRODT<1 D FSN
Q
;
;
FSN ;
S LRSN=0
F S LRSN=$O(^LRO(69,LRODT,1,"AA",LRDFN,LRSN)) Q:LRSN<1 D
. Q:'$D(^LRO(69,LRODT,1,LRSN,.1)) S LRORD=+^(.1) D PT
Q
;
;
TEST ;
D CHKPAGE Q:$G(LRSTOP)
S X=^LRO(69,LRODT,1,LRSN,2,I,0) S:$P(^(0),U,3) (LRNOP,LRNOPMSG)=1
W !," TEST: ",$S($D(^LAB(60,+X,0)):$P(^(0),"^"),1:"UNKNOWN"),?28," "
S LRURG=+$P(X,U,2)
W $E($S($D(^LAB(62.05,LRURG,0)):$P(^(0),U),1:"ROUTINE"),1,15)
W ?38," ",$S($D(^LRO(68,+$P(X,"^",4),0)):$P(^(0),"^"),1:""),?50," ",$P(X,"^",5),?55
;
D REF
I $P(X,"^",11) D
. W !?3,"Canceled by: "_$P(^VA(200,$P(X,"^",11),0),"^") S I(2)=0
. F S I(2)=$O(^LRO(69,LRODT,1,LRSN,2,I,1.1,I(2))) Q:I(2)<1 I $D(^(I(2),0)) W !?5,^(0) D CHKPAGE Q:$G(LRSTOP)
D CHKPAGE Q:$G(LRSTOP)
;
S I(2)=0
F S I(2)=$O(^LRO(69,LRODT,1,LRSN,2,I,1,I(2))) Q:I(2)<1 I $D(^(I(2),0)) W !?5,^(0) D CHKPAGE Q:$G(LRSTOP)
Q
;
;
REF ; If referred test, display status and manifest
N LREVNT,LRSCFG,LRUID
;
S LRUID=$P($G(^LRO(69,LRODT,1,LRSN,2,I,.3)),"^")
I LRUID="" Q
;
W " <"_LRUID_">"
;
S LREVNT=$$STATUS^LREVENT(LRUID,+X,""),LRSCFG=""
I LREVNT="" Q
I $P(LREVNT,"^",3)'="" D
. N LR628
. S LR628=$O(^LAHM(62.8,"B",$P(LREVNT,"^",3),0))
. S LRSCFG=$P($G(^LAHM(62.8,LR628,0)),"^",2)
. I LRSCFG S LRSCFG(0)=$P($G(^LAHM(62.9,LRSCFG,0),"Unknown/deleted"),"^")
W !,?4,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
W !,?4,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
I LRSCFG W " using shipping config "_LRSCFG(0)
;
Q
;
;
END ;
K %,%DT,A,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,I,II,K,L,LRARIV,LRCLCTR,LRCLST
K LRCTYP,LRDRWTM,LRFLAG1,LRFLG,LRLOC,LRMD,LRODT,LROR,LRORD
K LRPRAC,LRSN,LRSN1,LRSTOP,LRURG,LRW,LRWHOE,LRWRD,VA("BID"),VA("PID")
K VAIN,VADM,VAERR,X,X1,X2,Y,Z
Q:$G(LR2ORD)
K LRNOP,LRNOPMSG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCE 8407 printed Sep 23, 2025@19:49:12 Page 2
LRCE ;DALOI/JMC - LOOK-UP ON CENTRAL ENTRY # ; 12/20/17 8:51am
+1 ;;5.2;LAB SERVICE;**28,76,103,121,153,210,202,263,350,416,486,498**;Sep 27, 1994;Build 7
+2 ;
EN ;
+1 NEW CAN,ORD
+2 SET (LRSTOP,LRFLAG1,LRFLG,LRSN1,LRNOP)=0
+3 KILL DIRUT,SSN,LRORD
+4 WRITE !!
+5 SET DIR("A")="Order Number or UID: "
SET DIR(0)="FOA"
+6 SET DIR("?",1)="Enter a whole number for the order number, enter the universal identifier"
+7 SET DIR("?",2)="(UID), or press Return to find the order number by Patient."
SET DIR("?")="Enter '^' to Exit."
+8 DO ^DIR
+9 IF $GET(SSN)&(Y="")
GOTO END
+10 IF Y=""
DO ^LROS
if '$GET(SSN)
GOTO END
GOTO EN
NEXT IF $DATA(DIRUT)
GOTO END
+1 DO UNIV
+2 SET LRORD=+Y
+3 IF LRORD?.AP!(LRORD<1)
Begin DoDot:1
+4 WRITE !,"Enter a whole number for the order number."
End DoDot:1
GOTO EN
+5 SET LRORD=+LRORD
+6 KILL DIR,X,Y,DIRUT
+7 IF $ORDER(^LRO(69,"C",LRORD,0))<1
WRITE " NUMBER NOT FOUND"
GOTO LRCE
+8 IF $DATA(LRADDTST)
IF $$CAN(LRORD)
Begin DoDot:1
+9 WRITE !!,?5,"This order has been canceled."
+10 WRITE !,?5,"Tests WILL NOT be added. A new order must be placed."
End DoDot:1
GOTO EN
DIS ;
+1 WRITE @IOF
+2 IF $DATA(LRADDTST)
Begin DoDot:1
+3 WRITE !!?15,"LISTING OF DATES "
+4 SET (CNT,LRODT)=0
+5 FOR A=0:0
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT=""
QUIT
Begin DoDot:2
+6 DO CHKPAGE
if $GET(LRSTOP)
QUIT
+7 SET CNT=CNT+1
+8 WRITE !?5,CNT,?10,$$FMTE^XLFDT(LRODT,"5FM")
End DoDot:2
End DoDot:1
+9 if $GET(LRSTOP)
QUIT
KILL CNT,A
+10 SET LRODT=0
+11 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+12 DO LR2
End DoDot:1
IF $DATA(LRADDTST)
IF +LRADDTST
QUIT
+13 IF $DATA(LRADDTST)
if LRADDTST=""
GOTO LRCE
GOTO END
+14 IF '$DATA(LRADDTST)
GOTO EN
+15 QUIT
+16 ;
CAN(ORD) ;See if all tests have been canceled
+1 NEW I,SN,ODT,LRSTR
+2 SET (CAN,ODT,SN)=1
+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!('CAN)
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 'CAN
QUIT
Begin DoDot:3
+7 SET LRSTR=$GET(^LRO(69,ODT,1,SN,2,I,0))
if LRSTR=""
QUIT
+8 ;check for "canceled by" and "canceled" status
+9 IF '$PIECE(LRSTR,"^",11)
IF $PIECE(LRSTR,U,9)'="CA"
SET CAN=0
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT CAN
+11 ;
ADDTST ;
+1 NEW LRADDTST
+2 SET LRADDTST=""
DO EN
+3 SET LRRSTAT=160
+4 IF LRADDTST
DO ^LRORD
+5 DO END
DO ADDEND
+6 QUIT
+7 ;
+8 ;
ADDEND ;
+1 KILL LRCLCTR,LRCLST,LRDFN,LRDPF,LRDRWTM,LRFLAG1,LRFLG
+2 KILL LRLLOC,LRLOC,LRODT,LROLLOC,LRORDRR,LRPRAC,LRRB
+3 KILL LRRSITE,LRSD,LRDN,LRSTOP,LRTREA,LRSN,LRTSN,LRTSP,PNM,SSN,DOB,SEX
+4 KILL TYPE,LRRSTAT,LRNOP,LRSN1
+5 KILL X,Y,I
+6 QUIT
+7 ;
+8 ;
LR2 ;
+1 if $GET(LRSTOP)
QUIT
+2 DO CHKPAGE
+3 if $GET(LRSTOP)
QUIT
+4 SET LRSN=0
+5 FOR
SET LRSN=+$ORDER(^LRO(69,"C",+$GET(LRORD),+$GET(LRODT),LRSN))
if LRSN<1!($GET(LRSTOP))
QUIT
DO PT
IF $DATA(LRADDTST)
IF +LRADDTST
QUIT
+6 QUIT
+7 ;
+8 ;
UNIV ; see if entry is UID
+1 NEW LRAA,LRAD,LRAN
IF $DATA(^LRO(68,"C",X))
SET LRAA=$ORDER(^LRO(68,"C",X,0))
IF LRAA
SET LRAD=$ORDER(^LRO(68,"C",X,LRAA,0))
IF LRAD
SET LRAN=$ORDER(^LRO(68,"C",X,LRAA,LRAD,0))
IF LRAN
SET Y=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
+2 QUIT
+3 ;
+4 ;
CHKPAGE ;
+1 if $GET(LRSTOP)
QUIT
+2 if $Y<(IOSL-2)
QUIT
+3 KILL DIR
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 IF $DATA(DUOUT)!($DATA(DIRUT))
SET LRSTOP=1
QUIT
+7 WRITE @IOF
+8 WRITE !
+9 QUIT
+10 ;
+11 ;
PT ;
+1 DO CHKPAGE
+2 if $GET(LRSTOP)!($GET(LRFLG))
QUIT
+3 SET LROR=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,0)):^(0),1:-1)
+4 SET LRDFN=+LROR
+5 IF LRDFN<1
WRITE " NO PATIENT"
QUIT
+6 SET LRWHOE=+$PIECE(LROR,U,2)
+7 SET LRWHOE=$SELECT($DATA(^VA(200,LRWHOE,0)):$PIECE(^(0),U),1:"")
+8 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+9 DO PT^LRX
+10 HANG 1
HEAD ;
+1 DO CHKPAGE
+2 if $GET(LRSTOP)
QUIT
+3 WRITE !!,"ORDER #: ",LRORD,?20,"PAT: ",PNM," SSN: ",SSN,!
+4 DO CHKPAGE
+5 if $GET(LRSTOP)
QUIT
+6 DO LRGLIN^LRX
+7 WRITE !
+8 SET LRCTYP=$PIECE(LROR,U,4)
+9 IF (LRWHOE'="")!(LRCTYP'="")
Begin DoDot:1
+10 IF LRWHOE'=""
WRITE "WHO ENTERED: ",$EXTRACT(LRWHOE,1,25)
KILL LRWHOE
+11 if LRCTYP'=""
WRITE ?40,"TYPE OF COLLECTION: ",LRCTYP
End DoDot:1
+12 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
Begin DoDot:1
+13 SET LRCLCTR=$PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)
SET LRCLST=$PIECE(^(1),U,4)
+14 if LRCLCTR'=""
SET LRCLCTR=$PIECE($GET(^VA(200,+LRCLCTR,0)),U)
+15 WRITE !
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+16 if LRCLCTR'=""
WRITE " COLLECTOR : ",$EXTRACT(LRCLCTR,1,25)
+17 if LRCLST'=""
WRITE ?40,"COLLECTION STATUS: ",LRCLST
End DoDot:1
+18 if $GET(LRSTOP)
QUIT
+19 ;
+20 SET LRDRWTM=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,1)):+^(1),1:"")
+21 if LRDRWTM
SET LRDRWTM=$$FMTE^XLFDT(LRDRWTM,"ZM")
+22 SET LRLOC=+$PIECE(LROR,U,9)
SET LRLOC=$PIECE($GET(^SC(LRLOC,0)),U)
+23 IF (LRDRWTM'="")!(LRLOC'="")
Begin DoDot:1
+24 WRITE !
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+25 if LRDRWTM'=""
WRITE " DRAW TIME: ",LRDRWTM
+26 IF LRDRWTM=""
IF $PIECE(LROR,"^",8)
WRITE "TO BE DRAWN: ",$$FMTE^XLFDT($PIECE(LROR,U,8),"ZM")
+27 if LRLOC'=""
WRITE ?40,"ORDERING LOCATION: ",$EXTRACT(LRLOC,1,20)
End DoDot:1
+28 if $GET(LRSTOP)
QUIT
+29 ;
+30 WRITE !
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+31 IF $GET(^LRO(69,LRODT,1,LRSN,3))
WRITE " LAB ARRIVAL: ",$$FMTE^XLFDT(+$GET(^(3)),"ZM")
+32 IF LRDPF=2
if LRWRD'=""
WRITE ?40,"WARD: ",LRWRD
+33 if $PIECE(LROR,U,3)
WRITE !," SPECIMEN: "
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+34 if $PIECE(LROR,U,3)
WRITE $SELECT($DATA(^LAB(62,$PIECE(LROR,U,3),0)):$PIECE(^(0),U),1:"??")
+35 SET L=+$PIECE(^LRO(69,LRODT,1,LRSN,0),U,6)
IF L
Begin DoDot:1
+36 SET LRMD=$SELECT($DATA(^VA(200,L,0)):$PIECE(^(0),U),1:L)
+37 WRITE ?40,"PROVIDER: ",$EXTRACT(LRMD,1,30)
End DoDot:1
+38 if $GET(^LRO(69,LRODT,1,LRSN,"PCE"))
WRITE !,?5,"Visit Number(s): ",$GET(^("PCE"))
+39 ;
+40 SET I=0
TST DO CHKPAGE
+1 if $GET(LRSTOP)
QUIT
+2 FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
if I<1
QUIT
Begin DoDot:1
+3 DO CHKPAGE
if $GET(LRSTOP)
QUIT
+4 SET LRNOPMSG=0
+5 DO TEST
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
+6 DO CHKPAGE
+7 if $GET(LRSTOP)
QUIT
+8 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $LENGTH($PIECE(^(1),U,6))
Begin DoDot:1
+9 WRITE !,"COMMENT: ",$PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
+10 SET I=0
+11 FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))
if I<1
QUIT
WRITE !,?3,^(I,0)
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+12 if $GET(LRSTOP)
QUIT
NXT SET X=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)
+1 IF X="C"!($GET(LRNOPMSG))
WRITE !,"Order has already been accessioned."
+2 IF LRNOP
IF '$DATA(LRLABKY)
Begin DoDot:1
+3 IF $GET(LRNOPMSG)
WRITE !,"Tests have been accessioned, call the lab to add tests to the same order."
End DoDot:1
QUIT
+4 IF '$DATA(LRADDTST)
QUIT
+5 IF X="M"
WRITE !?5,"This Order was Merged "
QUIT
+6 IF '$GET(LRRSTAT)
SET LRRSTAT=160
SEL WRITE !,"Is this the one"
+1 SET %=1
SET LRNOP=0
KILL LRORDRR,LRRSITE,LRSD,LRTSP
+2 DO YN^DICN
+3 IF %'=1
SET (LRFLG1,LRNOP)=0
QUIT
+4 SET LRADDTST=$SELECT(%=1:LRORD,1:"")
+5 if $GET(LRSTOP)!('$GET(LRADDTST))
QUIT
+6 IF %=1
Begin DoDot:1
+7 NEW X,X0,I,DIC,DA
+8 SET X0=^LRO(69,LRODT,1,LRSN,0)
SET LRLWC=$PIECE(X0,"^",4)
+9 SET LRFLG=1
+10 SET LRPRAC=$PIECE(X0,"^",6)
SET LRLLOC=$PIECE(X0,"^",7)
SET LROLLOC=$PIECE(X0,U,9)
+11 if LRLWC'="R"
QUIT
SET LRRSITE("SDT")=$PIECE(X0,U,5)
+12 SET DIC("A")="*Select Original Ordered Test "
+13 SET DA=LRSN
SET DA(1)=LRODT
SET DIC("S")="I $G(^(.3))"
+14 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DIC(0)="AQEZNM"
+15 DO ^DIC
IF Y<1
SET LRADDTST=""
QUIT
+16 SET LRTSP=$PIECE(Y,U,2)
SET X=$GET(^LRO(69,LRODT,1,LRSN,2,+Y,.3))
+17 if '$PIECE(X,U,2)
QUIT
SET (LRSD("RPSITE"),LRRSITE("RSITE"))=$PIECE(X,U,2)_U_$PIECE(^LRO(69,LRODT,1,LRSN,0),U,7)
+18 SET LRRSITE("RPSITE")=$PIECE(X,U,3)
+19 SET LRSD("RUID")=$PIECE(X,U,5)
+20 ;LRRSITE("IDTYPE") needs to be set so that
+21 ;all UID fields are set correctly in file 69
+22 ;see SET3^LRX (line below added in LR*5.2*498)
+23 SET LRRSITE("IDTYPE")=1
+24 SET LRORDRR="R"
End DoDot:1
+25 QUIT
+26 ;
+27 ;
LUPT ;
+1 KILL DFN,DIC
SET DIC(0)="EMQ"
+2 DO ^LRDPA
+3 if DFN<1!$DATA(DUOUT)
QUIT
+4 ;
LU1 ;
+1 WRITE !,"Order date to start from: T//"
READ X:DTIME
+2 IF '$TEST!(X["^")
QUIT
+3 SET %DT="E"
SET X=$SELECT(X="":"T",1:X)
+4 DO ^%DT
+5 if Y<1
GOTO LU1
SET Y=Y-1
+6 SET LRODT=Y
FOR
SET LRODT=$ORDER(^LRO(69,LRODT))
if LRODT<1
QUIT
DO FSN
+7 QUIT
+8 ;
+9 ;
FSN ;
+1 SET LRSN=0
+2 FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,LRSN))
if LRSN<1
QUIT
Begin DoDot:1
+3 if '$DATA(^LRO(69,LRODT,1,LRSN,.1))
QUIT
SET LRORD=+^(.1)
DO PT
End DoDot:1
+4 QUIT
+5 ;
+6 ;
TEST ;
+1 DO CHKPAGE
if $GET(LRSTOP)
QUIT
+2 SET X=^LRO(69,LRODT,1,LRSN,2,I,0)
if $PIECE(^(0),U,3)
SET (LRNOP,LRNOPMSG)=1
+3 WRITE !," TEST: ",$SELECT($DATA(^LAB(60,+X,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),?28," "
+4 SET LRURG=+$PIECE(X,U,2)
+5 WRITE $EXTRACT($SELECT($DATA(^LAB(62.05,LRURG,0)):$PIECE(^(0),U),1:"ROUTINE"),1,15)
+6 WRITE ?38," ",$SELECT($DATA(^LRO(68,+$PIECE(X,"^",4),0)):$PIECE(^(0),"^"),1:""),?50," ",$PIECE(X,"^",5),?55
+7 ;
+8 DO REF
+9 IF $PIECE(X,"^",11)
Begin DoDot:1
+10 WRITE !?3,"Canceled by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")
SET I(2)=0
+11 FOR
SET I(2)=$ORDER(^LRO(69,LRODT,1,LRSN,2,I,1.1,I(2)))
if I(2)<1
QUIT
IF $DATA(^(I(2),0))
WRITE !?5,^(0)
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
+12 DO CHKPAGE
if $GET(LRSTOP)
QUIT
+13 ;
+14 SET I(2)=0
+15 FOR
SET I(2)=$ORDER(^LRO(69,LRODT,1,LRSN,2,I,1,I(2)))
if I(2)<1
QUIT
IF $DATA(^(I(2),0))
WRITE !?5,^(0)
DO CHKPAGE
if $GET(LRSTOP)
QUIT
+16 QUIT
+17 ;
+18 ;
REF ; If referred test, display status and manifest
+1 NEW LREVNT,LRSCFG,LRUID
+2 ;
+3 SET LRUID=$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,I,.3)),"^")
+4 IF LRUID=""
QUIT
+5 ;
+6 WRITE " <"_LRUID_">"
+7 ;
+8 SET LREVNT=$$STATUS^LREVENT(LRUID,+X,"")
SET LRSCFG=""
+9 IF LREVNT=""
QUIT
+10 IF $PIECE(LREVNT,"^",3)'=""
Begin DoDot:1
+11 NEW LR628
+12 SET LR628=$ORDER(^LAHM(62.8,"B",$PIECE(LREVNT,"^",3),0))
+13 SET LRSCFG=$PIECE($GET(^LAHM(62.8,LR628,0)),"^",2)
+14 IF LRSCFG
SET LRSCFG(0)=$PIECE($GET(^LAHM(62.9,LRSCFG,0),"Unknown/deleted"),"^")
End DoDot:1
+15 WRITE !,?4,"REFERRAL STATUS: "_$PIECE(LREVNT,"^")_" ("_$PIECE(LREVNT,"^",2)_")"
+16 WRITE !,?4,"SHIPPING MANIFEST: "_$PIECE(LREVNT,"^",3)
+17 IF LRSCFG
WRITE " using shipping config "_LRSCFG(0)
+18 ;
+19 QUIT
+20 ;
+21 ;
END ;
+1 KILL %,%DT,A,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,I,II,K,L,LRARIV,LRCLCTR,LRCLST
+2 KILL LRCTYP,LRDRWTM,LRFLAG1,LRFLG,LRLOC,LRMD,LRODT,LROR,LRORD
+3 KILL LRPRAC,LRSN,LRSN1,LRSTOP,LRURG,LRW,LRWHOE,LRWRD,VA("BID"),VA("PID")
+4 KILL VAIN,VADM,VAERR,X,X1,X2,Y,Z
+5 if $GET(LR2ORD)
QUIT
+6 KILL LRNOP,LRNOPMSG
+7 QUIT
