source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCENDE1.m@ 1789

LRCENDE1 ;SLC/CJS-ORDER DELETE ;8/11/97
 ;;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
 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
 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