BLRSGNSP ; IHS/MSC/MKK - Delete Order even though in SiGN or SYmptom Process ; 31-Jul-2015 06:30 ; MKK
;;5.2;LR;**1033,1035,1036**;NOV 1, 1997;Build 10
;
; Code cloned from LRCENDEL routine.
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
EP ; EP - ORDERN = Order Number
GETRID(ORDERN) ; EP - Cancel ALL Tests on an Order
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)
;
S LRORT=+$G(^TMP("BLRDIAG",$J,"ORDER","ADDTST"))
I LRORT D GETRID1(ORDERN,LRORT) Q
;
S (DELCNT,LRODT)=0
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP)) Q:LRSP<1 D
.. ;
.. D OERRSTSC^BLRUTIL7(LRODT,LRSP) ; IHS/MSC/MKK - LR*5.2*1035
.. ;
.. S LRORT=0
.. F S LRORT=$O(^LRO(69,LRODT,1,LRSP,2,LRORT)) Q:LRORT<1 D
... S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
... ;
... ; Skip if already cancelled
... Q:$L($P(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
... ;
... S FDAIENS=LRORT_","_LRSP_","_LRODT_","
... K FDA
... S FDA(69.03,FDAIENS,8)="CA"
... S FDA(69.03,FDAIENS,11)=$G(DUZ)
... D FILE^DIE("KS","FDA","ERRS")
... ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File") Q
... I $D(ERRS) D ERRMSG^BLRSGNS3("GETRID: FILE^DIE","BLRSGNSP") Q ; IHS/MSC/MKK - LR*5.2*1035
... D MAKEMESG(LRODT,LRSP,LRORT)
... S DELCNT=DELCNT+1
... D DELACC(LRODT,LRSP,LRORT)
;
K ^TMP("BLRDAIG",$J,"ORDER")
K ^TMP("BLR SNOMED GET",$J,"HDR")
Q:DELCNT<1
;
W !!,"All Tests on Order ",ORDERN,":",!
S LRODT=0
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP)) Q:LRSP<1 D
.. S LRORT=0
.. F S LRORT=$O(^LRO(69,LRODT,1,LRSP,2,LRORT)) Q:LRORT<1 D
... S IENS=LRORT_","_LRSP_","_LRODT
... W ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
;
D PRESSKEY^BLRGMENU(9)
Q
;
GETRID1(ORDERN,LRORT) ; EP - Cancel One Test on an Order
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORT,ORDERN,U,XPARSYS,XQXFLG)
;
S LRODT=0
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP)) Q:LRSP<1 D
.. S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
.. Q:$L(STR)<1
.. ;
.. ; Skip if already cancelled
.. Q:$L($P(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
.. ;
.. D OERRSTSO^BLRUTIL7(LRODT,LRSP,LRORT) ; IHS/MSC/MKK - LR*5.2*1035
.. ;
.. S FDAIENS=LRORT_","_LRSP_","_LRODT_","
.. K FDA
.. S FDA(69.03,FDAIENS,8)="CA"
.. S FDA(69.03,FDAIENS,11)=$G(DUZ)
.. D FILE^DIE("KS","FDA","ERRS")
.. ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File") Q
.. ; I $D(ERRS) D ERRMSG("GETRID1: FILE^DIE") Q
.. I $D(ERRS) D ERRMSG^BLRSGNS3("GETRID1: FILE^DIE","BLRSGNSP") Q ; IHS/MSC/MKK - LR*5.2*1035
.. D MAKEMESG(LRODT,LRSP,LRORT)
.. ;
.. D DELACC(LRODT,LRSP,LRORT)
;
K ^TMP("BLRDAIG",$J,"ORDER")
K ^TMP("BLR SNOMED GET",$J,"HDR")
;
W !!,"Test on Order ",ORDERN,":",!
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP)) Q:LRSP<1 D
.. S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
.. Q:$L(STR)<1
.. S IENS=LRORT_","_LRSP_","_LRODT
.. W ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
;
D PRESSKEY^BLRGMENU(9)
Q
;
DELACC(LRODT,LRSP,LRORT) ; EP - Cancel Test on Accession and add note on Lab Data File
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRORT,LRSP,U,XPARSYS,XQXFLG)
;
S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
;
S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
Q:LRAD<1!(LRAA<1)!(LRAN<1) ; Skip if no Accession
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)
;
; Need to get File 68 variables
S LROTF60=+$G(STR) ; File 60 Pointer
;
S (FOUND,LRAT)=0
F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1!(FOUND) D
. S:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT,0))=LROTF60 FOUND=LRAT
;
Q:FOUND<1 ; Skip if cannot find Test on Accession
;
; File 68 "NOT PERFORMED"
D ^XBFMK
S IENS=FOUND_","_LRAN_","_LRAD_","_LRAA_","
K FDA,ERRS
S FDA(68.04,IENS,3)=$G(DUZ)
S FDA(68.04,IENS,4)=$$NOW^XLFDT
S FDA(68.04,IENS,5)="*Not Performed"
D FILE^DIE("KS","FDA","ERRS")
; I $D(ERRS) D SHOWERRS^BLRADDCD("Accession File") Q
I $D(ERRS) D ERRMSG^BLRSGNS3("File 68 - DELACC: FILE^DIE","BLRSGNSP") Q ; IHS/MSC/MKK - LR*5.2*1035
;
; File 63 "NOT PERFORMED"
S F60NAME=$$GET1^DIQ(60,LROTF60,"NAME")
S DEL1="*"_F60NAME_" Not Performed: "_$$HTE^XLFDT($H,"5MPZ")_" by "_$G(DUZ)
S DEL2="*NP Reason: User Quit During Clinical Indication Selection."
K IENS,FDA,ERRS
S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1 ; Get next COMMENT line
S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL1
D UPDATE^DIE(,"FDA","IENS","ERRS")
; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File") Q
; I $D(ERRS) D ERRMSG("File 63.041 - DELACC: UPDATE^DIE") Q
I $D(ERRS) D ERRMSG^BLRSGNS3("File 63.041 - DELACC: UPDATE^DIE","BLRSGNSP") Q ; IHS/MSC/MKK - LR*5.2*1035
;
K IENS,FDA,ERRS
S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1 ; Get next COMMENT line
S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL2
D UPDATE^DIE(,"FDA","IENS","ERRS")
; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File")
; I $D(ERRS) D ERRMSG("File 63.041, Line 2 - DELACC: UPDATE^DIE") Q
I $D(ERRS) D ERRMSG^BLRSGNS3("File 63.041, Line 2 - DELACC: UPDATE^DIE","BLRSGNSP") Q ; IHS/MSC/MKK - LR*5.2*1035
Q
;
; ----- Begin IHS/MSC/MKK - LR*5.2*1036
ERRMSG(MSG,ERRFRTN) ; EP - Left in for other routines to call.
D ERRMSG^BLRSGNS3(MSG,ERRFRTN)
Q
; ----- End IHS/MSC/MKK - LR*5.2*1036
;
MAKEMESG(LRODT,LRSN,LRI) ; EP - Create the cancel reason in 69 - some code cloned from LRHYDEL routine.
NEW II,ORIFN,LRMSTATI,LRNATURE,LRSTATUS
;
S ORIFN=$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="OTHER CANCEL REASON: *NP Reason:User Quit During Clinical Indication Selection."
S X=X+1,X(1)=X(1)+1
S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$HTE^XLFDT($H,"5MZ")
S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
Q
;
W @IOF N LRCANK,LRTN
S BLROPT="DELORD",BLROPT(0)=$P($G(XQY0),U)
FIND ; EP
S LREND=0 D ^LRPARAM I $G(LREND) G END
K LRDFN,LRONE,LRNATURE
W !?3,"If lab has received the sample (i.e. the test has an accession),",!,?3,"you can't change this order. If so, use the REMOVE AN ACCESSION option",!,?3,"to change the test." ; IHS/OIT/MKK - LR*5.2*1033
D
. N DIR
. S DIR("A")="ENTER ORDER NUMBER: "
. S DIR(0)="LO^1:9999999999"
. S DIR("?")="Enter the number associated with the order. "
. S DIR("??")="^D ^LROS"
. S DIR("S")="I $O(^LRO(69,""C"",X,0))"
. S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035
. D ^DIR
G END:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
S LRORD=X
W @IOF D LOOK G FIND
Q
;
LOOK ; EP
S LRCNT=0,LRODT=$O(^LRO(69,"C",LRORD,0)) I LRODT<1 W !,"Not found." Q
S (LRCANK,LROV,LRSN,LRCOL)=0
F S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1!($G(LREND)) D:'$G(LREND) SHOW^LROS S LRCNT=1 S:$S($D(^LRO(69,LRODT,1,LRSN,3)):$P(^(3),U,2),1:0) LROV=1 D
. L +^LRO(69,"C",+LRORD):1 I '$T W !?5,"Someone Else is Editing this order, try later",! S LREND=1 Q
. S LRTN=0 F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 S X=^(LRTN,0) I '$P(X,"^",11) S LRCANK=1 Q
I $G(LREND) D UNL69,END Q
I LRCNT<1 W !,"No order found with that number." D UNL69,END Q
I 'LRCANK W !!,"[ * All tests on this order # have already been dispositoned. * ]" D NAME Q
I $G(LRCOL) D D UNL69,END Q
. W !!?5," You CAN NOT change the status of test(s) on this order."
. W !,"Test sample(s) have already been received into the laboratory."
. W !,"You must use the REMOVE AN ACCESSION option to have the test(s) status changed.",$C(7)
D NAME
S LRNOP=0 S %=1 ; I 'LROV F I=0:0 W !,"Change entire order" S %=2 D YN^DICN Q:% W "Answer 'Y'es or 'N'o."
I 'LROV G END:%=-1,OUT:%=1
S LRT=0,J=0 F S J=$O(LRT(J)) Q:J<1 S LRT=J
I LRT<1 W !,$$CJ^XLFSTR(" Can't change status of test(s) on this order.",IOM),! D UNL69 Q
MORE ; EP
W !,?8,"entry",?15,"test",?40,"sample"
S LRT=0,J=0 F S J=$O(LRT(J)) Q:J<1 S LRT=J W !,?10,J,?15,$P(^LAB(60,$P(LRT(J),U,3),0),U),?40,$P(LRT(J),U,4)
I LRT=0 W !,"All have been dispositioned from that order."
Q
;
ONE ; EP
R !,"Change status of which entry: ",LRJ:DTIME W:LRJ["?" !,"Pick one of the following entries:" G MORE:LRJ["?" Q:LRJ["^"!(LRJ="")
I LRJ'=+LRJ!(LRJ<1)!(LRJ>LRT) W !,"Enter a number between 1 and ",LRT,! G ONE
I '$D(LRT(LRJ)) W !,"You've already dispositioned that one.",! G MORE
K LRNATURE
D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
K LRTSTI,LRMSTATI D EN1,UNL69 G LOOK
Q
;
EN1 ; EP
I '$D(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0))#2 W !,"Does not exist ",! Q
S LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),LRAD=+$P(LRX,U,3),LRAA=+$P(LRX,U,4),LRAN=+$P(LRX,U,5),LRNOP=0,LRONE="",LRACC=0,ORIFN=$P(LRX,U,7)
S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
S LRTNM=$P($G(^LAB(60,LRTSTS,0)),U)
I '$L($G(LRNATURE)) D DC^LROR6() I $G(LRNATURE)=-1 W !!,$C(7),"NOTHING CHANGED" Q
S LRIDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
I LRIDT L +^LR(LRDFN,LRSS,LRIDT):1 I '$T W !?5,"Someone else is editing this entry",! S LREND=1 Q
D SET^LRTSTOUT I LRIDT L -^LR(LRDFN,LRSS,LRIDT)
D UNL69
Q
;
D CEN1^LRCENDE1 K LRONE Q:LRACC&'$D(^XUSEC("LRLAB",DUZ))
I LRTSTI,'$G(LRNOP) D
. N LRI S LRI(LRTSN)=""
. D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.LRI,$G(LRMSTATI))
. S $P(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ K T(LRJ)
. S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=LRTSTI,DA(1)=LRODT,DR=99 D ^DIE
K LRI
S X=DUZ D DUZ^LRX
W:'LRNOP !!,"Status changed to Not Performed" G FIND:$O(LRT(0))<1,ONE
;
OUT ; EP
Q:$G(LRNOP) S LRJ=0
D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
S LRCCOMX=LRCCOM
S LRJ=0 F S LRJ=$O(LRT(LRJ)) Q:LRJ<1 S LRCCOM=LRCCOMX D
. S LRSN=0
. F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D
.. S LRTSTI=0
.. F S LRTSTI=$O(^LRO(69,LRODT,1,LRSN,2,LRTSTI)) Q:LRTSTI<1 D
... S IENS=LRTSTI_","_LRSN_","_LRODT_","
;
K LRCCOMX D UNL69
Q
;
S LRSN=0 F S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1 D
. S LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),LRAD=$P(LRX,U,3),LRAA=+$P(LRX,U,4),LRAN=+$P(LRX,U,5),LRNOP=0,LRONE="",LRACC=0,ORIFN=$P(LRX,U,7)
;
ALLDEL ; EP
K LRNATURE G FIND
;
% ; EP
K DIR,X,Y,%
S DIR(0)="YO"
S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035
D ^DIR
S %=$E(X)
Q
;
UNL69 ;
L -^LRO(69,"C",+LRORD)
Q
;
NAME ; EP
S LRDFN=+^LRO(69,LRODT,1,$O(^LRO(69,"C",+LRORD,LRODT,0)),0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX W !,PNM,?30,HRCN
;
EN ;from LRPHITE3
K LRT S (J,LRSN,LRNOP)=0 F S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1!($G(LRNOP)) D TSET
Q
;
TSET ; EP
I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) D Q
. W !,$$CJ^XLFSTR("Test(s) already verified for this order, cannot change ENTIRE order",IOM)
. W !,$$CJ^XLFSTR(" You must select individual test using the 'Delete Test from Accession' option.",IOM),!!
. D UNL69 S LRNOP=1
;
S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) D
. Q:$P(X,"^",11)
. I $P(X,U,3),'$D(LRLABKY) Q
. S J=J+1,LRSPEC=$S($D(^LRO(69,LRODT,1,LRSN,4,1,0)):+^(0),1:""),LRT(J)=LRSN_U_I_U_+X_U_$S(LRSPEC:$P(^LAB(61,+LRSPEC,0),U),1:"")_U_$P(X,U,2,99)
Q
;
END ; EP
K %,A,AGE,DFN,DIC,DIE,DOB,DQ,DR,DWLW,HRCN,I,J,K,LRAA,LRACC,LRACN,LRACN0,LRAD,LRAN,LRCL,LRCNT,LRCOL
K LRDOC,LRDPF,LRDTM,LREND,LRIDT,LRJ,LRNOW,LRLL,LRLLOC,LRNATURE,LRNOP,LROD0,LROD1,LROD3,LRODT
K LROOS,LRORD,LROS,LROSD,LROT,LROV,LRROD,LRSCNXB,LRSN,LRSPEC,LRSS,LRTC,LRTP,LRTSTI,LRTSTS,LRT,LRTT
K LRURG,LRUSI,LRUSNM,LRWRD,LRCANK,LRTN,LRCCOM,LRCCOM1
K PNM,SEX,SSN,T,X,X1,X2,X3,X4,Y,Z,ORIFN
D END^LRTSTOUT
Q
BLRSGNSP ; IHS/MSC/MKK - Delete Order even though in SiGN or SYmptom Process ; 31-Jul-2015 06:30 ; MKK
+1 ;;5.2;LR;**1033,1035,1036**;NOV 1, 1997;Build 10
+2 ;
+3 ; Code cloned from LRCENDEL routine.
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP - ORDERN = Order Number
GETRID(ORDERN) ; EP - Cancel ALL Tests on an Order
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRORT=+$GET(^TMP("BLRDIAG",$JOB,"ORDER","ADDTST"))
+4 IF LRORT
DO GETRID1(ORDERN,LRORT)
QUIT
+5 ;
+6 SET (DELCNT,LRODT)=0
+7 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+8 SET LRSP=0
+9 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+10 ;
+11 ; IHS/MSC/MKK - LR*5.2*1035
DO OERRSTSC^BLRUTIL7(LRODT,LRSP)
+12 ;
+13 SET LRORT=0
+14 FOR
SET LRORT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LRORT))
IF LRORT<1
QUIT
Begin DoDot:3
+15 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
+16 ;
+17 ; Skip if already cancelled
+18 IF $LENGTH($PIECE(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
QUIT
+19 ;
+20 SET FDAIENS=LRORT_","_LRSP_","_LRODT_","
+21 KILL FDA
+22 SET FDA(69.03,FDAIENS,8)="CA"
+23 SET FDA(69.03,FDAIENS,11)=$GET(DUZ)
+24 DO FILE^DIE("KS","FDA","ERRS")
+25 ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File") Q
+26 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("GETRID: FILE^DIE","BLRSGNSP")
QUIT
+27 DO MAKEMESG(LRODT,LRSP,LRORT)
+28 SET DELCNT=DELCNT+1
+29 DO DELACC(LRODT,LRSP,LRORT)
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 KILL ^TMP("BLRDAIG",$JOB,"ORDER")
+32 KILL ^TMP("BLR SNOMED GET",$JOB,"HDR")
+33 IF DELCNT<1
QUIT
+34 ;
+35 WRITE !!,"All Tests on Order ",ORDERN,":",!
+36 SET LRODT=0
+37 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+38 SET LRSP=0
+39 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+40 SET LRORT=0
+41 FOR
SET LRORT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LRORT))
IF LRORT<1
QUIT
Begin DoDot:3
+42 SET IENS=LRORT_","_LRSP_","_LRODT
+43 WRITE ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;
+45 DO PRESSKEY^BLRGMENU(9)
+46 QUIT
+47 ;
GETRID1(ORDERN,LRORT) ; EP - Cancel One Test on an Order
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORT,ORDERN,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRODT=0
+4 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+5 SET LRSP=0
+6 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+7 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
+8 IF $LENGTH(STR)<1
QUIT
+9 ;
+10 ; Skip if already cancelled
+11 IF $LENGTH($PIECE(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
QUIT
+12 ;
+13 ; IHS/MSC/MKK - LR*5.2*1035
DO OERRSTSO^BLRUTIL7(LRODT,LRSP,LRORT)
+14 ;
+15 SET FDAIENS=LRORT_","_LRSP_","_LRODT_","
+16 KILL FDA
+17 SET FDA(69.03,FDAIENS,8)="CA"
+18 SET FDA(69.03,FDAIENS,11)=$GET(DUZ)
+19 DO FILE^DIE("KS","FDA","ERRS")
+20 ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File") Q
+21 ; I $D(ERRS) D ERRMSG("GETRID1: FILE^DIE") Q
+22 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("GETRID1: FILE^DIE","BLRSGNSP")
QUIT
+23 DO MAKEMESG(LRODT,LRSP,LRORT)
+24 ;
+25 DO DELACC(LRODT,LRSP,LRORT)
End DoDot:2
End DoDot:1
+26 ;
+27 KILL ^TMP("BLRDAIG",$JOB,"ORDER")
+28 KILL ^TMP("BLR SNOMED GET",$JOB,"HDR")
+29 ;
+30 WRITE !!,"Test on Order ",ORDERN,":",!
+31 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+32 SET LRSP=0
+33 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+34 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
+35 IF $LENGTH(STR)<1
QUIT
+36 SET IENS=LRORT_","_LRSP_","_LRODT
+37 WRITE ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
End DoDot:2
End DoDot:1
+38 ;
+39 DO PRESSKEY^BLRGMENU(9)
+40 QUIT
+41 ;
DELACC(LRODT,LRSP,LRORT) ; EP - Cancel Test on Accession and add note on Lab Data File
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRORT,LRSP,U,XPARSYS,XQXFLG)
+2 ;
+3 SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
+4 ;
+5 SET LRAD=+$PIECE(STR,"^",3)
SET LRAA=+$PIECE(STR,"^",4)
SET LRAN=+$PIECE(STR,"^",5)
+6 ; Skip if no Accession
IF LRAD<1!(LRAA<1)!(LRAN<1)
QUIT
+7 ;
+8 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRIDT=$PIECE($GET(^(3)),"^",5)
+9 ;
+10 ; Need to get File 68 variables
+11 ; File 60 Pointer
SET LROTF60=+$GET(STR)
+12 ;
+13 SET (FOUND,LRAT)=0
+14 FOR
SET LRAT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))
IF LRAT<1!(FOUND)
QUIT
Begin DoDot:1
+15 IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT,0))=LROTF60
SET FOUND=LRAT
End DoDot:1
+16 ;
+17 ; Skip if cannot find Test on Accession
IF FOUND<1
QUIT
+18 ;
+19 ; File 68 "NOT PERFORMED"
+20 DO ^XBFMK
+21 SET IENS=FOUND_","_LRAN_","_LRAD_","_LRAA_","
+22 KILL FDA,ERRS
+23 SET FDA(68.04,IENS,3)=$GET(DUZ)
+24 SET FDA(68.04,IENS,4)=$$NOW^XLFDT
+25 SET FDA(68.04,IENS,5)="*Not Performed"
+26 DO FILE^DIE("KS","FDA","ERRS")
+27 ; I $D(ERRS) D SHOWERRS^BLRADDCD("Accession File") Q
+28 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("File 68 - DELACC: FILE^DIE","BLRSGNSP")
QUIT
+29 ;
+30 ; File 63 "NOT PERFORMED"
+31 SET F60NAME=$$GET1^DIQ(60,LROTF60,"NAME")
+32 SET DEL1="*"_F60NAME_" Not Performed: "_$$HTE^XLFDT($HOROLOG,"5MPZ")_" by "_$GET(DUZ)
+33 SET DEL2="*NP Reason: User Quit During Clinical Indication Selection."
+34 KILL IENS,FDA,ERRS
+35 ; Get next COMMENT line
SET IENS(1)=$ORDER(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1
+36 SET FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL1
+37 DO UPDATE^DIE(,"FDA","IENS","ERRS")
+38 ; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File") Q
+39 ; I $D(ERRS) D ERRMSG("File 63.041 - DELACC: UPDATE^DIE") Q
+40 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("File 63.041 - DELACC: UPDATE^DIE","BLRSGNSP")
QUIT
+41 ;
+42 KILL IENS,FDA,ERRS
+43 ; Get next COMMENT line
SET IENS(1)=$ORDER(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1
+44 SET FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL2
+45 DO UPDATE^DIE(,"FDA","IENS","ERRS")
+46 ; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File")
+47 ; I $D(ERRS) D ERRMSG("File 63.041, Line 2 - DELACC: UPDATE^DIE") Q
+48 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("File 63.041, Line 2 - DELACC: UPDATE^DIE","BLRSGNSP")
QUIT
+49 QUIT
+50 ;
+51 ; ----- Begin IHS/MSC/MKK - LR*5.2*1036
ERRMSG(MSG,ERRFRTN) ; EP - Left in for other routines to call.
+1 DO ERRMSG^BLRSGNS3(MSG,ERRFRTN)
+2 QUIT
+3 ; ----- End IHS/MSC/MKK - LR*5.2*1036
+4 ;
MAKEMESG(LRODT,LRSN,LRI) ; EP - Create the cancel reason in 69 - some code cloned from LRHYDEL routine.
+1 NEW II,ORIFN,LRMSTATI,LRNATURE,LRSTATUS
+2 ;
+3 SET ORIFN=$PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
+4 SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1)
SET X(1)=$PIECE($GET(^(0)),U,4)
+5 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="OTHER CANCEL REASON: *NP Reason:User Quit During Clinical Indication Selection."
+6 SET X=X+1
SET X(1)=X(1)+1
+7 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$HTE^XLFDT($HOROLOG,"5MZ")
+8 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
+9 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"
SET $PIECE(^(0),U,10)="L"
SET $PIECE(^(0),U,11)=DUZ
+10 IF $DATA(^LRO(69,LRODT,1,LRSN,"PCE"))
SET ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
+11 QUIT
+12 ;
+13 WRITE @IOF
NEW LRCANK,LRTN
+14 SET BLROPT="DELORD"
SET BLROPT(0)=$PIECE($GET(XQY0),U)
FIND ; EP
+1 SET LREND=0
DO ^LRPARAM
IF $GET(LREND)
GOTO END
+2 KILL LRDFN,LRONE,LRNATURE
+3 ; IHS/OIT/MKK - LR*5.2*1033
WRITE !?3,"If lab has received the sample (i.e. the test has an accession),",!,?3,"you can't change this order. If so, use the REMOVE AN ACCESSION option",!,?3,"to change the test."
+4 Begin DoDot:1
+5 NEW DIR
+6 SET DIR("A")="ENTER ORDER NUMBER: "
+7 SET DIR(0)="LO^1:9999999999"
+8 SET DIR("?")="Enter the number associated with the order. "
+9 SET DIR("??")="^D ^LROS"
+10 SET DIR("S")="I $O(^LRO(69,""C"",X,0))"
+11 ; IHS/MSC/MKK - LR*5.2*1035
SET DIR("T")=1800
+12 DO ^DIR
End DoDot:1
+13 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
GOTO END
+14 SET LRORD=X
+15 WRITE @IOF
DO LOOK
GOTO FIND
+16 QUIT
+17 ;
LOOK ; EP
+1 SET LRCNT=0
SET LRODT=$ORDER(^LRO(69,"C",LRORD,0))
IF LRODT<1
WRITE !,"Not found."
QUIT
+2 SET (LRCANK,LROV,LRSN,LRCOL)=0
+3 FOR
SET LRSN=$ORDER(^LRO(69,"C",+LRORD,LRODT,LRSN))
IF LRSN<1!($GET(LREND))
QUIT
IF '$GET(LREND)
DO SHOW^LROS
SET LRCNT=1
IF $SELECT($DATA(^LRO(69,LRODT,1,LRSN,3))
SET LROV=1
Begin DoDot:1
+4 LOCK +^LRO(69,"C",+LRORD):1
IF '$TEST
WRITE !?5,"Someone Else is Editing this order, try later",!
SET LREND=1
QUIT
+5 SET LRTN=0
FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
IF LRTN<1
QUIT
SET X=^(LRTN,0)
IF '$PIECE(X,"^",11)
SET LRCANK=1
QUIT
End DoDot:1
+6 IF $GET(LREND)
DO UNL69
DO END
QUIT
+7 IF LRCNT<1
WRITE !,"No order found with that number."
DO UNL69
DO END
QUIT
+8 IF 'LRCANK
WRITE !!,"[ * All tests on this order # have already been dispositoned. * ]"
DO NAME
QUIT
+9 IF $GET(LRCOL)
Begin DoDot:1
+10 WRITE !!?5," You CAN NOT change the status of test(s) on this order."
+11 WRITE !,"Test sample(s) have already been received into the laboratory."
+12 WRITE !,"You must use the REMOVE AN ACCESSION option to have the test(s) status changed.",$CHAR(7)
End DoDot:1
DO UNL69
DO END
QUIT
+13 DO NAME
+14 ; I 'LROV F I=0:0 W !,"Change entire order" S %=2 D YN^DICN Q:% W "Answer 'Y'es or 'N'o."
SET LRNOP=0
SET %=1
+15 IF 'LROV
IF %=-1
GOTO END
IF %=1
GOTO OUT
+16 SET LRT=0
SET J=0
FOR
SET J=$ORDER(LRT(J))
IF J<1
QUIT
SET LRT=J
+17 IF LRT<1
WRITE !,$$CJ^XLFSTR(" Can't change status of test(s) on this order.",IOM),!
DO UNL69
QUIT
MORE ; EP
+1 WRITE !,?8,"entry",?15,"test",?40,"sample"
+2 SET LRT=0
SET J=0
FOR
SET J=$ORDER(LRT(J))
IF J<1
QUIT
SET LRT=J
WRITE !,?10,J,?15,$PIECE(^LAB(60,$PIECE(LRT(J),U,3),0),U),?40,$PIECE(LRT(J),U,4)
+3 IF LRT=0
WRITE !,"All have been dispositioned from that order."
+4 QUIT
+5 ;
ONE ; EP
+1 READ !,"Change status of which entry: ",LRJ:DTIME
IF LRJ["?"
WRITE !,"Pick one of the following entries:"
IF LRJ["?"
GOTO MORE
IF LRJ["^"!(LRJ="")
QUIT
+2 IF LRJ'=+LRJ!(LRJ<1)!(LRJ>LRT)
WRITE !,"Enter a number between 1 and ",LRT,!
GOTO ONE
+3 IF '$DATA(LRT(LRJ))
WRITE !,"You've already dispositioned that one.",!
GOTO MORE
+4 KILL LRNATURE
+5 DO FX2^LRTSTOUT
IF $GET(LREND)
DO UNL69
DO END
QUIT
+6 KILL LRTSTI,LRMSTATI
DO EN1
DO UNL69
GOTO LOOK
+7 QUIT
+8 ;
EN1 ; EP
+1 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0))#2
WRITE !,"Does not exist ",!
QUIT
+2 SET LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0)
SET LRAD=+$PIECE(LRX,U,3)
SET LRAA=+$PIECE(LRX,U,4)
SET LRAN=+$PIECE(LRX,U,5)
SET LRNOP=0
SET LRONE=""
SET LRACC=0
SET ORIFN=$PIECE(LRX,U,7)
+3 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+4 SET LRTNM=$PIECE($GET(^LAB(60,LRTSTS,0)),U)
+5 IF '$LENGTH($GET(LRNATURE))
DO DC^LROR6()
IF $GET(LRNATURE)=-1
WRITE !!,$CHAR(7),"NOTHING CHANGED"
QUIT
+6 SET LRIDT=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+7 IF LRIDT
LOCK +^LR(LRDFN,LRSS,LRIDT):1
IF '$TEST
WRITE !?5,"Someone else is editing this entry",!
SET LREND=1
QUIT
+8 DO SET^LRTSTOUT
IF LRIDT
LOCK -^LR(LRDFN,LRSS,LRIDT)
+9 DO UNL69
+10 QUIT
+11 ;
+12 DO CEN1^LRCENDE1
KILL LRONE
IF LRACC&'$DATA(^XUSEC("LRLAB",DUZ))
QUIT
+13 IF LRTSTI
IF '$GET(LRNOP)
Begin DoDot:1
+14 NEW LRI
SET LRI(LRTSN)=""
+15 DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.LRI,$GET(LRMSTATI))
+16 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
KILL T(LRJ)
+17 SET DIE="^LRO(69,LRODT,1,LRSN,2,"
SET DA=LRTSTI
SET DA(1)=LRODT
SET DR=99
DO ^DIE
End DoDot:1
+18 KILL LRI
+19 SET X=DUZ
DO DUZ^LRX
+20 IF 'LRNOP
WRITE !!,"Status changed to Not Performed"
IF $ORDER(LRT(0))<1
GOTO FIND
GOTO ONE
+21 ;
OUT ; EP
+1 IF $GET(LRNOP)
QUIT
SET LRJ=0
+2 DO FX2^LRTSTOUT
IF $GET(LREND)
DO UNL69
DO END
QUIT
+3 SET LRCCOMX=LRCCOM
+4 SET LRJ=0
FOR
SET LRJ=$ORDER(LRT(LRJ))
IF LRJ<1
QUIT
SET LRCCOM=LRCCOMX
Begin DoDot:1
+5 SET LRSN=0
+6 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSN))
IF LRSN<1
QUIT
Begin DoDot:2
+7 SET LRTSTI=0
+8 FOR
SET LRTSTI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTSTI))
IF LRTSTI<1
QUIT
Begin DoDot:3
+9 SET IENS=LRTSTI_","_LRSN_","_LRODT_","
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 KILL LRCCOMX
DO UNL69
+12 QUIT
+13 ;
+14 SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",+LRORD,LRODT,LRSN))
IF LRSN<1
QUIT
Begin DoDot:1
+15 SET LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0)
SET LRAD=$PIECE(LRX,U,3)
SET LRAA=+$PIECE(LRX,U,4)
SET LRAN=+$PIECE(LRX,U,5)
SET LRNOP=0
SET LRONE=""
SET LRACC=0
SET ORIFN=$PIECE(LRX,U,7)
End DoDot:1
+16 ;
ALLDEL ; EP
+1 KILL LRNATURE
GOTO FIND
+2 ;
% ; EP
+1 KILL DIR,X,Y,%
+2 SET DIR(0)="YO"
+3 ; IHS/MSC/MKK - LR*5.2*1035
SET DIR("T")=1800
+4 DO ^DIR
+5 SET %=$EXTRACT(X)
+6 QUIT
+7 ;
UNL69 ;
+1 LOCK -^LRO(69,"C",+LRORD)
+2 QUIT
+3 ;
NAME ; EP
+1 SET LRDFN=+^LRO(69,LRODT,1,$ORDER(^LRO(69,"C",+LRORD,LRODT,0)),0)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+2 DO PT^LRX
WRITE !,PNM,?30,HRCN
+3 ;
EN ;from LRPHITE3
+1 KILL LRT
SET (J,LRSN,LRNOP)=0
FOR
SET LRSN=$ORDER(^LRO(69,"C",+LRORD,LRODT,LRSN))
IF LRSN<1!($GET(LRNOP))
QUIT
DO TSET
+2 QUIT
+3 ;
TSET ; EP
+1 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
IF $PIECE(^(3),"^",2)
Begin DoDot:1
+2 WRITE !,$$CJ^XLFSTR("Test(s) already verified for this order, cannot change ENTIRE order",IOM)
+3 WRITE !,$$CJ^XLFSTR(" You must select individual test using the 'Delete Test from Accession' option.",IOM),!!
+4 DO UNL69
SET LRNOP=1
End DoDot:1
QUIT
+5 ;
+6 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
IF I<1
QUIT
SET X=^(I,0)
Begin DoDot:1
+7 IF $PIECE(X,"^",11)
QUIT
+8 IF $PIECE(X,U,3)
IF '$DATA(LRLABKY)
QUIT
+9 SET J=J+1
SET LRSPEC=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,4,1,0)):+^(0),1:"")
SET LRT(J)=LRSN_U_I_U_+X_U_$SELECT(LRSPEC:$PIECE(^LAB(61,+LRSPEC,0),U),1:"")_U_$PIECE(X,U,2,99)
End DoDot:1
+10 QUIT
+11 ;
END ; EP
+1 KILL %,A,AGE,DFN,DIC,DIE,DOB,DQ,DR,DWLW,HRCN,I,J,K,LRAA,LRACC,LRACN,LRACN0,LRAD,LRAN,LRCL,LRCNT,LRCOL
+2 KILL LRDOC,LRDPF,LRDTM,LREND,LRIDT,LRJ,LRNOW,LRLL,LRLLOC,LRNATURE,LRNOP,LROD0,LROD1,LROD3,LRODT
+3 KILL LROOS,LRORD,LROS,LROSD,LROT,LROV,LRROD,LRSCNXB,LRSN,LRSPEC,LRSS,LRTC,LRTP,LRTSTI,LRTSTS,LRT,LRTT
+4 KILL LRURG,LRUSI,LRUSNM,LRWRD,LRCANK,LRTN,LRCCOM,LRCCOM1
+5 KILL PNM,SEX,SSN,T,X,X1,X2,X3,X4,Y,Z,ORIFN
+6 DO END^LRTSTOUT
+7 QUIT
