- 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