BLRLROS ; IHS/OIT/MKK - LAB ORDER STATUS ; 22-Oct-2013 09:22 ; MKK
;;5.2;LR;**1034**;NOV 01, 1997;Build 88
;
; Cloned from LROS
; Will sort patient's data by Date, then by Order Number
;
EP ; EP
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S LRLOOKUP=1 ; Variable to indicate to lookup patients, prevent adding new entries in ^LRDPA
;
K DIC,LRDPAF,%DT("B") S DIC(0)="A"
D ^LRDPA G:(LRDFN=-1)!$D(DUOUT)!$D(DTOUT) LREND
D L0 G EP
;
L0 ; EP
D ENT S %DT="" D DT^LRX
;
L1 ; EP
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 ; EP
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
;
K ^TMP("BLRLROS",$J)
S LRODT=$$FMADD^XLFDT(LRODT,1)
F S LRODT=$O(^LRO(69,"D",LRDFN,LRODT),-1) Q:LRODT<1 D
. S LRSP=.9999999
. F S LRSP=$O(^LRO(69,"D",LRDFN,LRODT,LRSP)) Q:LRSP<1 D
.. S ORDNUM=+$G(^LRO(69,LRODT,1,LRSP,.1))
.. Q:ORDNUM<1
.. S ^TMP("BLRLROS",$J,LRODT,ORDNUM,LRSP)=""
;
D NEWHEAD
;
S LRODT="A",LREND=""
F S LRODT=$O(^TMP("BLRLROS",$J,LRODT),-1) Q:LRODT<1!($G(LREND)) D
. S ORDNUM=""
. F S ORDNUM=$O(^TMP("BLRLROS",$J,LRODT,ORDNUM),-1) Q:ORDNUM<1!($G(LREND)) D
.. S LRSN=""
.. F S LRSN=$O(^TMP("BLRLROS",$J,LRODT,ORDNUM,LRSN)) Q:LRSN<1!($G(LREND)) D
... D ORDER
... Q:$G(LREND)
... I $Y>(IOSL-6) D HED
;
I $G(LREND) D ^XBCLS Q
;
W !!
K ^TMP("BLRLROS",$J)
Q
;
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 ; EP - call with LRSN, from LROE, LROE1, LRORD1, LROW2, LROR1
NEW ORDERNUM,LRDOC
;
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:"")
;
S ORDERNUM=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5,"I")
S LRDOC=$$GET1^DIQ(69.01,LRSN_","_LRODT,7)
;
D ORDERHED
D WAITBAN 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 HEDBAN Q:$G(LREND)
I $G(^LRO(69,LRODT,1,LRSN,"PCE")) W !,?5,"Visit Number(s): ",$G(^("PCE")) D HEDBAN 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 HEDBAN 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 ; EP
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 HEDBAN Q
G NOTACC:LROD1="" ;,NOTACC:$P(LROD1,"^",4)="U"
;
TST1 ; EP
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 HEDBAN
Q
;
TST2 ; EP
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 Q:LREND D 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 ; EP+
W !?2,$S($D(^LAB(60,+LRTSTS,0)):$P(^(0),U),1:"BAD TEST POINTER")
I $X>19 W ! D WAITBAN Q:(LREND)
W ?20,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," " D WAITBAN Q:$G(LREND)
I $X>28 W ! D WAITBAN Q:$G(LREND)
W ?28,LROT," ",LROS,?43," ",LROSD
W:X3 ?62,$S($D(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")
I LRROD W !?46," See order: " D REVIDEO^BLRUTIL3(" "_LRROD_" ") D WAITBAN Q:$G(LREND)
;
D:$L($G(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999))) CLININDD
;
Q
;
CLININDD ; EP - Display 'Clinical Indication' Data
NEW ORDIEN,CLININD,ICD,ICDCODE,ICDIEN,ICDSTR,SNOMED,TAB,UID
;
S ORDIEN=LRACN_","_LRSN_","_LRODT
S CLININD=$$GET1^DIQ(69.03,ORDIEN,9999999.1)
S SNOMED=$$GET1^DIQ(69.03,ORDIEN,9999999.2)
S UID=$P($G(^LRO(68,+$G(X1),1,+$G(X2),1,+$G(X3),.3)),"^")
S TAB=5
;
W:$L(SNOMED)!($L(UID)) !
;
W:$L(SNOMED) ?9,"SNOMED: ",SNOMED
W:$L(UID) ?57,"UID: ",UID
;
I $L(CLININD) W !,?9,"Clinical Indication: " D LINEWRAP^BLRGMENU($X,CLININD,(IOM-$X))
;
S ICD=0,ICDCNT=0
F S ICD=$O(^LRO(69,LRODT,1,LRSN,2,LRACN,2,ICD)) Q:ICD<1 D
. W !
. S ICDIEN=$$GET1^DIQ(69.05,ICD_","_ORDIEN,.01,"I")
. S ICDSTR=$$ICDDX^ICDEX(ICDIEN)
. W ?9,"ICD:",$P(ICDSTR,"^",2)
. D LINEWRAP^BLRGMENU(24,$P(ICDSTR,"^",4),56)
Q
;
COM(LRMMODE) ; EP
Q:LREND
;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) ; EP
;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 TAB=$G(TAB,3)
N LRI,LINES,STR
S (LINES,LRI)=0
F S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI)) Q:LRI<1!($G(LREND)) D
. S STR=$G(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI,0))
. Q:$L(STR)<1
. ;
. W !,?TAB,": "
. D LINEWRAP^BLRGMENU(TAB+2,STR,(IOM-TAB))
. D WAIT
Q
;
NOTACC ; EP
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 ; EP
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 ; EP
S Y=$$FMTE^XLFDT(Y,"5MZ")
Q
;
HED ; EP
; D:$E(IOST,1)="C"&($Y>18) WAIT
Q:$G(LREND)
Q:$Y<18
;
W !
K DIR,X,Y
S DIR(0)="E"
D ^DIR
I +$G(DIRUT) S LREND=".^"[X Q
;
D NEWHEAD
;
ENT ; EP - 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 ; EP - call with LRSN,LRODT, from LRCENDEL, LRTSTJAN
S LREND=0
D NEWHEAD
D ORDER
Q
;
WAIT ; EP
Q:$Y<(IOSL-6)
I $E(IOST)'="C" W @IOF Q
;
W !
K DIR,X,Y
S DIR(0)="E"
D ^DIR
I +$G(DIRUT) S LREND=".^"[X Q
;
D NEWHEAD
Q
;
CANC ; EP - 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
;
HEDBAN ; EP
Q:$G(LREND)
Q:$Y<18
;
I $E(IOST)'="C" W @IOF Q
;
W !
K DIR,X,Y
S DIR(0)="E"
D ^DIR
I +$G(DIRUT) S LREND=".^"[X Q
;
D NEWHEAD
I +$G(PG)>1 D ORDERHED W !
Q
;
WAITBAN ; EP
Q:$Y<(IOSL-4)
I $E(IOST)'="C" W @IOF Q
;
W !
K DIR,X,Y
S DIR(0)="E"
D ^DIR
I +$G(DIRUT) S LREND=".^"[X Q
;
D NEWHEAD
I +$G(PG)>1 D ORDERHED W !
Q
;
ORDERHED ; EP
I $Y+3>(IOSL-4) D NEWHEAD
; W !,$$COLHEAD^BLRGMENU("Order Date: "_$$FMTE^XLFDT(LRODT,"5DZ"),80)
W !,"Lab Order #: " D:ORDERNUM REVIDEO^BLRUTIL3(" "_ORDERNUM_" ")
W ?45,"Provider: ",$E(LRDOC,1,25)
Q
;
NEWHEAD ; EP
W @IOF
W ?2,"Test",?20,"Urgency",?30,"Status",?62,"Accession"
W !
W $TR($J("",IOM)," ","-")
S PG=1+$G(PG)
Q
BLRLROS ; IHS/OIT/MKK - LAB ORDER STATUS ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LR;**1034**;NOV 01, 1997;Build 88
+2 ;
+3 ; Cloned from LROS
+4 ; Will sort patient's data by Date, then by Order Number
+5 ;
EP ; EP
PEP ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Variable to indicate to lookup patients, prevent adding new entries in ^LRDPA
SET LRLOOKUP=1
+4 ;
+5 KILL DIC,LRDPAF,%DT("B")
SET DIC(0)="A"
+6 DO ^LRDPA
IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO LREND
+7 DO L0
GOTO EP
+8 ;
L0 ; EP
+1 DO ENT
SET %DT=""
DO DT^LRX
+2 ;
L1 ; EP
+1 SET LREND=0
SET %DT="E"
SET %DT("A")="DATE to begin review: "
DO DATE^LRWU
IF Y<1
GOTO LREND
+2 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
+3 ;
L2 ; EP
+1 SET LRSN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,0))
+2 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
+3 ;
+4 KILL ^TMP("BLRLROS",$JOB)
+5 SET LRODT=$$FMADD^XLFDT(LRODT,1)
+6 FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT),-1)
IF LRODT<1
QUIT
Begin DoDot:1
+7 SET LRSP=.9999999
+8 FOR
SET LRSP=$ORDER(^LRO(69,"D",LRDFN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+9 SET ORDNUM=+$GET(^LRO(69,LRODT,1,LRSP,.1))
+10 IF ORDNUM<1
QUIT
+11 SET ^TMP("BLRLROS",$JOB,LRODT,ORDNUM,LRSP)=""
End DoDot:2
End DoDot:1
+12 ;
+13 DO NEWHEAD
+14 ;
+15 SET LRODT="A"
SET LREND=""
+16 FOR
SET LRODT=$ORDER(^TMP("BLRLROS",$JOB,LRODT),-1)
IF LRODT<1!($GET(LREND))
QUIT
Begin DoDot:1
+17 SET ORDNUM=""
+18 FOR
SET ORDNUM=$ORDER(^TMP("BLRLROS",$JOB,LRODT,ORDNUM),-1)
IF ORDNUM<1!($GET(LREND))
QUIT
Begin DoDot:2
+19 SET LRSN=""
+20 FOR
SET LRSN=$ORDER(^TMP("BLRLROS",$JOB,LRODT,ORDNUM,LRSN))
IF LRSN<1!($GET(LREND))
QUIT
Begin DoDot:3
+21 DO ORDER
+22 IF $GET(LREND)
QUIT
+23 IF $Y>(IOSL-6)
DO HED
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 IF $GET(LREND)
DO ^XBCLS
QUIT
+26 ;
+27 WRITE !!
+28 KILL ^TMP("BLRLROS",$JOB)
+29 QUIT
+30 ;
+31 IF $Y>18
DO WAIT
IF LREND
GOTO LREND
IF LRSN<1
GOTO L2
+32 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
+33 DO ENTRY
IF LREND
GOTO LREND
SET X1=LRODT
SET X2=-1
DO C^%DTC
SET LRODT=X
+34 GOTO L2
+35 ;
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
+3 ;
ORDER ; EP - call with LRSN, from LROE, LROE1, LRORD1, LROW2, LROR1
+1 NEW ORDERNUM,LRDOC
+2 ;
+3 KILL D,LRTT
SET LREND=0
+4 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+5 ;
+6 SET LROD0=^LRO(69,LRODT,1,LRSN,0)
SET LROD1=$SELECT($DATA(^(1)):^(1),1:"")
SET LROD3=$SELECT($DATA(^(3)):^(3),1:"")
+7 ;
+8 SET ORDERNUM=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5,"I")
+9 SET LRDOC=$$GET1^DIQ(69.01,LRSN_","_LRODT,7)
+10 ;
+11 DO ORDERHED
+12 DO WAITBAN
IF $GET(LREND)
QUIT
+13 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:"")
+14 IF $EXTRACT($PIECE(LROD1,U,6))="*"
WRITE !?3,$PIECE(LROD1,U,6)
DO HEDBAN
IF $GET(LREND)
QUIT
+15 IF $GET(^LRO(69,LRODT,1,LRSN,"PCE"))
WRITE !,?5,"Visit Number(s): ",$GET(^("PCE"))
DO HEDBAN
IF $GET(LREND)
QUIT
+16 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 HEDBAN
IF $GET(LREND)
QUIT
+17 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
+18 QUIT
+19 ;
TEST ; EP
+1 NEW LRY,LRURG
+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=""
+6 IF '(+LRACN0)
WRITE !!,"BAD ORDER ",LRSN,!,$CHAR(7)
DO HEDBAN
QUIT
+7 ;,NOTACC:$P(LROD1,"^",4)="U"
IF LROD1=""
GOTO NOTACC
+8 ;
TST1 ; EP
+1 SET X1=+$PIECE(LRACN0,U,4)
SET X2=+$PIECE(LRACN0,U,3)
SET X3=+$PIECE(LRACN0,U,5)
+2 IF '$DATA(^LRO(68,X1,1,X2,1,X3,0))
GOTO NOTACC
IF '$DATA(^(3))
GOTO NOTACC
SET LRACD=$SELECT($DATA(^(9)):^(9),1:"")
+3 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
+4 IF $EXTRACT($PIECE(LROD1,U,6))="*"
WRITE !,?20,$PIECE(LROD1,U,6)
DO HEDBAN
+5 QUIT
+6 ;
TST2 ; EP
+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
IF LREND
QUIT
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
+9 ;
WRITE ; EP+
+1 WRITE !?2,$SELECT($DATA(^LAB(60,+LRTSTS,0)):$PIECE(^(0),U),1:"BAD TEST POINTER")
+2 IF $X>19
WRITE !
DO WAITBAN
IF (LREND)
QUIT
+3 WRITE ?20,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
DO WAITBAN
IF $GET(LREND)
QUIT
+4 IF $X>28
WRITE !
DO WAITBAN
IF $GET(LREND)
QUIT
+5 WRITE ?28,LROT," ",LROS,?43," ",LROSD
+6 IF X3
WRITE ?62,$SELECT($DATA(^LRO(68,X1,1,X2,1,X3,.2)):^(.2),1:"")
+7 IF LRROD
WRITE !?46," See order: "
DO REVIDEO^BLRUTIL3(" "_LRROD_" ")
DO WAITBAN
IF $GET(LREND)
QUIT
+8 ;
+9 IF $LENGTH($GET(^LRO(69,LRODT,1,LRSN,2,LRACN,9999999)))
DO CLININDD
+10 ;
+11 QUIT
+12 ;
CLININDD ; EP - Display 'Clinical Indication' Data
+1 NEW ORDIEN,CLININD,ICD,ICDCODE,ICDIEN,ICDSTR,SNOMED,TAB,UID
+2 ;
+3 SET ORDIEN=LRACN_","_LRSN_","_LRODT
+4 SET CLININD=$$GET1^DIQ(69.03,ORDIEN,9999999.1)
+5 SET SNOMED=$$GET1^DIQ(69.03,ORDIEN,9999999.2)
+6 SET UID=$PIECE($GET(^LRO(68,+$GET(X1),1,+$GET(X2),1,+$GET(X3),.3)),"^")
+7 SET TAB=5
+8 ;
+9 IF $LENGTH(SNOMED)!($LENGTH(UID))
WRITE !
+10 ;
+11 IF $LENGTH(SNOMED)
WRITE ?9,"SNOMED: ",SNOMED
+12 IF $LENGTH(UID)
WRITE ?57,"UID: ",UID
+13 ;
+14 IF $LENGTH(CLININD)
WRITE !,?9,"Clinical Indication: "
DO LINEWRAP^BLRGMENU($X,CLININD,(IOM-$X))
+15 ;
+16 SET ICD=0
SET ICDCNT=0
+17 FOR
SET ICD=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRACN,2,ICD))
IF ICD<1
QUIT
Begin DoDot:1
+18 WRITE !
+19 SET ICDIEN=$$GET1^DIQ(69.05,ICD_","_ORDIEN,.01,"I")
+20 SET ICDSTR=$$ICDDX^ICDEX(ICDIEN)
+21 WRITE ?9,"ICD:",$PIECE(ICDSTR,"^",2)
+22 DO LINEWRAP^BLRGMENU(24,$PIECE(ICDSTR,"^",4),56)
End DoDot:1
+23 QUIT
+24 ;
COM(LRMMODE) ; EP
+1 IF LREND
QUIT
+2 ;Write comments
+3 ;LRMMODE=comments node to display
+4 NEW LRTSTI
+5 IF '$GET(LRMMODE)
SET LRMMODE=1
+6 SET LRTSTI=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+LRTSTS,0))
IF 'LRTSTI
QUIT
+7 DO COMWRT(LRODT,LRSN,LRTSTI,LRMMODE,3)
+8 QUIT
+9 ;
COMWRT(LRODT,LRSN,LRTSTI,NODE,TAB) ; EP
+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 SET TAB=$GET(TAB,3)
+5 NEW LRI,LINES,STR
+6 SET (LINES,LRI)=0
+7 FOR
SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI))
IF LRI<1!($GET(LREND))
QUIT
Begin DoDot:1
+8 SET STR=$GET(^LRO(69,LRODT,1,LRSN,2,LRTSTI,NODE,LRI,0))
+9 IF $LENGTH(STR)<1
QUIT
+10 ;
+11 WRITE !,?TAB,": "
+12 DO LINEWRAP^BLRGMENU(TAB+2,STR,(IOM-TAB))
+13 DO WAIT
End DoDot:1
+14 QUIT
+15 ;
NOTACC ; EP
+1 IF $GET(LROD3)=""
SET LROS=""
GOTO NO2
+2 IF $PIECE(LROD3,U,2)'=""
SET LROS=" "
SET Y=$PIECE(LROD3,U,2)
GOTO NO2
+3 SET Y=$PIECE(LROD3,U)
SET LROS=" "
+4 ;
NO2 ; EP
+1 IF 'Y
SET Y=$PIECE(LROD0,U,8)
SET Y=$SELECT(Y:Y,+LROD3:+LROD3,+LROD1:+LROD1,1:LRODT)
DO DATE
SET LROSD=Y
+2 SET LRTSTS=+LRACN0
SET LRURG=$PIECE(LRACN0,U,2)
+3 SET LROS=$SELECT(LRROD:"Combined",1:LROS)
IF LROS=""
SET LROS="for: "
+4 ;second call for backward compatibility - can be removed in future years (1/98)
IF LRTSTS
DO WRITE
DO COM(1.1)
DO COM(1)
+5 IF $LENGTH($PIECE(LROD1,U,6))
WRITE !,?20,$PIECE(LROD1,U,6)
DO WAIT
+6 QUIT
+7 ;
DATE ; EP
+1 SET Y=$$FMTE^XLFDT(Y,"5MZ")
+2 QUIT
+3 ;
HED ; EP
+1 ; D:$E(IOST,1)="C"&($Y>18) WAIT
+2 IF $GET(LREND)
QUIT
+3 IF $Y<18
QUIT
+4 ;
+5 WRITE !
+6 KILL DIR,X,Y
+7 SET DIR(0)="E"
+8 DO ^DIR
+9 IF +$GET(DIRUT)
SET LREND=".^"[X
QUIT
+10 ;
+11 DO NEWHEAD
+12 ;
ENT ; EP - from LROE, LROE1, LRORD1, LROW2
+1 QUIT
+2 ;
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
+3 QUIT
+4 ;
SHOW ; EP - call with LRSN,LRODT, from LRCENDEL, LRTSTJAN
+1 SET LREND=0
+2 DO NEWHEAD
+3 DO ORDER
+4 QUIT
+5 ;
WAIT ; EP
+1 IF $Y<(IOSL-6)
QUIT
+2 IF $EXTRACT(IOST)'="C"
WRITE @IOF
QUIT
+3 ;
+4 WRITE !
+5 KILL DIR,X,Y
+6 SET DIR(0)="E"
+7 DO ^DIR
+8 IF +$GET(DIRUT)
SET LREND=".^"[X
QUIT
+9 ;
+10 DO NEWHEAD
+11 QUIT
+12 ;
CANC ; EP - 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
+4 ;
HEDBAN ; EP
+1 IF $GET(LREND)
QUIT
+2 IF $Y<18
QUIT
+3 ;
+4 IF $EXTRACT(IOST)'="C"
WRITE @IOF
QUIT
+5 ;
+6 WRITE !
+7 KILL DIR,X,Y
+8 SET DIR(0)="E"
+9 DO ^DIR
+10 IF +$GET(DIRUT)
SET LREND=".^"[X
QUIT
+11 ;
+12 DO NEWHEAD
+13 IF +$GET(PG)>1
DO ORDERHED
WRITE !
+14 QUIT
+15 ;
WAITBAN ; EP
+1 IF $Y<(IOSL-4)
QUIT
+2 IF $EXTRACT(IOST)'="C"
WRITE @IOF
QUIT
+3 ;
+4 WRITE !
+5 KILL DIR,X,Y
+6 SET DIR(0)="E"
+7 DO ^DIR
+8 IF +$GET(DIRUT)
SET LREND=".^"[X
QUIT
+9 ;
+10 DO NEWHEAD
+11 IF +$GET(PG)>1
DO ORDERHED
WRITE !
+12 QUIT
+13 ;
ORDERHED ; EP
+1 IF $Y+3>(IOSL-4)
DO NEWHEAD
+2 ; W !,$$COLHEAD^BLRGMENU("Order Date: "_$$FMTE^XLFDT(LRODT,"5DZ"),80)
+3 WRITE !,"Lab Order #: "
IF ORDERNUM
DO REVIDEO^BLRUTIL3(" "_ORDERNUM_" ")
+4 WRITE ?45,"Provider: ",$EXTRACT(LRDOC,1,25)
+5 QUIT
+6 ;
NEWHEAD ; EP
+1 WRITE @IOF
+2 WRITE ?2,"Test",?20,"Urgency",?30,"Status",?62,"Accession"
+3 WRITE !
+4 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","-")
+5 SET PG=1+$GET(PG)
+6 QUIT
