LRCE.m

LRCE ;SLC/RWF/DALOI/JMC - LOOK-UP ON CENTRAL ENTRY # ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LR;**28,76,103,121,1013,1015,121,153,210,202,263,1018,1022,1033**;NOV 1, 1997

 ;

EN ; EP

 S (LRSTOP,LRFLAG1,LRFLG,LRSN1,LRNOP)=0

 K DIRUT,SSN,LRORD

 W !! S LN=2

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 K DIR  ;IHS/ITSC/TPF 11/12/02 DIR SHOULD BE KILLED BEFORE CALLING DIR  **1015**

 ;----- END IHS MODIFICATIONS

 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

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

ADDTST ;

 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,!

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 W !!,"ORDER #: ",LRORD,?20,"PAT: ",PNM,"    HRCN: ",HRCN,!  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 D CHKPAGE

 Q:$G(LRSTOP)

 D LRGLIN^LRX

 W !

 S LRCTYP=$P(LROR,U,4)

 I ($L(LRWHOE))!($L(LRCTYP)) D

 . I $L(LRWHOE) W "WHO ENTERED: ",$E(LRWHOE,1,25) K LRWHOE

 . W:$L(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:$L(LRCLCTR) LRCLCTR=$P($G(^VA(200,+LRCLCTR,0)),U)

 . W ! D CHKPAGE Q:$G(LRSTOP)

 . W:$L(LRCLCTR) "  COLLECTOR : ",$E(LRCLCTR,1,25)

 . W:$L(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,"5FM")

 S LRLOC=+$P(LROR,U,9),LRLOC=$P($G(^SC(LRLOC,0)),U)

 I ($L(LRDRWTM))!($L(LRLOC)) D

 . W ! D CHKPAGE Q:$G(LRSTOP)

 . W:$L(LRDRWTM) "  DRAW TIME:   ",LRDRWTM

 . I '$L(LRDRWTM),$P(LROR,"^",8) W "TO BE DRAWN:   ",$$FMTE^XLFDT($P(LROR,U,8),"5FM")

 . W:$L(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)),"5FM")

 I LRDPF=2 W:$L(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)

 . 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(LRNOP)) W !,"Order has already been accessioned."

 I LRNOP,'$P($G(LRLABKY),U) W !,"Tests have been accessioned, call the lab to add tests to the same order." Q

 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 Orginal 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)

 . 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=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

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ; W !,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,I,9999999))  ;IHS/ITSC/TPF 11/07/02 **1015** 'SIGN OR SYMPTOM' LAB POV

 ;----- END IHS MODIFICATIONS

 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 W ?38,"  ",$S($D(^LRO(68,+$P(X,"^",4),0)):$P(^(0),"^"),1:""),?50,"  ",$P(X,"^",5)

 ; W !,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,I,9999999))  ;IHS/ITSC/TPF 11/07/02 **1015** 'SIGN OR SYMPTOM' LAB POV

 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 ;

 W !,"Clinical Indication: ",$G(^LRO(69,LRODT,1,LRSN,2,I,9999999))  ;IHS/MSC/MKK - LR*5.2*1033

 ;

 D REF

 I $P(X,"^",11) W !?3,"Canceled by: "_$P(^VA(200,$P(X,"^",11),0),"^") S I(2)=0 D

 . 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,LRMAN,LRUID S LRUID=$P($G(^LRO(69,LRODT,1,LRSN,2,I,.3)),"^") Q:'LRUID

 ; W "  <"_LRUID_">" S LREVNT=$$STATUS^LREVENT(LRUID,+X,"") I LREVNT'="" D

 ; .S LRMAN=$P(LREVNT,"^",3) I LRMAN'="" W !,?5,"SHIPPING MANIFEST: "_LRMAN

 ; .W !,?5,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"

 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 W !,"  <"_LRUID_">"

 S LREVNT=$$STATUS^LREVENT(LRUID,+X,"")

 I LREVNT'="" D

 .S LRMAN=$P(LREVNT,"^",3)

 .I LRMAN'="" W !,?5,"SHIPPING MANIFEST: "_LRMAN

 .W !,?5,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"

 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1022

 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

 Q

LRCE      ;SLC/RWF/DALOI/JMC - LOOK-UP ON CENTRAL ENTRY # ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LR;**28,76,103,121,1013,1015,121,153,210,202,263,1018,1022,1033**;NOV 1, 1997

 +2       ;

EN        ; EP

 +1        SET (LRSTOP,LRFLAG1,LRFLG,LRSN1,LRNOP)=0

 +2        KILL DIRUT,SSN,LRORD

 +3        WRITE !!

           SET LN=2

 +4       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +5       ;IHS/ITSC/TPF 11/12/02 DIR SHOULD BE KILLED BEFORE CALLING DIR  **1015**

           KILL DIR

 +6       ;----- END IHS MODIFICATIONS

 +7        SET DIR("A")="Order Number or UID: "

           SET DIR(0)="FOA"

 +8        SET DIR("?",1)="Enter a whole number for the order number, enter the universal identifier"

 +9        SET DIR("?",2)="(UID), or press Return to find the order number by Patient."

           SET DIR("?")="Enter '^' to Exit."

 +10       DO ^DIR

 +11       IF $GET(SSN)&(Y="")

               GOTO END

 +12       IF Y=""

               DO ^LROS

               IF '$GET(SSN)

                   GOTO END

               GOTO EN

NEXT       IF $DATA(DIRUT)

               GOTO END

 +1        DO UNIV

 +2        SET LRORD=+Y

           IF LRORD?.AP!(LRORD<1)

               Begin DoDot:1

 +3                WRITE !,"Enter a whole number for the order number."

               End DoDot:1

               GOTO EN

 +4        SET LRORD=+LRORD

 +5        KILL DIR,X,Y,DIRUT

 +6        IF $ORDER(^LRO(69,"C",LRORD,0))<1

               WRITE "  NUMBER NOT FOUND"

               GOTO LRCE

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 

ADDTST    ;

 +1        SET LRADDTST=""

           DO EN

 +2        SET LRRSTAT=160

 +3        IF LRADDTST

               DO ^LRORD

 +4        DO END

           DO ADDEND

 +5        QUIT 

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 

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 

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 

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 

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       ;W !!,"ORDER #: ",LRORD,?20,"PAT: ",PNM,"    SSN: ",SSN,!

 +4       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +5       ;IHS/ANMC/CLS 08/18/96

           WRITE !!,"ORDER #: ",LRORD,?20,"PAT: ",PNM,"    HRCN: ",HRCN,!

 +6       ;----- END IHS MODIFICATIONS

 +7        DO CHKPAGE

 +8        IF $GET(LRSTOP)

               QUIT 

 +9        DO LRGLIN^LRX

 +10       WRITE !

 +11       SET LRCTYP=$PIECE(LROR,U,4)

 +12       IF ($LENGTH(LRWHOE))!($LENGTH(LRCTYP))

               Begin DoDot:1

 +13               IF $LENGTH(LRWHOE)

                       WRITE "WHO ENTERED: ",$EXTRACT(LRWHOE,1,25)

                       KILL LRWHOE

 +14               IF $LENGTH(LRCTYP)

                       WRITE ?40,"TYPE OF COLLECTION: ",LRCTYP

               End DoDot:1

 +15       IF $DATA(^LRO(69,LRODT,1,LRSN,1))

               Begin DoDot:1

 +16               SET LRCLCTR=$PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)

                   SET LRCLST=$PIECE(^(1),U,4)

 +17               IF $LENGTH(LRCLCTR)

                       SET LRCLCTR=$PIECE($GET(^VA(200,+LRCLCTR,0)),U)

 +18               WRITE !

                   DO CHKPAGE

                   IF $GET(LRSTOP)

                       QUIT 

 +19               IF $LENGTH(LRCLCTR)

                       WRITE "  COLLECTOR : ",$EXTRACT(LRCLCTR,1,25)

 +20               IF $LENGTH(LRCLST)

                       WRITE ?40,"COLLECTION STATUS: ",LRCLST

               End DoDot:1

 +21       IF $GET(LRSTOP)

               QUIT 

           SET LRDRWTM=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,1)):+^(1),1:"")

 +22       IF LRDRWTM

               SET LRDRWTM=$$FMTE^XLFDT(LRDRWTM,"5FM")

 +23       SET LRLOC=+$PIECE(LROR,U,9)

           SET LRLOC=$PIECE($GET(^SC(LRLOC,0)),U)

 +24       IF ($LENGTH(LRDRWTM))!($LENGTH(LRLOC))

               Begin DoDot:1

 +25               WRITE !

                   DO CHKPAGE

                   IF $GET(LRSTOP)

                       QUIT 

 +26               IF $LENGTH(LRDRWTM)

                       WRITE "  DRAW TIME:   ",LRDRWTM

 +27               IF '$LENGTH(LRDRWTM)

                       IF $PIECE(LROR,"^",8)

                           WRITE "TO BE DRAWN:   ",$$FMTE^XLFDT($PIECE(LROR,U,8),"5FM")

 +28               IF $LENGTH(LRLOC)

                       WRITE ?40,"ORDERING LOCATION: ",$EXTRACT(LRLOC,1,20)

               End DoDot:1

 +29       IF $GET(LRSTOP)

               QUIT 

           WRITE !

           DO CHKPAGE

           IF $GET(LRSTOP)

               QUIT 

 +30       IF $GET(^LRO(69,LRODT,1,LRSN,3))

               WRITE "  LAB ARRIVAL: ",$$FMTE^XLFDT(+$GET(^(3)),"5FM")

 +31       IF LRDPF=2

               IF $LENGTH(LRWRD)

                   WRITE ?40,"WARD: ",LRWRD

 +32       IF $PIECE(LROR,U,3)

               WRITE !,"  SPECIMEN: "

           DO CHKPAGE

           IF $GET(LRSTOP)

               QUIT 

 +33       IF $PIECE(LROR,U,3)

               WRITE $SELECT($DATA(^LAB(62,$PIECE(LROR,U,3),0)):$PIECE(^(0),U),1:"??")

 +34       SET L=+$PIECE(^LRO(69,LRODT,1,LRSN,0),U,6)

           IF L

               Begin DoDot:1

 +35               SET LRMD=$SELECT($DATA(^VA(200,L,0)):$PIECE(^(0),U),1:L)

 +36               WRITE ?40,"PROVIDER: ",$EXTRACT(LRMD,1,30)

               End DoDot:1

 +37       IF $GET(^LRO(69,LRODT,1,LRSN,"PCE"))

               WRITE !,?5,"Visit Number(s): ",$GET(^("PCE"))

 +38      ;

 +39       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                DO TEST

                   DO CHKPAGE

                   IF $GET(LRSTOP)

                       QUIT 

               End DoDot:1

 +5        DO CHKPAGE

 +6        IF $GET(LRSTOP)

               QUIT 

 +7        IF $DATA(^LRO(69,LRODT,1,LRSN,1))

               IF $LENGTH($PIECE(^(1),U,6))

                   Begin DoDot:1

 +8                    WRITE !,"COMMENT: ",$PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)

                       DO CHKPAGE

                       IF $GET(LRSTOP)

                           QUIT 

                   End DoDot:1

 +9        SET I=0

 +10       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 

 +11       IF $GET(LRSTOP)

               QUIT 

NXT        SET X=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)

 +1        IF X="C"!($GET(LRNOP))

               WRITE !,"Order has already been accessioned."

 +2        IF LRNOP

               IF '$PIECE($GET(LRLABKY),U)

                   WRITE !,"Tests have been accessioned, call the lab to add tests to the same order."

                   QUIT 

 +3        IF '$DATA(LRADDTST)

               QUIT 

 +4        IF X="M"

               WRITE !?5,"This Order was Merged "

               QUIT 

 +5        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 Orginal 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               SET LRORDRR="R"

               End DoDot:1

 +21       QUIT 

LUPT      ;

 +1        KILL DFN,DIC

           SET DIC(0)="EMQ"

 +2        DO ^LRDPA

 +3        IF DFN<1!$DATA(DUOUT)

               QUIT 

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 

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