source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LROR8.m@ 1116

Last change on this file since 1116 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
RevLine 
[613]1LROR8 ;SLC/DCM - FLAG/HOLD ORDERS ;5/1/89 17:46 ;
2 ;;5.2;LAB SERVICE;**100,128**;Sep 27, 1994
3EN ;;from LROR to FLAG orders
4 I ORSTS'=5,ORSTS'=4 W !,"Only PENDING lab orders can be flagged." Q
5 S ORSTS=$S(ORSTS=4:5,ORSTS=5:4,ORSTS="":4,1:"") D:ORSTS'="" ST^ORX
6 Q
7EN1 ;;from LROR to HOLD orders
8 I ORGY=0 W !!,"Lab orders cannot be put on HOLD. Do you want to CANCEL the order",$C(7) S %=2 D YN^DICN Q:%'=1
9 D C^LROR3 Q
10 Q
11EN2 ;Verify unreleased lab orders
12 Q ;Disable verify - now done when released
13EN3 ;Verify upon release
14 I ORSTS'=11,ORSTS'="" Q
15 N LRSTS
16 S LRSTS=ORSTS,LRSX=0,LRASK=0,LRORIFN=ORIFN,LREND=0,X=ORPK,LRTST=+X,LROST=$P(X,"^",2),LRSAMP=$P(X,"^",3),LRSPEC=$P(X,"^",4),LRZX(1)=$P(X,"^",5),LRURG=$P(X,"^",6),LRORD=$P(X,"^",7),LRI=1,LRTEST(LRI)=LRTST
17 I 'LRORD D GET
18 I 'LRTST!('LROST)!('LRSAMP)!('LRSPEC)!('$L(LRZX(1)))!('LRURG)!('$L(LRORD)) W !,"Incomplete data! This order cannot be released." D READ^ORUTL S OREND=1 D END Q
19 S LRTSTNM=$S($D(^LAB(60,LRTST,0)):$P(^(0),"^"),1:"")
20 D NOW^%DTC S LRNOW=%
21 N GOT,LRNSN,LRODT S GOT=0,LRODT=$P(LROST,".")
22 I $D(^LRO(69,"C",LRORD,LRODT)) S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D Q:GOT
23 . I $D(^LRO(69,LRODT,1,LRSN,0)),$P(^(0),"^",3)=LRSAMP,$D(^(4,1,0)),+^(0)=LRSPEC,$P($G(^LRO(69,LRODT,1,LRSN,3)),"^") S GOT=1
24 I GOT W $C(7),!!,"The specimen for test "_LRTSTNM_", has already been processed by Lab.",!,"Please create a new order, or contact lab to have this test added." S ORSTS="K" D ST^ORX W !?5,LRTSTNM_" Deleted" S OREND=1 D END,READ^ORUTL Q
25 I LROST["."&(LRNOW>(LROST+.0002)) D COL I LREND S OREND=1 D END Q
26 I LROST'[".",$P(LRNOW,".",1)>LROST D COL I LREND S OREND=1 D END Q
27 D DUP I LREND D END Q
28S1 S LRSX=LRSX+1 I $D(^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)) G S1
29 S:'$G(^XUTL("OR",$J,"LROT",LROST,LRZX(1))) ^(LRZX(1))=LRORD
30 S ^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX,1)=LRURG,^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX,0)=LRORIFN,^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)=LRTST
31 I $D(ORCARY),'$D(^XUTL("OR",$J,"COM")) M ^XUTL("OR",$J,"COM")=ORCARY
32 I '$D(ORCARY),$D(^XUTL("OR",$J,"COM")) M ORCARY=^XUTL("OR",$J,"COM")
33 Q:LRSTS="" S LREXP="",LRZX(6)=LROST\1 D MAX^LRXO1 I LREND S ORSTS="K" D ST^ORX W " Deleted" K ^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX) Q
34 I $D(^LAB(60,LRTST,3,+$O(^LAB(60,LRTST,3,"B",+LRSAMP,0)),0)) S LREXP=$P(^(0),"^",6) I LREXP D RCOM^LRXO9
35 I 'LREXP S LREXP=$P(^LAB(60,LRTST,0),"^",19) I LREXP D RCOM^LRXO9
36 ;I $D(^LAB(60,LRTST,6,0)),$O(^(0))'<1 W !,"GENERAL WARD INSTRUCTIONS:" S N1=0 F S N1=$O(^LAB(60,LRTST,6,N1)) Q:N1<1 W !," "_^(N1,0)
37 N LRCSX S LRCSX=0,CNT=2,I=0,LRLWC=LRZX(1)
38 F S LRCSX=$O(^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX)) Q:LRCSX<1 S I=0 D
39 . F S I=$O(^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX,I)) Q:I<1 I ^(I)'["~For",$O(^(I,0))=LRTST S ORETURN("ORTX",CNT)=^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX,I),CNT=CNT+1
40 D SET2^LROR(+LRTEST(LRI),LRSAMP,LRSPEC,LRURG,LRLWC,LRORD) S ORETURN("ORTX",1)=ORTX(1) K LRLWC
41 I $D(ORETURN) S ORIFN=LRORIFN D RETURN^ORX
42 ;K ^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)
43 Q
44COL S Y=LROST D DD^%DT W !!,"The collection time of "_Y_" has expired",!,"Please enter a new collection time"
45 D INIT^LRXO00 I LRZX(1)["I" D Q
46 . D EN^LRORDIM I $G(LREND) W !,"No Collection Time Entered",!! Q
47 . S ORETURN("ORSTRT")=LROST D RETURN^ORX Q
48 N LRNOW D EN^LRXO5 I $G(LREND) W !,"A new collection time must be entered to release this order",!,"Order not released!" Q
49 S ORETURN("ORSTRT")=LROST D RETURN^ORX
50 Q
51END K LRORIFN,LREND,LRTST,LROST,LRSAMP,LRSPEC,LRZX(1),LRURG,LRORD,LROT,LRZX(6),X,LRI,LRTEST
52 Q
53DUP ;Check for duplicate in ^XUTL
54 N SX
55 S SX=0 F S SX=$O(^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,SX)) Q:SX<1 I LRTST=+(^(SX)) S LREND=1 D:LRORIFN'=+$G(^(SX,0)) Q
56 . W !!!,"Duplicate test "_LRTSTNM_", for the same collection time will be deleted",!! D READ^ORUTL
57 . S ORIFN=LRORIFN,ORSTS="K" D ST^ORX
58 Q
59GET ;Get Ord #
60 S LRORD=$G(^XUTL("OR",$J,"LROT",LROST,LRZX(1)))
61 I 'LRORD S ZTQUEUED=1 D ORDER^LROW2 K ZTQUEUED
62 Q
Note: See TracBrowser for help on using the repository browser.