Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRLROS

BLRLROS.m

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