LROR8 ; IHS/DIR/AAB - FLAG/HOLD ORDERS 5/1/89 17:46 ; [ 07/22/2002 1:31 PM ]
;;5.2T9;LR;**1002,1013,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**100,128**;Sep 27, 1994
EN ;;from LROR to FLAG orders
I ORSTS'=5,ORSTS'=4 W !,"Only PENDING lab orders can be flagged." Q
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESOTRE CALL TO ORX
S ORSTS=$S(ORSTS=4:5,ORSTS=5:4,ORSTS="":4,1:"") D:ORSTS'="" ST^ORX
;S ORSTS=$S(ORSTS=4:5,ORSTS=5:4,ORSTS="":4,1:"") ;IHS/DIR TUC/AAB 06/15/98
;END IHS MODIFICATIONS
Q
EN1 ;;from LROR to HOLD orders
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
D C^LROR3 Q
Q
EN2 ;Verify unreleased lab orders
Q ;Disable verify - now done when released
EN3 ;Verify upon release
I ORSTS'=11,ORSTS'="" Q
N LRSTS
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
I 'LRORD D GET
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALL TO ORUTL
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
;I 'LRTST!('LROST)!('LRSAMP)!('LRSPEC)!('$L(LRZX(1)))!('LRURG)!('$L(LRORD)) W !,"Incomplete data! This order cannot be released." S OREND=1 D END Q ;IHS/DIR TUC/AAB 06/15/98
S LRTSTNM=$S($D(^LAB(60,LRTST,0)):$P(^(0),"^"),1:"")
D NOW^%DTC S LRNOW=%
N GOT,LRNSN,LRODT S GOT=0,LRODT=$P(LROST,".")
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
. 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
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALL TO ORX
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
;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."
;I GOT S ORSTS="K" W !?5,LRTSTNM_" Deleted" S OREND=1 D END,READ^ORUTL Q ;IHS/DIR TUC/AAB 06/15/98
;END IHS MODIFICATIONS
I LROST["."&(LRNOW>(LROST+.0002)) D COL I LREND S OREND=1 D END Q
I LROST'[".",$P(LRNOW,".",1)>LROST D COL I LREND S OREND=1 D END Q
D DUP I LREND D END Q
S1 S LRSX=LRSX+1 I $D(^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)) G S1
S:'$G(^XUTL("OR",$J,"LROT",LROST,LRZX(1))) ^(LRZX(1))=LRORD
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
I $D(ORCARY),'$D(^XUTL("OR",$J,"COM")) M ^XUTL("OR",$J,"COM")=ORCARY
I '$D(ORCARY),$D(^XUTL("OR",$J,"COM")) M ORCARY=^XUTL("OR",$J,"COM")
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALL TO ORX
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
;Q:LRSTS="" S LREXP="",LRZX(6)=LROST\1 D MAX^LRXO1 I LREND S ORSTS="K" W " Deleted" K ^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX) Q ;IHS/DIR TUC/AAB 06/15/98
;END IHS MODIFICATIONS
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
I 'LREXP S LREXP=$P(^LAB(60,LRTST,0),"^",19) I LREXP D RCOM^LRXO9
;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)
N LRCSX S LRCSX=0,CNT=2,I=0,LRLWC=LRZX(1)
F S LRCSX=$O(^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX)) Q:LRCSX<1 S I=0 D
. 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
D SET2^LROR(+LRTEST(LRI),LRSAMP,LRSPEC,LRURG,LRLWC,LRORD) S ORETURN("ORTX",1)=ORTX(1) K LRLWC
;BEGIN IHS MODIFCATIONS LR*5.2*1018
;RESTORE CALL TO ORX
I $D(ORETURN) S ORIFN=LRORIFN D RETURN^ORX
;I $D(ORETURN) S ORIFN=LRORIFN ;IHS/DIR TUC/AAB 06/15/98
K ^XUTL("OR",$J,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)
Q
COL S Y=LROST D DD^%DT W !!,"The collection time of "_Y_" has expired",!,"Please enter a new collection time"
D INIT^LRXO00 I LRZX(1)["I" D Q
. D EN^LRORDIM I $G(LREND) W !,"No Collection Time Entered",!! Q
. S ORETURN("ORSTRT")=LROST D RETURN^ORX Q
. ;S ORETURN("ORSTRT")=LROST Q ;IHS/DIR TUC/AAB 06/15/98
N LRNOW D EN^LRXO5 I $G(LREND) W !,"A new collection time must be entered to release this order",!,"Order not released!" Q
S ORETURN("ORSTRT")=LROST D RETURN^ORX
;S ORETURN("ORSTRT")=LROST ;IHS/DIR TUC/AAB 06/15/98
Q
END K LRORIFN,LREND,LRTST,LROST,LRSAMP,LRSPEC,LRZX(1),LRURG,LRORD,LROT,LRZX(6),X,LRI,LRTEST
Q
DUP ;Check for duplicate in ^XUTL
N SX
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
. W !!!,"Duplicate test "_LRTSTNM_", for the same collection time will be deleted",!! D READ^ORUTL
. S ORIFN=LRORIFN,ORSTS="K" D ST^ORX
. ;S ORIFN=LRORIFN,ORSTS="K" ;IHS/DIR TUC/AAB 06/15/98
;END IHS MODIFICATIONS
Q
GET ;Get Ord #
S LRORD=$G(^XUTL("OR",$J,"LROT",LROST,LRZX(1)))
I 'LRORD S ZTQUEUED=1 D ORDER^LROW2 K ZTQUEUED
Q
LROR8 ; IHS/DIR/AAB - FLAG/HOLD ORDERS 5/1/89 17:46 ; [ 07/22/2002 1:31 PM ]
+1 ;;5.2T9;LR;**1002,1013,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**100,128**;Sep 27, 1994
EN ;;from LROR to FLAG orders
+1 IF ORSTS'=5
IF ORSTS'=4
WRITE !,"Only PENDING lab orders can be flagged."
QUIT
+2 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;RESOTRE CALL TO ORX
+4 SET ORSTS=$SELECT(ORSTS=4:5,ORSTS=5:4,ORSTS="":4,1:"")
IF ORSTS'=""
DO ST^ORX
+5 ;S ORSTS=$S(ORSTS=4:5,ORSTS=5:4,ORSTS="":4,1:"") ;IHS/DIR TUC/AAB 06/15/98
+6 ;END IHS MODIFICATIONS
+7 QUIT
EN1 ;;from LROR to HOLD orders
+1 IF ORGY=0
WRITE !!,"Lab orders cannot be put on HOLD. Do you want to CANCEL the order",$CHAR(7)
SET %=2
DO YN^DICN
IF %'=1
QUIT
+2 DO C^LROR3
QUIT
+3 QUIT
EN2 ;Verify unreleased lab orders
+1 ;Disable verify - now done when released
QUIT
EN3 ;Verify upon release
+1 IF ORSTS'=11
IF ORSTS'=""
QUIT
+2 NEW LRSTS
+3 SET LRSTS=ORSTS
SET LRSX=0
SET LRASK=0
SET LRORIFN=ORIFN
SET LREND=0
SET X=ORPK
SET LRTST=+X
SET LROST=$PIECE(X,"^",2)
SET LRSAMP=$PIECE(X,"^",3)
SET LRSPEC=$PIECE(X,"^",4)
SET LRZX(1)=$PIECE(X,"^",5)
SET LRURG=$PIECE(X,"^",6)
SET LRORD=$PIECE(X,"^",7)
SET LRI=1
SET LRTEST(LRI)=LRTST
+4 IF 'LRORD
DO GET
+5 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+6 ;RESTORE CALL TO ORUTL
+7 IF 'LRTST!('LROST)!('LRSAMP)!('LRSPEC)!('$LENGTH(LRZX(1)))!('LRURG)!('$LENGTH(LRORD))
WRITE !,"Incomplete data! This order cannot be released."
DO READ^ORUTL
SET OREND=1
DO END
QUIT
+8 ;I 'LRTST!('LROST)!('LRSAMP)!('LRSPEC)!('$L(LRZX(1)))!('LRURG)!('$L(LRORD)) W !,"Incomplete data! This order cannot be released." S OREND=1 D END Q ;IHS/DIR TUC/AAB 06/15/98
+9 SET LRTSTNM=$SELECT($DATA(^LAB(60,LRTST,0)):$PIECE(^(0),"^"),1:"")
+10 DO NOW^%DTC
SET LRNOW=%
+11 NEW GOT,LRNSN,LRODT
SET GOT=0
SET LRODT=$PIECE(LROST,".")
+12 IF $DATA(^LRO(69,"C",LRORD,LRODT))
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
IF LRSN<1
QUIT
Begin DoDot:1
+13 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
IF $PIECE(^(0),"^",3)=LRSAMP
IF $DATA(^(4,1,0))
IF +^(0)=LRSPEC
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,3)),"^")
SET GOT=1
End DoDot:1
IF GOT
QUIT
+14 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+15 ;RESTORE CALL TO ORX
+16 IF GOT
WRITE $CHAR(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."
SET ORSTS="K"
DO ST^ORX
WRITE !?5,LRTSTNM_" Deleted"
SET OREND=1
DO END
DO READ^ORUTL
QUIT
+17 ;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."
+18 ;I GOT S ORSTS="K" W !?5,LRTSTNM_" Deleted" S OREND=1 D END,READ^ORUTL Q ;IHS/DIR TUC/AAB 06/15/98
+19 ;END IHS MODIFICATIONS
+20 IF LROST["."&(LRNOW>(LROST+.0002))
DO COL
IF LREND
SET OREND=1
DO END
QUIT
+21 IF LROST'["."
IF $PIECE(LRNOW,".",1)>LROST
DO COL
IF LREND
SET OREND=1
DO END
QUIT
+22 DO DUP
IF LREND
DO END
QUIT
S1 SET LRSX=LRSX+1
IF $DATA(^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX))
GOTO S1
+1 IF '$GET(^XUTL("OR",$JOB,"LROT",LROST,LRZX(1)))
SET ^(LRZX(1))=LRORD
+2 SET ^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX,1)=LRURG
SET ^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX,0)=LRORIFN
SET ^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)=LRTST
+3 IF $DATA(ORCARY)
IF '$DATA(^XUTL("OR",$JOB,"COM"))
MERGE ^XUTL("OR",$JOB,"COM")=ORCARY
+4 IF '$DATA(ORCARY)
IF $DATA(^XUTL("OR",$JOB,"COM"))
MERGE ORCARY=^XUTL("OR",$JOB,"COM")
+5 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+6 ;RESTORE CALL TO ORX
+7 IF LRSTS=""
QUIT
SET LREXP=""
SET LRZX(6)=LROST\1
DO MAX^LRXO1
IF LREND
SET ORSTS="K"
DO ST^ORX
WRITE " Deleted"
KILL ^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)
QUIT
+8 ;Q:LRSTS="" S LREXP="",LRZX(6)=LROST\1 D MAX^LRXO1 I LREND S ORSTS="K" W " Deleted" K ^XUTL("OR",$J,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX) Q ;IHS/DIR TUC/AAB 06/15/98
+9 ;END IHS MODIFICATIONS
+10 IF $DATA(^LAB(60,LRTST,3,+$ORDER(^LAB(60,LRTST,3,"B",+LRSAMP,0)),0))
SET LREXP=$PIECE(^(0),"^",6)
IF LREXP
DO RCOM^LRXO9
+11 IF 'LREXP
SET LREXP=$PIECE(^LAB(60,LRTST,0),"^",19)
IF LREXP
DO RCOM^LRXO9
+12 ;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)
+13 NEW LRCSX
SET LRCSX=0
SET CNT=2
SET I=0
SET LRLWC=LRZX(1)
+14 FOR
SET LRCSX=$ORDER(^XUTL("OR",$JOB,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX))
IF LRCSX<1
QUIT
SET I=0
Begin DoDot:1
+15 FOR
SET I=$ORDER(^XUTL("OR",$JOB,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX,I))
IF I<1
QUIT
IF ^(I)'["~For"
IF $ORDER(^(I,0))=LRTST
SET ORETURN("ORTX",CNT)=^XUTL("OR",$JOB,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRCSX,I)
SET CNT=CNT+1
End DoDot:1
+16 DO SET2^LROR(+LRTEST(LRI),LRSAMP,LRSPEC,LRURG,LRLWC,LRORD)
SET ORETURN("ORTX",1)=ORTX(1)
KILL LRLWC
+17 ;BEGIN IHS MODIFCATIONS LR*5.2*1018
+18 ;RESTORE CALL TO ORX
+19 IF $DATA(ORETURN)
SET ORIFN=LRORIFN
DO RETURN^ORX
+20 ;I $D(ORETURN) S ORIFN=LRORIFN ;IHS/DIR TUC/AAB 06/15/98
+21 KILL ^XUTL("OR",$JOB,"COM",LROST,LRZX(1),LRSAMP,LRSPEC,LRSX)
+22 QUIT
COL SET Y=LROST
DO DD^%DT
WRITE !!,"The collection time of "_Y_" has expired",!,"Please enter a new collection time"
+1 DO INIT^LRXO00
IF LRZX(1)["I"
Begin DoDot:1
+2 DO EN^LRORDIM
IF $GET(LREND)
WRITE !,"No Collection Time Entered",!!
QUIT
+3 SET ORETURN("ORSTRT")=LROST
DO RETURN^ORX
QUIT
+4 ;S ORETURN("ORSTRT")=LROST Q ;IHS/DIR TUC/AAB 06/15/98
End DoDot:1
QUIT
+5 NEW LRNOW
DO EN^LRXO5
IF $GET(LREND)
WRITE !,"A new collection time must be entered to release this order",!,"Order not released!"
QUIT
+6 SET ORETURN("ORSTRT")=LROST
DO RETURN^ORX
+7 ;S ORETURN("ORSTRT")=LROST ;IHS/DIR TUC/AAB 06/15/98
+8 QUIT
END KILL LRORIFN,LREND,LRTST,LROST,LRSAMP,LRSPEC,LRZX(1),LRURG,LRORD,LROT,LRZX(6),X,LRI,LRTEST
+1 QUIT
DUP ;Check for duplicate in ^XUTL
+1 NEW SX
+2 SET SX=0
FOR
SET SX=$ORDER(^XUTL("OR",$JOB,"LROT",LROST,LRZX(1),LRSAMP,LRSPEC,SX))
IF SX<1
QUIT
IF LRTST=+(^(SX))
SET LREND=1
IF LRORIFN'=+$GET(^(SX,0))
Begin DoDot:1
+3 WRITE !!!,"Duplicate test "_LRTSTNM_", for the same collection time will be deleted",!!
DO READ^ORUTL
+4 SET ORIFN=LRORIFN
SET ORSTS="K"
DO ST^ORX
+5 ;S ORIFN=LRORIFN,ORSTS="K" ;IHS/DIR TUC/AAB 06/15/98
End DoDot:1
QUIT
+6 ;END IHS MODIFICATIONS
+7 QUIT
GET ;Get Ord #
+1 SET LRORD=$GET(^XUTL("OR",$JOB,"LROT",LROST,LRZX(1)))
+2 IF 'LRORD
SET ZTQUEUED=1
DO ORDER^LROW2
KILL ZTQUEUED
+3 QUIT
