LR7OSOS ;slc/dcm - Lab order status for OE/RR ;8/11/97
;;5.2;LAB SERVICE;**121,201,187,230**;Sep 27, 1994
EN(OMEGA,ALPHA) ;'...the last shall be first...the first shall be last'
N LRODT,LRSN,LREND
U IO
S LRODT=$S($G(ALPHA):ALPHA,1:""),LREND=0
F S LRODT=$O(^LRO(69,"D",LRDFN,LRODT),-1) Q:LRODT<1!(LRODT<OMEGA) D ENTRY Q:LREND
Q
ENTRY D HED
S LRSN=0
F S LRSN=$O(^LRO(69,"D",LRDFN,LRODT,LRSN)) Q:LRSN<1 D ORDER,HED:$Y>(IOSL-3) Q:LREND
Q
ORDER ;call with LRODT,LRSN
N LROD0,LROD1,LROD3,X,LRDOC,X4,I,LRACN,LRACN0
K D,LRTT 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)
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:"")
W !?2,X," " W:X'[X4 X4 S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 W !?5,": ",^(I,0)
S LRACN=0 F S LRACN=$O(^LRO(69,LRODT,1,LRSN,2,LRACN)) Q:LRACN<1 I $D(^(LRACN,0))#2 S LRACN0=^(0) D TEST
Q
TEST ;
N LRY,LRURG,LRROD,Y,LRLL,LROT,LROS,LROOS,LROSD,LRURG,X3,X,X1,X2,LRACD,LRACC,LRTSTS
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) Q
G NOTACC:LROD1=""
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 S LRACC=^(I,0),LRTSTS=+LRACC D TST2
W:$L($P(LROD1,U,6)) !,?20,$P(LROD1,U,6)
Q
TST2 ;
N I,LRURG,LROT,LROS,LRLL,Y,LROSD
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="Test Complete" D DATE S LROSD=Y D WRITE,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)
Q
WRITE ;
W !?2,$S($D(^LAB(60,+LRTSTS,0)):$P(^(0),U),1:"BAD TEST POINTER") W:$X>20 ! W ?20,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," "
W:$X>28 ! W ?28,LROT," ",LROS,?48," ",LROSD
W:X3 ?62," ",$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"") W:LRROD !?46," See order: ",LRROD
Q
COM(COMNODE) ;Write comment
;COMNODE=Comment node to write
S:'$G(COMNODE) COMNODE=1
I LRTSTS=+LRACN0 S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRACN,COMNODE,I)) Q:I<1 W !?3,": "_^(I,0)
Q
NOTACC I 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: "
D WRITE:LRTSTS,COM(1)
W:$L($P(LROD1,U,6)) !,?20,$P(LROD1,U,6)
Q
DATE S Y=$$FMTE^XLFDT($P(Y,"."),"5Z")_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
HED D WAIT:$E(IOST,1)="C"&($Y>21) Q:LREND
I $O(^LRO(69,"D",LRDFN,LRODT,0)) W !!,"Orders for date: " S Y=LRODT D DD^LRX W Y
W @IOF," Test",?20,"Urgency",?30,"Status",?64,"Accession"
Q
WAIT W !," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S LREND=".^"[X
Q
CANC ;For Canceled tests
N LRTSTS
S LRTSTS=+LRACN0,LROT="Canceled by: "_$P(^VA(200,$P(LRACN0,"^",11),0),"^")
D WRITE:LRTSTS,COM(1.1),COM(1) ;second call for backward compatibility - can be removed in future years (1/98)
Q
OERR(X,ALPHA,OMEGA) ;Get order status for predefined patient
;X=DFN;DPT( <--ORVP FORMAT
;ALPHA=start date
;OMEGA=end date
I '$G(X) W !!?5,"NO PATIENT SELECTED",! H 2 Q
Q:'$G(ALPHA) Q:'$G(OMEGA)
N DFN,LRDFN,LRDPF,LRDT0,VA200
S DFN=+X,LRDPF=+$P(@("^"_$P(X,";",2)_"0)"),"^",2)_"^"_$P(X,";",2),LRDFN=$$LRDFN^LR7OR1(DFN)
Q:'LRDFN
W !,"Lab test status for: "_$P(^DPT(DFN,0),"^")
D EN(ALPHA,OMEGA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSOS 4307 printed Apr 09, 2024@21:07:33 Page 2
LR7OSOS ;slc/dcm - Lab order status for OE/RR ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,201,187,230**;Sep 27, 1994
EN(OMEGA,ALPHA) ;'...the last shall be first...the first shall be last'
+1 NEW LRODT,LRSN,LREND
+2 USE IO
+3 SET LRODT=$SELECT($GET(ALPHA):ALPHA,1:"")
SET LREND=0
+4 FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT),-1)
if LRODT<1!(LRODT<OMEGA)
QUIT
DO ENTRY
if LREND
QUIT
+5 QUIT
ENTRY DO HED
+1 SET LRSN=0
+2 FOR
SET LRSN=$ORDER(^LRO(69,"D",LRDFN,LRODT,LRSN))
if LRSN<1
QUIT
DO ORDER
if $Y>(IOSL-3)
DO HED
if LREND
QUIT
+3 QUIT
ORDER ;call with LRODT,LRSN
+1 NEW LROD0,LROD1,LROD3,X,LRDOC,X4,I,LRACN,LRACN0
+2 KILL D,LRTT
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 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)
+4 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:"")
+5 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
QUIT
WRITE !?5,": ",^(I,0)
+6 SET LRACN=0
FOR
SET LRACN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRACN))
if LRACN<1
QUIT
IF $DATA(^(LRACN,0))#2
SET LRACN0=^(0)
DO TEST
+7 QUIT
TEST ;
+1 NEW LRY,LRURG,LRROD,Y,LRLL,LROT,LROS,LROOS,LROSD,LRURG,X3,X,X1,X2,LRACD,LRACC,LRTSTS
+2 SET LRROD=$PIECE(LRACN0,U,6)
SET (Y,LRLL,LROT,LROS,LROSD,LRURG)=""
SET X3=0
+3 IF $PIECE(LRACN0,"^",11)
GOTO CANC
+4 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")
+5 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=""
IF '(+LRACN0)
WRITE !!,"BAD ORDER ",LRSN,!,$CHAR(7)
QUIT
+6 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
QUIT
SET LRACC=^(I,0)
SET LRTSTS=+LRACC
DO TST2
+3 if $LENGTH($PIECE(LROD1,U,6))
WRITE !,?20,$PIECE(LROD1,U,6)
+4 QUIT
TST2 ;
+1 NEW I,LRURG,LROT,LROS,LRLL,Y,LROSD
+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="Test Complete"
DO DATE
SET LROSD=Y
DO WRITE
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)
+8 QUIT
WRITE ;
+1 WRITE !?2,$SELECT($DATA(^LAB(60,+LRTSTS,0)):$PIECE(^(0),U),1:"BAD TEST POINTER")
if $X>20
WRITE !
WRITE ?20,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
+2 if $X>28
WRITE !
WRITE ?28,LROT," ",LROS,?48," ",LROSD
+3 if X3
WRITE ?62," ",$SELECT($DATA(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")
if LRROD
WRITE !?46," See order: ",LRROD
+4 QUIT
COM(COMNODE) ;Write comment
+1 ;COMNODE=Comment node to write
+2 if '$GET(COMNODE)
SET COMNODE=1
+3 IF LRTSTS=+LRACN0
SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRACN,COMNODE,I))
if I<1
QUIT
WRITE !?3,": "_^(I,0)
+4 QUIT
NOTACC IF 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 if LRTSTS
DO WRITE
DO COM(1)
+4 if $LENGTH($PIECE(LROD1,U,6))
WRITE !,?20,$PIECE(LROD1,U,6)
+5 QUIT
DATE SET Y=$$FMTE^XLFDT($PIECE(Y,"."),"5Z")_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
QUIT
HED if $EXTRACT(IOST,1)="C"&($Y>21)
DO WAIT
if LREND
QUIT
+1 IF $ORDER(^LRO(69,"D",LRDFN,LRODT,0))
WRITE !!,"Orders for date: "
SET Y=LRODT
DO DD^LRX
WRITE Y
+2 WRITE @IOF," Test",?20,"Urgency",?30,"Status",?64,"Accession"
+3 QUIT
WAIT WRITE !," PRESS '^' TO STOP "
READ X:DTIME
if X=""
SET X=1
SET LREND=".^"[X
+1 QUIT
CANC ;For Canceled tests
+1 NEW LRTSTS
+2 SET LRTSTS=+LRACN0
SET LROT="Canceled by: "_$PIECE(^VA(200,$PIECE(LRACN0,"^",11),0),"^")
+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 QUIT
OERR(X,ALPHA,OMEGA) ;Get order status for predefined patient
+1 ;X=DFN;DPT( <--ORVP FORMAT
+2 ;ALPHA=start date
+3 ;OMEGA=end date
+4 IF '$GET(X)
WRITE !!?5,"NO PATIENT SELECTED",!
HANG 2
QUIT
+5 if '$GET(ALPHA)
QUIT
if '$GET(OMEGA)
QUIT
+6 NEW DFN,LRDFN,LRDPF,LRDT0,VA200
+7 SET DFN=+X
SET LRDPF=+$PIECE(@("^"_$PIECE(X,";",2)_"0)"),"^",2)_"^"_$PIECE(X,";",2)
SET LRDFN=$$LRDFN^LR7OR1(DFN)
+8 if 'LRDFN
QUIT
+9 WRITE !,"Lab test status for: "_$PIECE(^DPT(DFN,0),"^")
+10 DO EN(ALPHA,OMEGA)
+11 QUIT
