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 ---[H[J[2J[HLROS 7578 printed Nov 22, 2024@17:29:05 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
+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
