LROR3 ; IHS/DIR/AAB - CANCEL,PURGE,SETUP,CLEAN EXECUTES 11/26/90 10:10 ; [ 09/06/2002 7:11 AM ]
;;5.2T9;LR;**1002,1003,1013,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**100,121,165**;Sep 27, 1994
C ;;Cancel execute from OR
;BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALL TO ORX
I ORSTS="",$D(ORPK),$L($P(ORPK,"^",8)) S X=$P(ORPK,"^",2)_","""_$P(ORPK,"^",5)_""","_$P(ORPK,"^",3)_","_$P(ORPK,"^",4)_","_$P(ORPK,"^",8) K:$L(X) @("^XUTL(""OR"",$J,""LROT"","_X_")") S ORSTS="K" D ST^ORX W " Deleted" Q
;BEGIN IHS MODIFICTIONS LR*5.2*1016
;REMOVE MODS TO TAKE OUT CALL MADE TO ORX ABOVE
;I ORSTS="",$D(ORPK),$L($P(ORPK,"^",8)) S X=$P(ORPK,"^",2)_","""_$P(ORPK,"^",5)_""","_$P(ORPK,"^",3)_","_$P(ORPK,"^",4)_","_$P(ORPK,"^",8) ;IHS/DIR TUC/AAB 06/15/98
;I ORSTS="",$D(ORPK),$L($P(ORPK,"^",8)) K:$L(X) @("^XUTL(""OR"",$J,""LROT"","_X_")") S ORSTS="K" W " Deleted" Q ;IHS/DIR TUC/AAB 06/15/98
I +ORSTS=11 S ORSTS="K" D ST^ORX W " Deleted" Q
;I +ORSTS=11 S ORSTS="K" W " Deleted" Q ;IHS/DIR TUC/AAB 06/15/98
I ORGY=0 D C3 Q:LREND
I ORGY'=0 S LRODT=+ORPK,LRSN=$P(ORPK,"^",2),I=$P(ORPK,"^",3)
I 'LRODT!('LRSN)!('I) S ORSTS=1 D:ORGY=9 ST^ORX Q
;I 'LRODT!('LRSN)!('I) S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
I '$D(^LRO(69,LRODT,1,LRSN)),ORGY=10 Q
I '$D(^LRO(69,LRODT,1,LRSN)),ORGY=9 S ORSTS=1 D ST^ORX Q
;I '$D(^LRO(69,LRODT,1,LRSN)),ORGY=9 S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
I '$D(^LRO(69,LRODT,1,LRSN,2,I)),ORGY=10 Q
I '$D(^LRO(69,LRODT,1,LRSN,2,I)),ORGY=9 S ORSTS=1 D ST^ORX Q
;I '$D(^LRO(69,LRODT,1,LRSN,2,I)),ORGY=9 S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
;END IHS MODIFICATIONS TO RESTORE CALLS TO ORX
I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) W !,"Tests already verified for this portion of the order, cannot delete." G END
C1 S LRORD=+^LRO(69,LRODT,1,LRSN,.1),X=^(2,I,0),LRTSN=+X,LRAD=+$P(X,"^",3),LRAA=+$P(X,"^",4),LRAN=+$P(X,"^",5),(LRNOP,LRACC)="",LRONE=""
I LRAD,LRAA,LRAN,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),'$D(^XUSEC("LRLAB",DUZ)) W !!,$C(7),"Already accessioned. Contact lab to cancel.",! G END
;BEGIN IHS MODIFICATIONS LR*5.2*1018
C2 I ORGY=0 D DC^ORX5 S LREND=1 G END
;I ORGY=0 S LREND=1 G END ;IHS/DIR TUC/AAB 06/15/98
I ORGY=9 D C4
END K LRODT,LRSN,LRAD,LRAA,LRAN,LRNOP,LRACC,LRONE,LRC,LRDFN,LRDPF,LRSX,LRTSN,LRUSNM
Q
C3 I 'ORPK D C2 Q
S LRODT=+ORPK,LRSN=$P(ORPK,"^",2),I=$P(ORPK,"^",3) I 'LRODT!('LRSN)!('I) D C2 Q
I '$D(^LRO(69,LRODT,1,LRSN,2,I)) K LRODT,LRSN D C2 Q
S LREND=0 Q
Q
C4 I LRAD,LRAA,LRAN,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D OR^LRCENDE1 I LRNOP G END
I 'LRNOP D C5
S ORSTS=1 D ST^ORX
;
S ORSTS=1 ;IHS/DIR TUC/AAB 06/15/98
Q
C5 ;
S $P(^LRO(69,LRODT,1,LRSN,2,$P(ORPK,"^",3),0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^W^"_DUZ
;K ^LRO(69,LRODT,1,LRSN,2,$P(ORPK,"^",3)),^LRO(69,LRODT,1,LRSN,2,"B",LRTSN,$P(ORPK,"^",3)) S LRTSN=$P(^LAB(60,LRTSN,0),"^") S:'$D(^LRO(69,LRODT,1,LRSN,6,0)) ^(0)="^69.04^^"
;S LRUSNM=$P(^VA(200,DUZ,0),"^"),X=1+$P(^LRO(69,LRODT,1,LRSN,6,0),"^",3),$P(^(0),"^",3,4)=X_"^"_X,^(X,0)="Ordered test "_LRTSN_" deleted by "_LRUSNM
;S DIE="^LRO(69,LRODT,1,",DA=LRSN,DR=16 D ^DIE
S Y=$P(^LRO(69,LRODT,1,LRSN,0),"^",8) D DD^%DT W !," Ordered test "_$P(^LAB(60,LRTSN,0),"^")_" for "_Y_" cancelled."
Q
P ;;Purge execute from OR
S LREND=0,LRXODT=+ORPK,LRXSN=$P(ORPK,"^",2),LRXTN=$P(ORPK,"^",3)
I LRXODT,LRXSN,LRXTN,ORSTS'=1 D PEND
I 'LREND S ORSTS="K" D ST^ORX
K LRXODT,LRXSN,LRXTN,LREND Q
SETUP ;;Setup execute from OR
Q
CLEAN ;;Clean-up execute from OR
D LREND^LROW4
K LRASK,LRPREV,LROCK,LRPGM,LRTSNM,LRCK,LRDTX,LROSX,LREK,LROST,LRPRAM,LRA,LRAA,LRABV,LRAD,LRAX,LRC,LRH,LRSF,LRSS,LRSX,LRU,LRWHO,LRECUR,LRNOW,LRSTUB,LRZX,LRSZX
K ^XUTL("OR",$J,"LROST"),^("LRZX"),^("LROT"),^("COM")
Q
PEND I '$D(^LRO(69,LRXODT,1,LRXSN,0)) Q
S X=+^LRO(69,LRXODT,1,LRXSN,0) I $D(^LR(X,0)),$P(^(0),"^",2)'=2 G P1
I '$D(^LRO(69,LRXODT,1,LRXSN,1)) S LREND=1 Q
I ORSTS=5 S LREND=1 Q
I $D(^LRO(69,LRXODT,1,LRXSN,3)),'$L($P(^(3),"^",2)) S LREND=1 Q
P1 S:$D(^LRO(69,LRXODT,1,LRXSN,2,LRXTN,0)) $P(^(0),"^",7)="" Q
Q
LROR3 ; IHS/DIR/AAB - CANCEL,PURGE,SETUP,CLEAN EXECUTES 11/26/90 10:10 ; [ 09/06/2002 7:11 AM ]
+1 ;;5.2T9;LR;**1002,1003,1013,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**100,121,165**;Sep 27, 1994
C ;;Cancel execute from OR
+1 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;RESTORE CALL TO ORX
+3 IF ORSTS=""
IF $DATA(ORPK)
IF $LENGTH($PIECE(ORPK,"^",8))
SET X=$PIECE(ORPK,"^",2)_","""_$PIECE(ORPK,"^",5)_""","_$PIECE(ORPK,"^",3)_","_$PIECE(ORPK,"^",4)_","_$PIECE(ORPK,"^",8)
IF $LENGTH(X)
KILL @("^XUTL(""OR"",$J,""LROT"","_X_")")
SET ORSTS="K"
DO ST^ORX
WRITE " Deleted"
QUIT
+4 ;BEGIN IHS MODIFICTIONS LR*5.2*1016
+5 ;REMOVE MODS TO TAKE OUT CALL MADE TO ORX ABOVE
+6 ;I ORSTS="",$D(ORPK),$L($P(ORPK,"^",8)) S X=$P(ORPK,"^",2)_","""_$P(ORPK,"^",5)_""","_$P(ORPK,"^",3)_","_$P(ORPK,"^",4)_","_$P(ORPK,"^",8) ;IHS/DIR TUC/AAB 06/15/98
+7 ;I ORSTS="",$D(ORPK),$L($P(ORPK,"^",8)) K:$L(X) @("^XUTL(""OR"",$J,""LROT"","_X_")") S ORSTS="K" W " Deleted" Q ;IHS/DIR TUC/AAB 06/15/98
+8 IF +ORSTS=11
SET ORSTS="K"
DO ST^ORX
WRITE " Deleted"
QUIT
+9 ;I +ORSTS=11 S ORSTS="K" W " Deleted" Q ;IHS/DIR TUC/AAB 06/15/98
+10 IF ORGY=0
DO C3
IF LREND
QUIT
+11 IF ORGY'=0
SET LRODT=+ORPK
SET LRSN=$PIECE(ORPK,"^",2)
SET I=$PIECE(ORPK,"^",3)
+12 IF 'LRODT!('LRSN)!('I)
SET ORSTS=1
IF ORGY=9
DO ST^ORX
QUIT
+13 ;I 'LRODT!('LRSN)!('I) S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
+14 IF '$DATA(^LRO(69,LRODT,1,LRSN))
IF ORGY=10
QUIT
+15 IF '$DATA(^LRO(69,LRODT,1,LRSN))
IF ORGY=9
SET ORSTS=1
DO ST^ORX
QUIT
+16 ;I '$D(^LRO(69,LRODT,1,LRSN)),ORGY=9 S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
+17 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,I))
IF ORGY=10
QUIT
+18 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,I))
IF ORGY=9
SET ORSTS=1
DO ST^ORX
QUIT
+19 ;I '$D(^LRO(69,LRODT,1,LRSN,2,I)),ORGY=9 S ORSTS=1 Q ;IHS/DIR TUC/AAB 06/15/98
+20 ;END IHS MODIFICATIONS TO RESTORE CALLS TO ORX
+21 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
IF $PIECE(^(3),"^",2)
WRITE !,"Tests already verified for this portion of the order, cannot delete."
GOTO END
C1 SET LRORD=+^LRO(69,LRODT,1,LRSN,.1)
SET X=^(2,I,0)
SET LRTSN=+X
SET LRAD=+$PIECE(X,"^",3)
SET LRAA=+$PIECE(X,"^",4)
SET LRAN=+$PIECE(X,"^",5)
SET (LRNOP,LRACC)=""
SET LRONE=""
+1 IF LRAD
IF LRAA
IF LRAN
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
IF '$DATA(^XUSEC("LRLAB",DUZ))
WRITE !!,$CHAR(7),"Already accessioned. Contact lab to cancel.",!
GOTO END
+2 ;BEGIN IHS MODIFICATIONS LR*5.2*1018
C2 IF ORGY=0
DO DC^ORX5
SET LREND=1
GOTO END
+1 ;I ORGY=0 S LREND=1 G END ;IHS/DIR TUC/AAB 06/15/98
+2 IF ORGY=9
DO C4
END KILL LRODT,LRSN,LRAD,LRAA,LRAN,LRNOP,LRACC,LRONE,LRC,LRDFN,LRDPF,LRSX,LRTSN,LRUSNM
+1 QUIT
C3 IF 'ORPK
DO C2
QUIT
+1 SET LRODT=+ORPK
SET LRSN=$PIECE(ORPK,"^",2)
SET I=$PIECE(ORPK,"^",3)
IF 'LRODT!('LRSN)!('I)
DO C2
QUIT
+2 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,I))
KILL LRODT,LRSN
DO C2
QUIT
+3 SET LREND=0
QUIT
+4 QUIT
C4 IF LRAD
IF LRAA
IF LRAN
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
DO OR^LRCENDE1
IF LRNOP
GOTO END
+1 IF 'LRNOP
DO C5
+2 SET ORSTS=1
DO ST^ORX
+3 ;
+4 ;IHS/DIR TUC/AAB 06/15/98
SET ORSTS=1
+5 QUIT
C5 ;
+1 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,$PIECE(ORPK,"^",3),0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^W^"_DUZ
+2 ;K ^LRO(69,LRODT,1,LRSN,2,$P(ORPK,"^",3)),^LRO(69,LRODT,1,LRSN,2,"B",LRTSN,$P(ORPK,"^",3)) S LRTSN=$P(^LAB(60,LRTSN,0),"^") S:'$D(^LRO(69,LRODT,1,LRSN,6,0)) ^(0)="^69.04^^"
+3 ;S LRUSNM=$P(^VA(200,DUZ,0),"^"),X=1+$P(^LRO(69,LRODT,1,LRSN,6,0),"^",3),$P(^(0),"^",3,4)=X_"^"_X,^(X,0)="Ordered test "_LRTSN_" deleted by "_LRUSNM
+4 ;S DIE="^LRO(69,LRODT,1,",DA=LRSN,DR=16 D ^DIE
+5 SET Y=$PIECE(^LRO(69,LRODT,1,LRSN,0),"^",8)
DO DD^%DT
WRITE !," Ordered test "_$PIECE(^LAB(60,LRTSN,0),"^")_" for "_Y_" cancelled."
+6 QUIT
P ;;Purge execute from OR
+1 SET LREND=0
SET LRXODT=+ORPK
SET LRXSN=$PIECE(ORPK,"^",2)
SET LRXTN=$PIECE(ORPK,"^",3)
+2 IF LRXODT
IF LRXSN
IF LRXTN
IF ORSTS'=1
DO PEND
+3 IF 'LREND
SET ORSTS="K"
DO ST^ORX
+4 KILL LRXODT,LRXSN,LRXTN,LREND
QUIT
SETUP ;;Setup execute from OR
+1 QUIT
CLEAN ;;Clean-up execute from OR
+1 DO LREND^LROW4
+2 KILL LRASK,LRPREV,LROCK,LRPGM,LRTSNM,LRCK,LRDTX,LROSX,LREK,LROST,LRPRAM,LRA,LRAA,LRABV,LRAD,LRAX,LRC,LRH,LRSF,LRSS,LRSX,LRU,LRWHO,LRECUR,LRNOW,LRSTUB,LRZX,LRSZX
+3 KILL ^XUTL("OR",$JOB,"LROST"),^("LRZX"),^("LROT"),^("COM")
+4 QUIT
PEND IF '$DATA(^LRO(69,LRXODT,1,LRXSN,0))
QUIT
+1 SET X=+^LRO(69,LRXODT,1,LRXSN,0)
IF $DATA(^LR(X,0))
IF $PIECE(^(0),"^",2)'=2
GOTO P1
+2 IF '$DATA(^LRO(69,LRXODT,1,LRXSN,1))
SET LREND=1
QUIT
+3 IF ORSTS=5
SET LREND=1
QUIT
+4 IF $DATA(^LRO(69,LRXODT,1,LRXSN,3))
IF '$LENGTH($PIECE(^(3),"^",2))
SET LREND=1
QUIT
P1 IF $DATA(^LRO(69,LRXODT,1,LRXSN,2,LRXTN,0))
SET $PIECE(^(0),"^",7)=""
QUIT
+1 QUIT
