- LROR3 ;SLC/DCM - CANCEL,PURGE,SETUP,CLEAN EXECUTES ;11/26/90 10:10 ;
- ;;5.2;LAB SERVICE;**100,121,165**;Sep 27, 1994
- C ;;Cancel execute from OR
- 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
- I +ORSTS=11 S ORSTS="K" D ST^ORX W " Deleted" Q
- 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 '$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,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,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
- C2 I ORGY=0 D DC^ORX5 S LREND=1 G END
- 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROR3 3036 printed Mar 13, 2025@21:23:09 Page 2
- LROR3 ;SLC/DCM - CANCEL,PURGE,SETUP,CLEAN EXECUTES ;11/26/90 10:10 ;
- +1 ;;5.2;LAB SERVICE;**100,121,165**;Sep 27, 1994
- C ;;Cancel execute from OR
- +1 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
- +2 IF +ORSTS=11
- SET ORSTS="K"
- DO ST^ORX
- WRITE " Deleted"
- QUIT
- +3 IF ORGY=0
- DO C3
- if LREND
- QUIT
- +4 IF ORGY'=0
- SET LRODT=+ORPK
- SET LRSN=$PIECE(ORPK,"^",2)
- SET I=$PIECE(ORPK,"^",3)
- +5 IF 'LRODT!('LRSN)!('I)
- SET ORSTS=1
- if ORGY=9
- DO ST^ORX
- QUIT
- +6 IF '$DATA(^LRO(69,LRODT,1,LRSN))
- IF ORGY=10
- QUIT
- +7 IF '$DATA(^LRO(69,LRODT,1,LRSN))
- IF ORGY=9
- SET ORSTS=1
- DO ST^ORX
- QUIT
- +8 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,I))
- IF ORGY=10
- QUIT
- +9 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,I))
- IF ORGY=9
- SET ORSTS=1
- DO ST^ORX
- QUIT
- +10 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
- C2 IF ORGY=0
- DO DC^ORX5
- SET LREND=1
- GOTO END
- +1 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 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
