LRCENDE1 ;SLC/CJS-ORDER DELETE ;8/11/97 [ 04/14/2003 7:35 AM ]
;;5.2T9;LR;**1002,1003,1006,1008,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**100,107,121,201,202,221**;Sep 27, 1994
DO I $D(^LRO(69,LRODT,1,LRSN,3))&'$D(^XUSEC("LRLAB",DUZ)) W !,"You're not cleared to delete this order." Q
Q:'$D(^LRO(69,LRODT,1,LRSN,0))
N LRMSTATI
I '$L($G(LRNATURE)) D DC^LROR6() I $G(LRNATURE)=-1 W !!,$C(7),"NOTHING CHANGED" Q
S LRACC=0 S TT=0
F S TT=$O(^LRO(69,LRODT,1,LRSN,2,TT)) Q:TT<1 K TST S X=^(TT,0) I '$P(X,"^",11) S TST(+X)="",LRAD=+$P(X,U,3),LRAA=+$P(X,U,4),LRAN=+$P(X,U,5),ORIFN=$P(X,U,7) D CEN1 I 'LRNOP D
. W !,"For test: " S X=^LRO(69,LRODT,1,LRSN,2,TT,0) W !,?5,$P(^LAB(60,+X,0),"^")
. S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=TT,DA(1)=LRSN,DA(2)=LRODT,DR="99.1///"_$S($L($P($G(LRNATURE),U,5)):$P(LRNATURE,U,5)_": ",1:"")_":99.1" D ^DIE
. D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.TST,$G(LRMSTATI))
. S:$D(^LRO(69,LRODT,1,LRSN,2,TT,0))#2 $P(^(0),"^",9,11)="CA^L^"_DUZ
Q:LRACC&'$D(^XUSEC("LRLAB",DUZ))!LRNOP
S LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRLLOC=$P(^(0),U,7)
I $P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC" S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2) S:ION="" ION=$P(^LAB(69.9,1,3),U,4) I ION]"" D ^LROW2P
Q
CEN1 ;from LRCENDEL
D DC
N X Q:'$D(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,0)) S LRACC=1 I '$D(^XUSEC("LRLAB",DUZ)) W !,"Already accessioned.",$C(7) Q
OR ;OE/RR 2.5
S LRSS=$P(^LRO(68,LRAA,0),"^",2)
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S LRIDT=$P(+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5) I 'LRIDT G SKPLR
I '$D(^LR(LRDFN,LRSS,LRIDT,0))#2 G SKPLR
I $P(^LR(LRDFN,LRSS,LRIDT,0),U,3) W !?5,"This accession has already been verified",! S LRNOP=1 Q
L +^LR(LRDFN,LRSS,LRIDT):1 I '$T W !!,"This accession is being used by someone else." S LRNOP=1 L -^LR(LRDFN,LRSS,LRIDT) Q
SKPLR ;from LRTSTJAM,LRTSTOUT
S LRNOW=$$NOW^XLFDT
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LROSN=$P(X,U,5),LROID=$P(X,U,6),LROCN=$S($D(^(.1)):$P(^(.1),U),1:"")
S LRCWDT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRAD),LROWDT=$P(^(0),U,3),LROWDT=$S($D(^LRO(68,LRAA,1,LROWDT,1,LRAN,0)):LROWDT,1:LRAD)
D ZAP:'$D(LRONE),ZAP1:$D(LRONE),ZAP:$O(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,0))'>0&$D(LRONE),ZAP2:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))&$D(LRONE)
I LRCWDT'=LROWDT S LRCWDT=LROWDT D ZAP:'$D(LRONE),ZAP1:$D(LRONE)
K LRF,LRCWDT,LROWDT,LROSN,LROID,LROCN W "."
L -^LR(LRDFN,LRSS,LRIDT)
I $D(^LRO(69,+LRODT,1,+LRSN,0)),$P(^(0),U,4)="LC" S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2) S:ION="" ION=$P(^LAB(69.9,1,3),U,4) I ION]"" D ^LROW2P
Q
ZAP S LRF=0,I=0 F S I=$O(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),U,5) D ZAP3(LRAA,LRCWDT,LRAN,I)
Q
ZAP1 D:$D(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,LRTSN,0))#2 ZAP3(LRAA,LRCWDT,LRAN,LRTSN)
Q
ZAP2 Q ;K ^LR(LRDFN,LRSS,LRIDT) I $O(^LRO(69,LRODT,1,LRSN,2,0))'>0 K ^LRO(69,"C",+LRORD,LRODT,LRSN),^LRO(69,LRODT,1,LRSN,2)
Q
DC ;DC orders in OE/RR 2.5
I $$VER^LR7OU1>2.5 Q
S LRSAVI=ORIFN
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORED LINE BELOW CALL TO ORX
I $P($G(^ORD(100.99,1,2)),"^",2) S ORNATR=$S($D(LRNATURE):LRNATURE,1:"") D:'$D(LRNATURE) OT^LROR6 S LRNATURE=ORNATR I ORNATR="V"!(ORNATR="P") S ORNAT=ORNATR D DC^ORX7
S:$G(LRNATURE)="C" OREASON="S" S ORIFN=LRSAVI,ORSTS=1 D ST^ORX
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORED LINE ABOVE. COMMENTED OUT EALIRER MODS TO CALL BLRORX
;I $P($G(^ORD(100.99,1,2)),"^",2) S ORNATR=$S($D(LRNATURE):LRNATURE,1:"") D:'$D(LRNATURE) OT^LROR6 S LRNATURE=ORNATR I ORNATR="V"!(ORNATR="P") S ORNAT=ORNATR ;IHS/DIR TUC/AAB 06/15/98
;S:$G(LRNATURE)="C" OREASON="S" S ORIFN=LRSAVI,ORSTS=1 ;IHS/DIR TUC/AAB 06/15/98
;----- END IHS MODIFICATIONS
K LRSAVI,ORSTS,ORIFN,OREASON,ORNATR Q
ZAP3(LRAA,LRCWDT,LRAN,LRTS) ;
S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
I $D(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,LRTS,0))#2,'$P(^(0),U,4) S $P(^(0),U,4,6)=DUZ_U_LRNOW_U_$S('$D(LRLABKY):"*Cancel by Floor",1:"*Not Performed")
Q
LRCENDE1 ;SLC/CJS-ORDER DELETE ;8/11/97 [ 04/14/2003 7:35 AM ]
+1 ;;5.2T9;LR;**1002,1003,1006,1008,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**100,107,121,201,202,221**;Sep 27, 1994
DO IF $DATA(^LRO(69,LRODT,1,LRSN,3))&'$DATA(^XUSEC("LRLAB",DUZ))
WRITE !,"You're not cleared to delete this order."
QUIT
+1 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+2 NEW LRMSTATI
+3 IF '$LENGTH($GET(LRNATURE))
DO DC^LROR6()
IF $GET(LRNATURE)=-1
WRITE !!,$CHAR(7),"NOTHING CHANGED"
QUIT
+4 SET LRACC=0
SET TT=0
+5 FOR
SET TT=$ORDER(^LRO(69,LRODT,1,LRSN,2,TT))
IF TT<1
QUIT
KILL TST
SET X=^(TT,0)
IF '$PIECE(X,"^",11)
SET TST(+X)=""
SET LRAD=+$PIECE(X,U,3)
SET LRAA=+$PIECE(X,U,4)
SET LRAN=+$PIECE(X,U,5)
SET ORIFN=$PIECE(X,U,7)
DO CEN1
IF 'LRNOP
Begin DoDot:1
+6 WRITE !,"For test: "
SET X=^LRO(69,LRODT,1,LRSN,2,TT,0)
WRITE !,?5,$PIECE(^LAB(60,+X,0),"^")
+7 SET DIE="^LRO(69,LRODT,1,LRSN,2,"
SET DA=TT
SET DA(1)=LRSN
SET DA(2)=LRODT
SET DR="99.1///"_$SELECT($LENGTH($PIECE($GET(LRNATURE),U,5)):$PIECE(LRNATURE,U,5)_": ",1:"")_":99.1"
DO ^DIE
+8 DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.TST,$GET(LRMSTATI))
+9 IF $DATA(^LRO(69,LRODT,1,LRSN,2,TT,0))#2
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
End DoDot:1
+10 IF LRACC&'$DATA(^XUSEC("LRLAB",DUZ))!LRNOP
QUIT
+11 SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
SET LRLLOC=$PIECE(^(0),U,7)
+12 IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)="LC"
SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
IF ION=""
SET ION=$PIECE(^LAB(69.9,1,3),U,4)
IF ION]""
DO ^LROW2P
+13 QUIT
CEN1 ;from LRCENDEL
+1 DO DC
+2 NEW X
IF '$DATA(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,0))
QUIT
SET LRACC=1
IF '$DATA(^XUSEC("LRLAB",DUZ))
WRITE !,"Already accessioned.",$CHAR(7)
QUIT
OR ;OE/RR 2.5
+1 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
+2 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+3 SET LRIDT=$PIECE(+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
IF 'LRIDT
GOTO SKPLR
+4 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))#2
GOTO SKPLR
+5 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)
WRITE !?5,"This accession has already been verified",!
SET LRNOP=1
QUIT
+6 LOCK +^LR(LRDFN,LRSS,LRIDT):1
IF '$TEST
WRITE !!,"This accession is being used by someone else."
SET LRNOP=1
LOCK -^LR(LRDFN,LRSS,LRIDT)
QUIT
SKPLR ;from LRTSTJAM,LRTSTOUT
+1 SET LRNOW=$$NOW^XLFDT
+2 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LROSN=$PIECE(X,U,5)
SET LROID=$PIECE(X,U,6)
SET LROCN=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
+3 SET LRCWDT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRAD)
SET LROWDT=$PIECE(^(0),U,3)
SET LROWDT=$SELECT($DATA(^LRO(68,LRAA,1,LROWDT,1,LRAN,0)):LROWDT,1:LRAD)
+4 IF '$DATA(LRONE)
DO ZAP
IF $DATA(LRONE)
DO ZAP1
IF $ORDER(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,0))'>0&$DATA(LRONE)
DO ZAP
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))&$DATA(LRONE)
DO ZAP2
+5 IF LRCWDT'=LROWDT
SET LRCWDT=LROWDT
IF '$DATA(LRONE)
DO ZAP
IF $DATA(LRONE)
DO ZAP1
+6 KILL LRF,LRCWDT,LROWDT,LROSN,LROID,LROCN
WRITE "."
+7 LOCK -^LR(LRDFN,LRSS,LRIDT)
+8 IF $DATA(^LRO(69,+LRODT,1,+LRSN,0))
IF $PIECE(^(0),U,4)="LC"
SET ION=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
IF ION=""
SET ION=$PIECE(^LAB(69.9,1,3),U,4)
IF ION]""
DO ^LROW2P
+9 QUIT
ZAP SET LRF=0
SET I=0
FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,I))
IF I<1
QUIT
IF $DATA(^(I,0))
IF '$PIECE(^(0),U,5)
DO ZAP3(LRAA,LRCWDT,LRAN,I)
+1 QUIT
ZAP1 IF $DATA(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,LRTSN,0))#2
DO ZAP3(LRAA,LRCWDT,LRAN,LRTSN)
+1 QUIT
ZAP2 ;K ^LR(LRDFN,LRSS,LRIDT) I $O(^LRO(69,LRODT,1,LRSN,2,0))'>0 K ^LRO(69,"C",+LRORD,LRODT,LRSN),^LRO(69,LRODT,1,LRSN,2)
QUIT
+1 QUIT
DC ;DC orders in OE/RR 2.5
+1 IF $$VER^LR7OU1>2.5
QUIT
+2 SET LRSAVI=ORIFN
+3 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+4 ;RESTORED LINE BELOW CALL TO ORX
+5 IF $PIECE($GET(^ORD(100.99,1,2)),"^",2)
SET ORNATR=$SELECT($DATA(LRNATURE):LRNATURE,1:"")
IF '$DATA(LRNATURE)
DO OT^LROR6
SET LRNATURE=ORNATR
IF ORNATR="V"!(ORNATR="P")
SET ORNAT=ORNATR
DO DC^ORX7
+6 IF $GET(LRNATURE)="C"
SET OREASON="S"
SET ORIFN=LRSAVI
SET ORSTS=1
DO ST^ORX
+7 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+8 ;RESTORED LINE ABOVE. COMMENTED OUT EALIRER MODS TO CALL BLRORX
+9 ;I $P($G(^ORD(100.99,1,2)),"^",2) S ORNATR=$S($D(LRNATURE):LRNATURE,1:"") D:'$D(LRNATURE) OT^LROR6 S LRNATURE=ORNATR I ORNATR="V"!(ORNATR="P") S ORNAT=ORNATR ;IHS/DIR TUC/AAB 06/15/98
+10 ;S:$G(LRNATURE)="C" OREASON="S" S ORIFN=LRSAVI,ORSTS=1 ;IHS/DIR TUC/AAB 06/15/98
+11 ;----- END IHS MODIFICATIONS
+12 KILL LRSAVI,ORSTS,ORIFN,OREASON,ORNATR
QUIT
ZAP3(LRAA,LRCWDT,LRAN,LRTS) ;
+1 IF '$GET(LRNOW)
SET LRNOW=$$NOW^XLFDT
+2 IF $DATA(^LRO(68,LRAA,1,LRCWDT,1,LRAN,4,LRTS,0))#2
IF '$PIECE(^(0),U,4)
SET $PIECE(^(0),U,4,6)=DUZ_U_LRNOW_U_$SELECT('$DATA(LRLABKY):"*Cancel by Floor",1:"*Not Performed")
+3 QUIT
