- 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
