LROR8.m

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