LROS.m

LROS ;SLC/CJS/DALOI/FHS-LAB ORDER STATUS; May 23, 2024@15:45

 ;;5.2;LAB SERVICE;**121,153,202,210,221,263,450,462,572**;Sep 27, 1994;Build 5

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

 ;;*

 N AGE,DOB,DOD,LRLABKY,LRPRAC,LRRB,LRTREA,LRWRD,SEX,SSN,VAPD

 ;;;*

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

 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

 ;LR*5.2*572: add LRARRAY

 N LRARRAY

 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)

 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)!($P(LRACN0,U,9)="CA") 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

 ;LR*5.2*572: Display any tests in "rolled over" date that

 ;            were not on original accession date.

 I LRACD]"" D

 . S I=0

 . F  S I=$O(^LRO(68,X1,1,LRACD,1,X3,4,I)) Q:I<.5!($G(LREND))  D

 . . Q:$D(^LRO(68,X1,1,X2,1,X3,4,I))

 . . Q:$D(LRARRAY(X1,LRACD,X3,I))

 . . S LRACC=^LRO(68,X1,1,LRACD,1,X3,4,I,0),LRTSTS=+LRACC D TST2

 . . S LRARRAY(X1,LRACD,X3,I)=""

 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:"")

 I LRROD W !?46,"  See order: ",LRROD D WAIT Q:$G(LREND)

 ;;*

APDATA ; Display CPRS AP Dialog

 I $O(^LRO(69,LRODT,1,LRSN,4,1,0)) D

 . ;

 . N DIC,DR,DA,S,LREND

 . D WAIT Q:$G(LREND)

 . W !,$$CJ^XLFSTR("+++++++++++++++   SPECIMEN DATA  +++++++++++++++",IOM),!

 . S DIC="^LRO(69,"_LRODT_",1,",S=$Y

 . S DR=4,DA=LRSN,DA(1)=LRSN,DA(2)=LRODT

 . D EN^DIQ

 . W !,$$CJ^XLFSTR("=================   END OF SPECIMEN DATA ==================",IOM)

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

 . D WAIT Q:$G(LREND)

 . I $O(^LRO(69,LRODT,1,LRSN,13,0)) D

 . . W !!,$$CJ^XLFSTR("+++++++++++++++ DIALOG RESPONSE  +++++++++++++++",IOM)

 . . N DIC,DR,DA,S,LREND

 . . S DIC="^LRO(69,"_LRODT_",1,",S=$Y

 . . S DR=4,DA=LRSN,DA(1)=LRSN,DA(2)=LRODT

 . . S DR="11:16" D EN^DIQ

 . . W !,$$CJ^XLFSTR("================== END OF DIALOG RESPONSE ==================",IOM)

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

 . D WAIT

 ;;;*

 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"

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: "_$S($P(LRANC0,U,11):$P(^VA(200,$P(LRACN0,"^",11),0),U),1:"Not Specified")

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

 ;;;*

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LROS   7578     printed  Mar 13, 2025@21:23:30                                                                                                                                                                                                        Page 2

LROS      ;SLC/CJS/DALOI/FHS-LAB ORDER STATUS; May 23, 2024@15:45

 +1       ;;5.2;LAB SERVICE;**121,153,202,210,221,263,450,462,572**;Sep 27, 1994;Build 5

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

           NEW LRLOOKUP

           SET LRLOOKUP=1

 +3       ;;*

 +4        NEW AGE,DOB,DOD,LRLABKY,LRPRAC,LRRB,LRTREA,LRWRD,SEX,SSN,VAPD

 +5       ;;;*

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         SET LRSN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,0))

           IF LRSN<1

               SET Y=LRODT

               DO DD^LRX

               WRITE !,"No orders for ",Y

               SET X1=LRODT

               SET X2=-1

               DO C^%DTC

               SET LRODT=X

               IF LRODT<LRLDAT

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

                   GOTO LREND

 +1        if $Y>18

               DO WAIT

           if LREND

               GOTO LREND

           if LRSN<1

               GOTO L2

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

 +3        DO ENTRY

           if LREND

               GOTO LREND

           SET X1=LRODT

           SET X2=-1

           DO C^%DTC

           SET LRODT=X

 +4        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       ;LR*5.2*572: add LRARRAY

 +2        NEW LRARRAY

 +3        KILL D,LRTT

           SET LREND=0

 +4        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:"")

 +5        WRITE !?2,"-Lab Order # ",$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 

 +6        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:"")

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

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

               DO WAIT

               if $GET(LREND)

                   QUIT 

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

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

               DO WAIT

               if $GET(LREND)

                   QUIT 

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

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

 +11       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)!($PIECE(LRACN0,U,9)="CA")

               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       ;LR*5.2*572: Display any tests in "rolled over" date that

 +4       ;            were not on original accession date.

 +5        IF LRACD]""

               Begin DoDot:1

 +6                SET I=0

 +7                FOR 

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

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

                           QUIT 

                       Begin DoDot:2

 +8                        if $DATA(^LRO(68,X1,1,X2,1,X3,4,I))

                               QUIT 

 +9                        if $DATA(LRARRAY(X1,LRACD,X3,I))

                               QUIT 

 +10                       SET LRACC=^LRO(68,X1,1,LRACD,1,X3,4,I,0)

                           SET LRTSTS=+LRACC

                           DO TST2

 +11                       SET LRARRAY(X1,LRACD,X3,I)=""

                       End DoDot:2

               End DoDot:1

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

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

               DO WAIT

 +13       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        if X3

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

 +7        IF LRROD

               WRITE !?46,"  See order: ",LRROD

               DO WAIT

               if $GET(LREND)

                   QUIT 

 +8       ;;*

APDATA    ; Display CPRS AP Dialog

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

               Begin DoDot:1

 +2       ;

 +3                NEW DIC,DR,DA,S,LREND

 +4                DO WAIT

                   if $GET(LREND)

                       QUIT 

 +5                WRITE !,$$CJ^XLFSTR("+++++++++++++++   SPECIMEN DATA  +++++++++++++++",IOM),!

 +6                SET DIC="^LRO(69,"_LRODT_",1,"

                   SET S=$Y

 +7                SET DR=4

                   SET DA=LRSN

                   SET DA(1)=LRSN

                   SET DA(2)=LRODT

 +8                DO EN^DIQ

 +9                WRITE !,$$CJ^XLFSTR("=================   END OF SPECIMEN DATA ==================",IOM)

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

                   READ X:DTIME

                   if X=""

                       SET X=1

                   SET LREND=".^"[X

                   if $GET(LREND)

                       QUIT 

                   WRITE @IOF

 +11               DO WAIT

                   if $GET(LREND)

                       QUIT 

 +12               IF $ORDER(^LRO(69,LRODT,1,LRSN,13,0))

                       Begin DoDot:2

 +13                       WRITE !!,$$CJ^XLFSTR("+++++++++++++++ DIALOG RESPONSE  +++++++++++++++",IOM)

 +14                       NEW DIC,DR,DA,S,LREND

 +15                       SET DIC="^LRO(69,"_LRODT_",1,"

                           SET S=$Y

 +16                       SET DR=4

                           SET DA=LRSN

                           SET DA(1)=LRSN

                           SET DA(2)=LRODT

 +17                       SET DR="11:16"

                           DO EN^DIQ

 +18                       WRITE !,$$CJ^XLFSTR("================== END OF DIALOG RESPONSE ==================",IOM)

                       End DoDot:2

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

                   READ X:DTIME

                   if X=""

                       SET X=1

                   SET LREND=".^"[X

                   if $GET(LREND)

                       QUIT 

                   WRITE @IOF

 +20               DO WAIT

               End DoDot:1

 +21      ;;;*

 +22       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        if $EXTRACT(IOST,1)="C"&($Y>18)

               DO WAIT

           if $GET(LREND)

               QUIT 

           WRITE @IOF,!,"  Test",?20,"Urgency",?30,"Status",?64,"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       ;;*

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

 +3        SET LRTSTS=+$GET(LRACN0)

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

 +4       ;;;*

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

           IF LRTSTS

               DO WRITE

               DO COM(1.1)

               DO COM(1)

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