LROS.m

LROS ;SLC/CJS/DALOI/FHS-LAB ORDER STATUS ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LR;**1003,1004,1015,1018,1030,1033**;NOV 01, 1997

 ;;5.2;LAB SERVICE;**121,153,202,210,221,263**;Sep 27, 1994

 N LRLOOKUP S LRLOOKUP=1 ; Variable to indicate to lookup patients, prevent adding new entries in ^LRDPA

EN K DIC,LRDPAF,%DT("B") S DIC(0)="A"

 D ^LRDPA G:(LRDFN=-1)!$D(DUOUT)!$D(DTOUT) LREND D L0 G EN

L0 D ENT S %DT="" D DT^LRX

L1 S LREND=0,%DT="E",%DT("A")="DATE to begin review: " D DATE^LRWU G LREND:Y<1 S (LRSDT,LRODT)=Y S %DT="",X="T-"_$S($P($G(^LAB(69.9,1,0)),U,9):$P(^(0),U,9),1:30) D ^%DT S LRLDAT=Y

L2 ; S LRSN=$O(^LRO(69,LRODT,1,"AA",LRDFN,0)) I LRSN<1 S Y=LRODT D DD^LRX W !,"No orders for ",Y S X1=LRODT,X2=-1 D C^%DTC S LRODT=X I LRODT<LRLDAT W !!,"NO REMAINING ACTIVE ORDERS",! G LREND

 S LRSN=$O(^LRO(69,LRODT,1,"AA",LRDFN,0)) I LRSN<1 S Y=LRODT D DD^LRX S X1=LRODT,X2=-1 D C^%DTC S LRODT=X I LRODT<LRLDAT W !!,"NO REMAINING ACTIVE ORDERS",! G LREND     ; IHS/OIT/MKK - LR*5.2*1030

 D WAIT:$Y>18 G LREND:LREND,L2:LRSN<1

 I LRSDT'=LRODT W !,"Orders for date: " S Y=LRODT D DD^LRX W Y," OK" S %=1 D YN^DICN I %'=1 G LREND

 D ENTRY G LREND:LREND S X1=LRODT,X2=-1 D C^%DTC S LRODT=X

 G L2

ENTRY D HED Q:LREND

 S LRSN=0 F  S LRSN=$O(^LRO(69,LRODT,1,"AA",LRDFN,LRSN)) Q:LRSN<1!($G(LREND))  D ORDER Q:$G(LREND)  D HED:$Y>(IOSL-2)

 Q

ORDER ;call with LRSN, from LROE, LROE1, LRORD1, LROW2, LROR1

 K D,LRTT S LREND=0

 Q:'$D(^LRO(69,LRODT,1,LRSN,0))  S LROD0=^LRO(69,LRODT,1,LRSN,0),LROD1=$S($D(^(1)):^(1),1:""),LROD3=$S($D(^(3)):^(3),1:"")

 ; W !?2,"-Lab Order # ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:"") S X=$P(LROD0,U,6) D DOC^LRX W ?45,"Provider: ",$E(LRDOC,1,25) D WAIT Q:$G(LREND)

 W !,"Lab Order # " D REVIDEO^BLRUTIL3($S($D(^LRO(69,LRODT,1,LRSN,.1)):" "_^(.1)_" ",1:""))  S X=$P(LROD0,U,6) D DOC^LRX W ?45,"Provider: ",$E(LRDOC,1,25) D WAIT Q:$G(LREND)  ; IHS/OIT/MKK - LR*5.2*1030

 S X=$P(LROD0,U,3),X=$S(X:$S($D(^LAB(62,+X,0)):$P(^(0),U),1:""),1:""),X4="" I $D(^LRO(69,LRODT,1,LRSN,4,1,0)),+^(0) S X4=+^(0),X4=$S($D(^LAB(61,X4,0)):$P(^(0),U),1:"")

 I $E($P(LROD1,U,6))="*" W !?3,$P(LROD1,U,6) D WAIT Q:$G(LREND)

 I $G(^LRO(69,LRODT,1,LRSN,"PCE")) W !,?5,"Visit Number(s): ",$G(^("PCE")) D WAIT Q:$G(LREND)

 W !?2,X,"  " W:X'[X4 X4 S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1!($G(LREND))  W !?5,": ",^(I,0) D WAIT Q:$G(LREND)

 S LRACN=0 F  S LRACN=$O(^LRO(69,LRODT,1,LRSN,2,LRACN)) Q:LRACN<1!($G(LREND))  I $D(^(LRACN,0))#2 S LRACN0=^(0) D TEST

 Q

TEST N LRY,LRURG

 S LRROD=$P(LRACN0,U,6),(Y,LRLL,LROT,LROS,LROSD,LRURG)="",X3=0

 I $P(LRACN0,"^",11) G CANC

 S X=$P(LROD0,U,4),LROT=$S(X="WC":"Requested (WARD COL)",X="SP":"Requested (SEND PATIENT)",X="LC":"Requested (LAB COL)",X="I":"Requested (IMM LAB COL)",1:"undetermined")

 S X=$P(LROD1,U,4),(LROOS,LROS)=$S(X="C":"Collected",X="U":"Uncollected, cancelled",1:"On Collection List") S:X="C" LROT=""

 I '(+LRACN0) W !!,"BAD ORDER ",LRSN,!,$C(7) D WAIT Q

 G NOTACC:LROD1="" ;,NOTACC:$P(LROD1,"^",4)="U"

TST1 S X1=+$P(LRACN0,U,4),X2=+$P(LRACN0,U,3),X3=+$P(LRACN0,U,5)

 G NOTACC:'$D(^LRO(68,X1,1,X2,1,X3,0)),NOTACC:'$D(^(3)) S LRACD=$S($D(^(9)):^(9),1:"")

 I '$D(LRTT(X1,X2,X3)) S LRTT(X1,X2,X3)="",I=0 F  S I=$O(^LRO(68,X1,1,X2,1,X3,4,I)) Q:I<.5!($G(LREND))  S LRACC=^(I,0),LRTSTS=+LRACC D TST2

 I $E($P(LROD1,U,6))="*" W !,?20,$P(LROD1,U,6) D WAIT

 Q

TST2 ;

 N I

 S LRURG=+$P(LRACC,U,2) I LRURG>49 Q

 I 'LRTSTS W !!,"BAD ACCESSION TEST POINTER: ",LRTSTS Q

 S LROT="",LROS=LROOS,LRLL=$P(LRACC,U,3),Y=$P(LRACC,U,5) I Y S LROS=$S($E($P(LRACC,U,6))="*":$P(LRACC,U,6),1:"Test Complete") D DATE S LROSD=Y D WRITE,COM(1.1),COM(1) Q

 S Y=$P(LROD3,U) D DATE S LROSD=Y I LRLL S LROS="Testing In Progress"

 I $P(LROD1,"^",4)="U" S (LROS,LROOS)=""

 D WRITE,COM(1.1),COM(1)

 Q

WRITE ;

 W !?2,$S($D(^LAB(60,+LRTSTS,0)):$P(^(0),U),1:"BAD TEST POINTER")

 I $X>20 W ! D WAIT Q:(LREND)

 W ?20,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," " D WAIT Q:$G(LREND)

 I $X>28 W ! D WAIT Q:$G(LREND)

 W ?28,LROT," ",LROS,?43," ",LROSD

 ; W:X3 ?60," ",$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")

 W:X3 ?62,$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")                ; IHS/OIT/MKK - LR*5.2*1030

 ; I LRROD W !?46,"  See order: ",LRROD D WAIT

 I LRROD W !?46,"  See order: " D REVIDEO^BLRUTIL3(" "_LRROD_" ")  D WAIT   ; IHS/OIT/MKK - LR*5.2*1030

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

 ;IHS/ITSC/TPF 11/08/02 'SIGN OR SYMPTOM' LAB POV **1015**

 ; W !,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))

 ; W:$L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) !,?2,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))     ; IHS/OIT/MKK - LR*5.2*1030

 ;----- END IHS MODIFICATIONS

 ;

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033 - Changed 'Sign or Symptom'

 W:$L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) !,?2,"Clinical Indication: ",$G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))

 ; I $L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) D

 ; . W !,?2,"Clinical Indication: ",$$GET1^DIQ(69.03,LRACN_","_LRSN_","_LRODT,"PROVIDER NARRATIVE")

 ; . W !,?15,"SNOMED: ",$$GET1^DIQ(69.03,LRACN_","_LRSN_","_LRODT,"SNOMED")

 ; . W !,?18,"ICD: ",$$GET1^DIQ(69.05,"1,"_LRACN_","_LRSN_","_LRODT,.01)

 ; ----- END IHS/MSC/MKK - LR*5.2*1033

 ;

 Q

COM(LRMMODE) ;

 ;Write comments

 ;LRMMODE=comments node to display

 N LRTSTI

 S:'$G(LRMMODE) LRMMODE=1

 S LRTSTI=$O(^LRO(69,LRODT,1,LRSN,2,"B",+LRTSTS,0)) Q:'LRTSTI

 D COMWRT(LRODT,LRSN,LRTSTI,LRMMODE,3)

 Q

COMWRT(LRODT,LRSN,LRTSTI,NODE,TAB) ;

 ;Write comment node

 I $S('LRODT:1,'LRSN:1,'LRTSTI:1,'NODE:1,1:0) Q

 Q:'$D(^LRO(69,LRODT,1,LRSN,2,LRTSTI))

 S:'$G(TAB) TAB=3

 N LRI

 S LRI=0 F  S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI)) Q:LRI<1!($G(LREND))  W:$D(^(LRI,0)) !?TAB,": "_^(0) D WAIT

 Q

NOTACC I $G(LROD3)="" S LROS="" G NO2

 I $P(LROD3,U,2)'="" S LROS=" ",Y=$P(LROD3,U,2) G NO2

 S Y=$P(LROD3,U) S LROS=" "

NO2 S:'Y Y=$P(LROD0,U,8) S Y=$S(Y:Y,+LROD3:+LROD3,+LROD1:+LROD1,1:LRODT) D DATE S LROSD=Y

 S LRTSTS=+LRACN0,LRURG=$P(LRACN0,U,2)

 S LROS=$S(LRROD:"Combined",1:LROS) S:LROS="" LROS="for: "

 I LRTSTS D WRITE,COM(1.1),COM(1) ;second call for backward compatibility - can be removed in future years (1/98)

 I $L($P(LROD1,U,6)) W !,?20,$P(LROD1,U,6) D WAIT

 Q

DATE S Y=$$FMTE^XLFDT(Y,"5MZ") Q

HED ; D WAIT:$E(IOST,1)="C"&($Y>18) Q:$G(LREND)  W @IOF,!,"  Test",?20,"Urgency",?30,"Status",?64,"Accession"

 D WAIT:$E(IOST,1)="C"&($Y>18) Q:$G(LREND)  W @IOF,!,"  Test",?20,"Urgency",?30,"Status",?62,"Accession"  ; IHS/OIT/MKK - LR*5.2*1030

ENT ;from LROE, LROE1, LRORD1, LROW2

 Q

LREND I $E(IOST)="P" W @IOF

 S:$D(ZTQUEUED) ZTREQ="@"

 K LRLDAT,LRURG,LROSD,LRTT,LROS,LROOS,LRROD,X1,X2,X3,%,A,DFN,DIC,I,K,LRACC,LRACN,LRACN0,LRDFN,LRDOC,LRDPF,LREND,LRLL,LROD0,LROD1,LROD3,LRODT,LROT,LRSDT,LRSN,LRTSTS,X,X4,Y,Z,%Y,DIWL,DIWR,DPF,PNM Q

SHOW ;call with LRSN,LRODT, from LRCENDEL, LRTSTJAN

 S LREND=0

 W !,"Order  Test",?20,"Urgency",?30,"Status",?64,"Accession" D ORDER Q

WAIT Q:$Y<(IOSL-3)  I $E(IOST)'="C" W @IOF Q

 W !,"  PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S LREND=".^"[X Q:$G(LREND)  W @IOF

 Q

CANC ;For Canceled tests

 S LRTSTS=+$G(LRACN0),LROT="*Canceled by: "_$P(^VA(200,$P(LRACN0,"^",11),0),U)

 I LRTSTS D WRITE,COM(1.1),COM(1) ;second call for backward compatitility - can be removed in future years (1/98)

 Q

OERR(X) ;Get order status for predefined patient

 ;X=DFN;DPT(   <--ORVP FORMAT

 I '$G(X) W !!?5,"NO PATIENT SELECTED",! H 2 Q

 N DFN,LRDPA,LRDFN,LRDT0,VA200

 S DFN=+X,LRDPF=+$P(@("^"_$P(X,";",2)_"0)"),"^",2)_"^"_$P(X,";",2)

 D END^LRDPA

 Q:LRDFN=-1

 W !,"Lab test status for: "_$P(^DPT(DFN,0),"^")

 D L0

 Q

LROS      ;SLC/CJS/DALOI/FHS-LAB ORDER STATUS ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LR;**1003,1004,1015,1018,1030,1033**;NOV 01, 1997

 +2       ;;5.2;LAB SERVICE;**121,153,202,210,221,263**;Sep 27, 1994

 +3       ; Variable to indicate to lookup patients, prevent adding new entries in ^LRDPA

           NEW LRLOOKUP

           SET LRLOOKUP=1

EN         KILL DIC,LRDPAF,%DT("B")

           SET DIC(0)="A"

 +1        DO ^LRDPA

           IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)

               GOTO LREND

           DO L0

           GOTO EN

L0         DO ENT

           SET %DT=""

           DO DT^LRX

L1         SET LREND=0

           SET %DT="E"

           SET %DT("A")="DATE to begin review: "

           DO DATE^LRWU

           IF Y<1

               GOTO LREND

           SET (LRSDT,LRODT)=Y

           SET %DT=""

           SET X="T-"_$SELECT($PIECE($GET(^LAB(69.9,1,0)),U,9):$PIECE(^(0),U,9),1:30)

           DO ^%DT

           SET LRLDAT=Y

L2        ; S LRSN=$O(^LRO(69,LRODT,1,"AA",LRDFN,0)) I LRSN<1 S Y=LRODT D DD^LRX W !,"No orders for ",Y S X1=LRODT,X2=-1 D C^%DTC S LRODT=X I LRODT<LRLDAT W !!,"NO REMAINING ACTIVE ORDERS",! G LREND

 +1       ; IHS/OIT/MKK - LR*5.2*1030

           SET LRSN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,0))

           IF LRSN<1

               SET Y=LRODT

               DO DD^LRX

               SET X1=LRODT

               SET X2=-1

               DO C^%DTC

               SET LRODT=X

               IF LRODT<LRLDAT

                   WRITE !!,"NO REMAINING ACTIVE ORDERS",!

                   GOTO LREND

 +2        IF $Y>18

               DO WAIT

           IF LREND

               GOTO LREND

           IF LRSN<1

               GOTO L2

 +3        IF LRSDT'=LRODT

               WRITE !,"Orders for date: "

               SET Y=LRODT

               DO DD^LRX

               WRITE Y," OK"

               SET %=1

               DO YN^DICN

               IF %'=1

                   GOTO LREND

 +4        DO ENTRY

           IF LREND

               GOTO LREND

           SET X1=LRODT

           SET X2=-1

           DO C^%DTC

           SET LRODT=X

 +5        GOTO L2

ENTRY      DO HED

           IF LREND

               QUIT 

 +1        SET LRSN=0

           FOR 

               SET LRSN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,LRSN))

               IF LRSN<1!($GET(LREND))

                   QUIT 

               DO ORDER

               IF $GET(LREND)

                   QUIT 

               IF $Y>(IOSL-2)

                   DO HED

 +2        QUIT 

ORDER     ;call with LRSN, from LROE, LROE1, LRORD1, LROW2, LROR1

 +1        KILL D,LRTT

           SET LREND=0

 +2        IF '$DATA(^LRO(69,LRODT,1,LRSN,0))

               QUIT 

           SET LROD0=^LRO(69,LRODT,1,LRSN,0)

           SET LROD1=$SELECT($DATA(^(1)):^(1),1:"")

           SET LROD3=$SELECT($DATA(^(3)):^(3),1:"")

 +3       ; W !?2,"-Lab Order # ",$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:"") S X=$P(LROD0,U,6) D DOC^LRX W ?45,"Provider: ",$E(LRDOC,1,25) D WAIT Q:$G(LREND)

 +4       ; IHS/OIT/MKK - LR*5.2*1030

           WRITE !,"Lab Order # "

           DO REVIDEO^BLRUTIL3($SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):" "_^(.1)_" ",1:""))

           SET X=$PIECE(LROD0,U,6)

           DO DOC^LRX

           WRITE ?45,"Provider: ",$EXTRACT(LRDOC,1,25)

           DO WAIT

           IF $GET(LREND)

               QUIT 

 +5        SET X=$PIECE(LROD0,U,3)

           SET X=$SELECT(X:$SELECT($DATA(^LAB(62,+X,0)):$PIECE(^(0),U),1:""),1:"")

           SET X4=""

           IF $DATA(^LRO(69,LRODT,1,LRSN,4,1,0))

               IF +^(0)

                   SET X4=+^(0)

                   SET X4=$SELECT($DATA(^LAB(61,X4,0)):$PIECE(^(0),U),1:"")

 +6        IF $EXTRACT($PIECE(LROD1,U,6))="*"

               WRITE !?3,$PIECE(LROD1,U,6)

               DO WAIT

               IF $GET(LREND)

                   QUIT 

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

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

               DO WAIT

               IF $GET(LREND)

                   QUIT 

 +8        WRITE !?2,X,"  "

           IF X'[X4

               WRITE X4

           SET I=0

           FOR 

               SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))

               IF I<1!($GET(LREND))

                   QUIT 

               WRITE !?5,": ",^(I,0)

               DO WAIT

               IF $GET(LREND)

                   QUIT 

 +9        SET LRACN=0

           FOR 

               SET LRACN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRACN))

               IF LRACN<1!($GET(LREND))

                   QUIT 

               IF $DATA(^(LRACN,0))#2

                   SET LRACN0=^(0)

                   DO TEST

 +10       QUIT 

TEST       NEW LRY,LRURG

 +1        SET LRROD=$PIECE(LRACN0,U,6)

           SET (Y,LRLL,LROT,LROS,LROSD,LRURG)=""

           SET X3=0

 +2        IF $PIECE(LRACN0,"^",11)

               GOTO CANC

 +3        SET X=$PIECE(LROD0,U,4)

           SET LROT=$SELECT(X="WC":"Requested (WARD COL)",X="SP":"Requested (SEND PATIENT)",X="LC":"Requested (LAB COL)",X="I":"Requested (IMM LAB COL)",1:"undetermined")

 +4        SET X=$PIECE(LROD1,U,4)

           SET (LROOS,LROS)=$SELECT(X="C":"Collected",X="U":"Uncollected, cancelled",1:"On Collection List")

           IF X="C"

               SET LROT=""

 +5        IF '(+LRACN0)

               WRITE !!,"BAD ORDER ",LRSN,!,$CHAR(7)

               DO WAIT

               QUIT 

 +6       ;,NOTACC:$P(LROD1,"^",4)="U"

           IF LROD1=""

               GOTO NOTACC

TST1       SET X1=+$PIECE(LRACN0,U,4)

           SET X2=+$PIECE(LRACN0,U,3)

           SET X3=+$PIECE(LRACN0,U,5)

 +1        IF '$DATA(^LRO(68,X1,1,X2,1,X3,0))

               GOTO NOTACC

           IF '$DATA(^(3))

               GOTO NOTACC

           SET LRACD=$SELECT($DATA(^(9)):^(9),1:"")

 +2        IF '$DATA(LRTT(X1,X2,X3))

               SET LRTT(X1,X2,X3)=""

               SET I=0

               FOR 

                   SET I=$ORDER(^LRO(68,X1,1,X2,1,X3,4,I))

                   IF I<.5!($GET(LREND))

                       QUIT 

                   SET LRACC=^(I,0)

                   SET LRTSTS=+LRACC

                   DO TST2

 +3        IF $EXTRACT($PIECE(LROD1,U,6))="*"

               WRITE !,?20,$PIECE(LROD1,U,6)

               DO WAIT

 +4        QUIT 

TST2      ;

 +1        NEW I

 +2        SET LRURG=+$PIECE(LRACC,U,2)

           IF LRURG>49

               QUIT 

 +3        IF 'LRTSTS

               WRITE !!,"BAD ACCESSION TEST POINTER: ",LRTSTS

               QUIT 

 +4        SET LROT=""

           SET LROS=LROOS

           SET LRLL=$PIECE(LRACC,U,3)

           SET Y=$PIECE(LRACC,U,5)

           IF Y

               SET LROS=$SELECT($EXTRACT($PIECE(LRACC,U,6))="*":$PIECE(LRACC,U,6),1:"Test Complete")

               DO DATE

               SET LROSD=Y

               DO WRITE

               DO COM(1.1)

               DO COM(1)

               QUIT 

 +5        SET Y=$PIECE(LROD3,U)

           DO DATE

           SET LROSD=Y

           IF LRLL

               SET LROS="Testing In Progress"

 +6        IF $PIECE(LROD1,"^",4)="U"

               SET (LROS,LROOS)=""

 +7        DO WRITE

           DO COM(1.1)

           DO COM(1)

 +8        QUIT 

WRITE     ;

 +1        WRITE !?2,$SELECT($DATA(^LAB(60,+LRTSTS,0)):$PIECE(^(0),U),1:"BAD TEST POINTER")

 +2        IF $X>20

               WRITE !

               DO WAIT

               IF (LREND)

                   QUIT 

 +3        WRITE ?20,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "

           DO WAIT

           IF $GET(LREND)

               QUIT 

 +4        IF $X>28

               WRITE !

               DO WAIT

               IF $GET(LREND)

                   QUIT 

 +5        WRITE ?28,LROT," ",LROS,?43," ",LROSD

 +6       ; W:X3 ?60," ",$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")

 +7       ; IHS/OIT/MKK - LR*5.2*1030

           IF X3

               WRITE ?62,$SELECT($DATA(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")

 +8       ; I LRROD W !?46,"  See order: ",LRROD D WAIT

 +9       ; IHS/OIT/MKK - LR*5.2*1030

           IF LRROD

               WRITE !?46,"  See order: "

               DO REVIDEO^BLRUTIL3(" "_LRROD_" ")

               DO WAIT

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

 +11      ;IHS/ITSC/TPF 11/08/02 'SIGN OR SYMPTOM' LAB POV **1015**

 +12      ; W !,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))

 +13      ; W:$L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) !,?2,"Sign or Symptom: ",$G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))     ; IHS/OIT/MKK - LR*5.2*1030

 +14      ;----- END IHS MODIFICATIONS

 +15      ;

 +16      ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033 - Changed 'Sign or Symptom'

 +17       IF $LENGTH($GET(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999)))

               WRITE !,?2,"Clinical Indication: ",$GET(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))

 +18      ; I $L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) D

 +19      ; . W !,?2,"Clinical Indication: ",$$GET1^DIQ(69.03,LRACN_","_LRSN_","_LRODT,"PROVIDER NARRATIVE")

 +20      ; . W !,?15,"SNOMED: ",$$GET1^DIQ(69.03,LRACN_","_LRSN_","_LRODT,"SNOMED")

 +21      ; . W !,?18,"ICD: ",$$GET1^DIQ(69.05,"1,"_LRACN_","_LRSN_","_LRODT,.01)

 +22      ; ----- END IHS/MSC/MKK - LR*5.2*1033

 +23      ;

 +24       QUIT 

COM(LRMMODE) ;

 +1       ;Write comments

 +2       ;LRMMODE=comments node to display

 +3        NEW LRTSTI

 +4        IF '$GET(LRMMODE)

               SET LRMMODE=1

 +5        SET LRTSTI=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+LRTSTS,0))

           IF 'LRTSTI

               QUIT 

 +6        DO COMWRT(LRODT,LRSN,LRTSTI,LRMMODE,3)

 +7        QUIT 

COMWRT(LRODT,LRSN,LRTSTI,NODE,TAB) ;

 +1       ;Write comment node

 +2        IF $SELECT('LRODT:1,'LRSN:1,'LRTSTI:1,'NODE:1,1:0)

               QUIT 

 +3        IF '$DATA(^LRO(69,LRODT,1,LRSN,2,LRTSTI))

               QUIT 

 +4        IF '$GET(TAB)

               SET TAB=3

 +5        NEW LRI

 +6        SET LRI=0

           FOR 

               SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI))

               IF LRI<1!($GET(LREND))

                   QUIT 

               IF $DATA(^(LRI,0))

                   WRITE !?TAB,": "_^(0)

               DO WAIT

 +7        QUIT 

NOTACC     IF $GET(LROD3)=""

               SET LROS=""

               GOTO NO2

 +1        IF $PIECE(LROD3,U,2)'=""

               SET LROS=" "

               SET Y=$PIECE(LROD3,U,2)

               GOTO NO2

 +2        SET Y=$PIECE(LROD3,U)

           SET LROS=" "

NO2        IF 'Y

               SET Y=$PIECE(LROD0,U,8)

           SET Y=$SELECT(Y:Y,+LROD3:+LROD3,+LROD1:+LROD1,1:LRODT)

           DO DATE

           SET LROSD=Y

 +1        SET LRTSTS=+LRACN0

           SET LRURG=$PIECE(LRACN0,U,2)

 +2        SET LROS=$SELECT(LRROD:"Combined",1:LROS)

           IF LROS=""

               SET LROS="for: "

 +3       ;second call for backward compatibility - can be removed in future years (1/98)

           IF LRTSTS

               DO WRITE

               DO COM(1.1)

               DO COM(1)

 +4        IF $LENGTH($PIECE(LROD1,U,6))

               WRITE !,?20,$PIECE(LROD1,U,6)

               DO WAIT

 +5        QUIT 

DATE       SET Y=$$FMTE^XLFDT(Y,"5MZ")

           QUIT 

HED       ; D WAIT:$E(IOST,1)="C"&($Y>18) Q:$G(LREND)  W @IOF,!,"  Test",?20,"Urgency",?30,"Status",?64,"Accession"

 +1       ; IHS/OIT/MKK - LR*5.2*1030

           IF $EXTRACT(IOST,1)="C"&($Y>18)

               DO WAIT

           IF $GET(LREND)

               QUIT 

           WRITE @IOF,!,"  Test",?20,"Urgency",?30,"Status",?62,"Accession"

ENT       ;from LROE, LROE1, LRORD1, LROW2

 +1        QUIT 

LREND      IF $EXTRACT(IOST)="P"

               WRITE @IOF

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        KILL LRLDAT,LRURG,LROSD,LRTT,LROS,LROOS,LRROD,X1,X2,X3,%,A,DFN,DIC,I,K,LRACC,LRACN,LRACN0,LRDFN,LRDOC,LRDPF,LREND,LRLL,LROD0,LROD1,LROD3,LRODT,LROT,LRSDT,LRSN,LRTSTS,X,X4,Y,Z,%Y,DIWL,DIWR,DPF,PNM

           QUIT 

SHOW      ;call with LRSN,LRODT, from LRCENDEL, LRTSTJAN

 +1        SET LREND=0

 +2        WRITE !,"Order  Test",?20,"Urgency",?30,"Status",?64,"Accession"

           DO ORDER

           QUIT 

WAIT       IF $Y<(IOSL-3)

               QUIT 

           IF $EXTRACT(IOST)'="C"

               WRITE @IOF

               QUIT 

 +1        WRITE !,"  PRESS '^' TO STOP "

           READ X:DTIME

           IF X=""

               SET X=1

           SET LREND=".^"[X

           IF $GET(LREND)

               QUIT 

           WRITE @IOF

 +2        QUIT 

CANC      ;For Canceled tests

 +1        SET LRTSTS=+$GET(LRACN0)

           SET LROT="*Canceled by: "_$PIECE(^VA(200,$PIECE(LRACN0,"^",11),0),U)

 +2       ;second call for backward compatitility - can be removed in future years (1/98)

           IF LRTSTS

               DO WRITE

               DO COM(1.1)

               DO COM(1)

 +3        QUIT 

OERR(X)   ;Get order status for predefined patient

 +1       ;X=DFN;DPT(   <--ORVP FORMAT

 +2        IF '$GET(X)

               WRITE !!?5,"NO PATIENT SELECTED",!

               HANG 2

               QUIT 

 +3        NEW DFN,LRDPA,LRDFN,LRDT0,VA200

 +4        SET DFN=+X

           SET LRDPF=+$PIECE(@("^"_$PIECE(X,";",2)_"0)"),"^",2)_"^"_$PIECE(X,";",2)

 +5        DO END^LRDPA

 +6        IF LRDFN=-1

               QUIT 

 +7        WRITE !,"Lab test status for: "_$PIECE(^DPT(DFN,0),"^")

 +8        DO L0

 +9        QUIT