LR7OSOS1 ;slc/dcm - Lab order status for OE/RR ;8/11/97
;;5.2;LAB SERVICE;**229**;Sep 27, 1994
EN(OMEGA,ALPHA) ;
N LRODT,LRSN,LREND
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>(GIOSL-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:"")
D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(2,CCNT,"Lab Order # "_$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""))
S X=$P(LROD0,U,6)
D DOC^LRX
S ^(0)=^TMP("ORDATA",$J,1,GCNT,0)_$$S^LR7OS(45,CCNT,"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:"")
D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(2,CCNT,X_" ")
I X'[X4 S ^(0)=^TMP("ORDATA",$J,1,GCNT,0)_$$S^LR7OS(CCNT,CCNT,X4)
S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 D LN S X=^(I,0),^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(5,CCNT,": "_X)
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) D LINE,LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(1,CCNT,"BAD ORDER "_LRSN) D LINE 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
I $L($P(LROD1,U,6)) D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(20,CCNT,$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 D LINE,LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(1,CCNT,"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 ;
D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(2,CCNT,$S($D(^LAB(60,+LRTSTS,0)):$P(^(0),U),1:"BAD TEST POINTER"))
I CCNT>20 D LN S ^TMP("ORDATA",$J,1,GCNT,0)=""
S ^TMP("ORDATA",$J,1,GCNT,0)=^TMP("ORDATA",$J,1,GCNT,0)_$$S^LR7OS(20,CCNT,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")_" ")
I CCNT>28 D LN S ^TMP("ORDATA",$J,1,GCNT,0)=""
S ^(0)=^TMP("ORDATA",$J,1,GCNT,0)_$$S^LR7OS(28,CCNT,LROT_" "_LROS)_$$S^LR7OS(48,CCNT,LROSD)
I X3 S ^TMP("ORDATA",$J,1,GCNT,0)=^TMP("ORDATA",$J,1,GCNT,0)_$$S^LR7OS(62,CCNT," "_$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:""))
I LRROD D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(46,CCNT," 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 D LN S X=^(I,0),^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(3,CCNT,": "_X)
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,LRTSTS=+LRACN0,LRURG=$P(LRACN0,U,2),LROS=$S(LRROD:"Combined",1:LROS)
S:LROS="" LROS="for: "
D WRITE:LRTSTS,COM(1)
I $L($P(LROD1,U,6)) D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(20,CCNT,$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 ;
I $O(^LRO(69,"D",LRDFN,LRODT,0)) D LINE,LN S Y=LRODT D DD^LRX S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(1,CCNT,"Orders for date: "_Y)
D LN S ^TMP("ORDATA",$J,1,GCNT,0)=$$S^LR7OS(1,CCNT," Test")_$$S^LR7OS(20,CCNT,"Urgency")_$$S^LR7OS(30,CCNT,"Status")_$$S^LR7OS(64,CCNT,"Accession")
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
TST ;Test call
D EN1(.Y,"38;DPT(",2981101,$$NOW^XLFDT)
Q
EN1(Y,ORVP,START,END,DTRANGE) ;Broker compatible entry point
S Y=$NA(^TMP("ORDATA",$J,1))
Q:'$G(ORVP)
I $L($G(DTRANGE)),'$G(START) S START=$$FMADD^XLFDT(DT,-DTRANGE),END=$$NOW^XLFDT
S:'$G(START) START=0
S:'$G(END) END=$$NOW^XLFDT
N GIOSL,GIOM,GCNT,CCNT,DFN,LRDFN,LRDPF,LRDT0,VA200
S GIOSL=9999999,GIOM=80,GCNT=0,CCNT=1
K ^TMP("ORDATA",$J)
S DFN=+ORVP,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2),LRDFN=$$LRDFN^LR7OR1(DFN)
I 'LRDFN S Y=$NA(^TMP("ORDATA",$J,1)) Q
D EN(START,END)
S Y=$NA(^TMP("ORDATA",$J,1))
Q
LN ;Increment counts
S GCNT=GCNT+1,CCNT=1
Q
OUT ;Show output
Q:'$D(^TMP("ORDATA",$J))
N I
S I=0
F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I,0)
Q
LINE ;Fill in the global with blank lines
N X
D LN S X="",$P(X," ",GIOM)="",^TMP("ORDATA",$J,1,GCNT,0)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSOS1 5640 printed Sep 23, 2025@19:41:19 Page 2
LR7OSOS1 ;slc/dcm - Lab order status for OE/RR ;8/11/97
+1 ;;5.2;LAB SERVICE;**229**;Sep 27, 1994
EN(OMEGA,ALPHA) ;
+1 NEW LRODT,LRSN,LREND
+2 SET LRODT=$SELECT($GET(ALPHA):ALPHA,1:"")
SET LREND=0
+3 FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT),-1)
if LRODT<1!(LRODT<OMEGA)
QUIT
DO ENTRY
if LREND
QUIT
+4 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>(GIOSL-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
+3 if '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+4 SET LROD0=^LRO(69,LRODT,1,LRSN,0)
SET LROD1=$SELECT($DATA(^(1)):^(1),1:"")
SET LROD3=$SELECT($DATA(^(3)):^(3),1:"")
+5 DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(2,CCNT,"Lab Order # "_$SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""))
+6 SET X=$PIECE(LROD0,U,6)
+7 DO DOC^LRX
+8 SET ^(0)=^TMP("ORDATA",$JOB,1,GCNT,0)_$$S^LR7OS(45,CCNT,"Provider: "_$EXTRACT(LRDOC,1,25))
+9 SET X=$PIECE(LROD0,U,3)
SET X=$SELECT(X:$SELECT($DATA(^LAB(62,+X,0)):$PIECE(^(0),U),1:""),1:"")
SET X4=""
+10 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:"")
+11 DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(2,CCNT,X_" ")
+12 IF X'[X4
SET ^(0)=^TMP("ORDATA",$JOB,1,GCNT,0)_$$S^LR7OS(CCNT,CCNT,X4)
+13 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))
if I<1
QUIT
DO LN
SET X=^(I,0)
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(5,CCNT,": "_X)
+14 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
+15 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")
+6 if X="C"
SET LROT=""
+7 IF '(+LRACN0)
DO LINE
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(1,CCNT,"BAD ORDER "_LRSN)
DO LINE
QUIT
+8 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))
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(20,CCNT,$PIECE(LROD1,U,6))
+4 QUIT
TST2 ;
+1 NEW I,LRURG,LROT,LROS,LRLL,Y,LROSD
+2 SET LRURG=+$PIECE(LRACC,U,2)
+3 IF LRURG>49
QUIT
+4 IF 'LRTSTS
DO LINE
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(1,CCNT,"BAD ACCESSION TEST POINTER: "_LRTSTS)
QUIT
+5 SET LROT=""
SET LROS=LROOS
SET LRLL=$PIECE(LRACC,U,3)
SET Y=$PIECE(LRACC,U,5)
+6 IF Y
SET LROS="Test Complete"
DO DATE
SET LROSD=Y
DO WRITE
DO COM(1)
QUIT
+7 SET Y=$PIECE(LROD3,U)
+8 DO DATE
+9 SET LROSD=Y
+10 IF LRLL
SET LROS="Testing In Progress"
+11 IF $PIECE(LROD1,"^",4)="U"
SET (LROS,LROOS)=""
+12 DO WRITE
DO COM(1)
+13 QUIT
WRITE ;
+1 DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(2,CCNT,$SELECT($DATA(^LAB(60,+LRTSTS,0)):$PIECE(^(0),U),1:"BAD TEST POINTER"))
+2 IF CCNT>20
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=""
+3 SET ^TMP("ORDATA",$JOB,1,GCNT,0)=^TMP("ORDATA",$JOB,1,GCNT,0)_$$S^LR7OS(20,CCNT,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")_" ")
+4 IF CCNT>28
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=""
+5 SET ^(0)=^TMP("ORDATA",$JOB,1,GCNT,0)_$$S^LR7OS(28,CCNT,LROT_" "_LROS)_$$S^LR7OS(48,CCNT,LROSD)
+6 IF X3
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=^TMP("ORDATA",$JOB,1,GCNT,0)_$$S^LR7OS(62,CCNT," "_$SELECT($DATA(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:""))
+7 IF LRROD
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(46,CCNT," See order: "_LRROD)
+8 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
DO LN
SET X=^(I,0)
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(3,CCNT,": "_X)
+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 ;
+1 if 'Y
SET Y=$PIECE(LROD0,U,8)
+2 SET Y=$SELECT(Y:Y,+LROD3:+LROD3,+LROD1:+LROD1,1:LRODT)
+3 DO DATE
+4 SET LROSD=Y
SET LRTSTS=+LRACN0
SET LRURG=$PIECE(LRACN0,U,2)
SET LROS=$SELECT(LRROD:"Combined",1:LROS)
+5 if LROS=""
SET LROS="for: "
+6 if LRTSTS
DO WRITE
DO COM(1)
+7 IF $LENGTH($PIECE(LROD1,U,6))
DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(20,CCNT,$PIECE(LROD1,U,6))
+8 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 ;
+1 IF $ORDER(^LRO(69,"D",LRDFN,LRODT,0))
DO LINE
DO LN
SET Y=LRODT
DO DD^LRX
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(1,CCNT,"Orders for date: "_Y)
+2 DO LN
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=$$S^LR7OS(1,CCNT," Test")_$$S^LR7OS(20,CCNT,"Urgency")_$$S^LR7OS(30,CCNT,"Status")_$$S^LR7OS(64,CCNT,"Accession")
+3 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
TST ;Test call
+1 DO EN1(.Y,"38;DPT(",2981101,$$NOW^XLFDT)
+2 QUIT
EN1(Y,ORVP,START,END,DTRANGE) ;Broker compatible entry point
+1 SET Y=$NAME(^TMP("ORDATA",$JOB,1))
+2 if '$GET(ORVP)
QUIT
+3 IF $LENGTH($GET(DTRANGE))
IF '$GET(START)
SET START=$$FMADD^XLFDT(DT,-DTRANGE)
SET END=$$NOW^XLFDT
+4 if '$GET(START)
SET START=0
+5 if '$GET(END)
SET END=$$NOW^XLFDT
+6 NEW GIOSL,GIOM,GCNT,CCNT,DFN,LRDFN,LRDPF,LRDT0,VA200
+7 SET GIOSL=9999999
SET GIOM=80
SET GCNT=0
SET CCNT=1
+8 KILL ^TMP("ORDATA",$JOB)
+9 SET DFN=+ORVP
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
SET LRDFN=$$LRDFN^LR7OR1(DFN)
+10 IF 'LRDFN
SET Y=$NAME(^TMP("ORDATA",$JOB,1))
QUIT
+11 DO EN(START,END)
+12 SET Y=$NAME(^TMP("ORDATA",$JOB,1))
+13 QUIT
LN ;Increment counts
+1 SET GCNT=GCNT+1
SET CCNT=1
+2 QUIT
OUT ;Show output
+1 if '$DATA(^TMP("ORDATA",$JOB))
QUIT
+2 NEW I
+3 SET I=0
+4 FOR
SET I=$ORDER(^TMP("ORDATA",$JOB,1,I))
if 'I
QUIT
WRITE !,^(I,0)
+5 QUIT
LINE ;Fill in the global with blank lines
+1 NEW X
+2 DO LN
SET X=""
SET $PIECE(X," ",GIOM)=""
SET ^TMP("ORDATA",$JOB,1,GCNT,0)=X
+3 QUIT
