Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRCENDEL

LRCENDEL.m

Go to the documentation of this file. 
  1. LRCENDEL ;SLC/CJS/DALOI/FHS-ORDER CANCELING NO TEST DELETE ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;LR;**1010,1013,1018,1033**;NOV 1, 1997
  1.  ;
  1.  ;;VA Lab Patches: 100,121,202,221,263 ; Sep 27, 1994
  1.  ;
  1.  W @IOF N LRCANK,LRTN
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  ;S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="DELORD",BLROPT(0)=$P(XQY0,U)  ;IHS/OIRM TUC/AAB 2/1/97
  1.  ;----- END IHS MODIFICATION
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS TESTING CHANGE
  1.  S BLROPT="DELORD",BLROPT(0)=$P($G(XQY0),U)
  1.  ;----- END IHS MODIFICATIONS
  1. FIND S LREND=0 D ^LRPARAM I $G(LREND) G END
  1.  K LRDFN,LRONE,LRNATURE
  1.  ; I '$D(LRLABKY) W !?3,"If lab has received the sample (i.e. the test has an accession),",!,"you can't change this order.  If so, call the lab to change the test."
  1.  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
  1.  D
  1.  . N DIR
  1.  . S DIR("A")="ENTER ORDER NUMBER: "
  1.  . S DIR(0)="LO^1:9999999999"
  1.  . S DIR("?")="Enter the number associated with the order. "
  1.  . S DIR("??")="^D ^LROS"
  1.  . S DIR("S")="I $O(^LRO(69,""C"",X,0))"
  1.  . D ^DIR
  1.  G END:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  S LRORD=X
  1.  W @IOF D LOOK G FIND
  1.  Q
  1. LOOK ;
  1.  S LRCNT=0,LRODT=$O(^LRO(69,"C",LRORD,0)) I LRODT<1 W !,"Not found." Q
  1.  S (LRCANK,LROV,LRSN,LRCOL)=0
  1.  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
  1.  . ; I $L($P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)),'$D(LRLABKY) S LRCOL=1
  1.  . I $L($P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)) S LRCOL=1     ; IHS/OIT/MKK - LR*5.2*1033
  1.  . L +^LRO(69,"C",+LRORD):1 I '$T W !?5,"Someone Else is Editing this order, try later",! S LREND=1 Q
  1.  . 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
  1.  I $G(LREND) D UNL69,END Q
  1.  I LRCNT<1 W !,"No order found with that number." D UNL69,END Q
  1.  I 'LRCANK W !!,"[ * All tests on this order # have already been dispositoned. * ]" D NAME Q
  1.  I $G(LRCOL) D  D UNL69,END Q
  1.  . W !!?5," You CAN NOT change the status of test(s) on this order."
  1.  . W !,"Test sample(s) have already been received into the laboratory."
  1.  . ; W !,"You must CONTACT the Laboratory to have test(s) status changed.",$C(7)
  1.  . W !,"You must use the REMOVE AN ACCESSION option to have the test(s) status changed.",$C(7)
  1.  D NAME
  1.  S LRNOP=0 I 'LROV F I=0:0 W !,"Change entire order" S %=2 D YN^DICN Q:%  W "Answer 'Y'es or 'N'o."
  1.  I 'LROV G END:%=-1,OUT:%=1
  1.  S LRT=0,J=0 F  S J=$O(LRT(J)) Q:J<1  S LRT=J
  1.  I LRT<1 W !,$$CJ^XLFSTR(" Can't change status of test(s) on this order.",IOM),! D UNL69 Q
  1. MORE W !,?8,"entry",?15,"test",?40,"sample"
  1.  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)
  1.  I LRT=0 W !,"All have been dispositioned from that order." Q
  1. ONE R !,"Change status of which entry: ",LRJ:DTIME W:LRJ["?" !,"Pick one of the following entries:" G MORE:LRJ["?" Q:LRJ["^"!(LRJ="")
  1.  I LRJ'=+LRJ!(LRJ<1)!(LRJ>LRT) W !,"Enter a number between 1 and ",LRT,! G ONE
  1.  I '$D(LRT(LRJ)) W !,"You've already dispositioned that one.",! G MORE
  1.  K LRNATURE
  1.  D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
  1.  K LRTSTI,LRMSTATI D EN1,UNL69 G LOOK
  1.  Q
  1. EN1 S LREND=0,LRSN=+LRT(LRJ),LRTSTI=+$P(LRT(LRJ),U,2),LRTSTS=+$P(LRT(LRJ),U,3)
  1.  I '$D(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0))#2 W !,"Does not exist ",! Q
  1.  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)
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  S LRTNM=$P($G(^LAB(60,LRTSTS,0)),U)
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  ;D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),"TESTS")
  1.  ;----- END IHS MODIFICATION
  1.  I '$L($G(LRNATURE)) D DC^LROR6() I $G(LRNATURE)=-1 W !!,$C(7),"NOTHING CHANGED" Q
  1.  S LRIDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  I LRIDT L +^LR(LRDFN,LRSS,LRIDT):1 I '$T W !?5,"Someone else is editing this entry",! S LREND=1 Q
  1.  D SET^LRTSTOUT I LRIDT L -^LR(LRDFN,LRSS,LRIDT)
  1.  D UNL69
  1.  Q
  1.  D CEN1^LRCENDE1 K LRONE Q:LRACC&'$D(^XUSEC("LRLAB",DUZ))
  1.  I LRTSTI,'$G(LRNOP) D
  1.  . N LRI S LRI(LRTSN)=""
  1.  . D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.LRI,$G(LRMSTATI))
  1.  . S $P(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ K T(LRJ)
  1.  . S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=LRTSTI,DA(1)=LRODT,DR=99 D ^DIE
  1.  K LRI
  1.  S X=DUZ D DUZ^LRX
  1.  ;I 'LRNOP S DIE="^LRO(69,LRODT,1,",DA=LRSN,DR="16" D ^DIE
  1.  W:'LRNOP !!,"Status changed to Not Performed" G FIND:$O(LRT(0))<1,ONE
  1. OUT Q:$G(LRNOP)  S LRJ=0
  1.  D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
  1.  S LRCCOMX=LRCCOM
  1.  S LRJ=0 F  S LRJ=$O(LRT(LRJ)) Q:LRJ<1  S LRCCOM=LRCCOMX D EN1
  1.  K LRCCOMX D UNL69
  1.  Q
  1.  S LRSN=0 F  S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1  D
  1.  . 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)
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1. ALLDEL ;D:BLRLOG ^BLRSLTL("M","D",$G(BLROPT),"ORDER")   ;IHS/OIRM TUC/AAB 11/14/96
  1.  ;D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),"ORDER")
  1.  ;-----END IHS MODIFICATION
  1.  K LRNATURE G FIND
  1. % ; EP
  1.  ; R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
  1.  K DIR,X,Y,%
  1.  S DIR(0)="YO"
  1.  D ^DIR
  1.  S %=$E(X)
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1033
  1.  Q
  1. UNL69 ;
  1.  L -^LRO(69,"C",+LRORD)
  1.  Q
  1. NAME ;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,SSN
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  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  ;IHS/ANMC/CLS 08/18/96
  1.  ;----- END IHS MODIFICATION
  1. EN ;from LRPHITE3
  1.  K LRT S (J,LRSN,LRNOP)=0 F  S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1!($G(LRNOP))  D TSET
  1.  Q
  1. TSET I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) D  Q
  1.  . W !,$$CJ^XLFSTR("Test(s) already verified for this order, cannot change ENTIRE order",IOM)
  1.  . W !,$$CJ^XLFSTR(" You must select individual test using the 'Delete Test from Accession' option.",IOM),!!
  1.  . D UNL69 S LRNOP=1
  1.  S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1  S X=^(I,0) D
  1.  . Q:$P(X,"^",11)
  1.  . I $P(X,U,3),'$D(LRLABKY) Q
  1.  . 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)
  1.  Q
  1. END K %,A,AGE,DFN,DIC,DIE,DOB,DQ,DR,DWLW,I,J,K,LRAA,LRACC,LRACN0,LRAD,LRAN,LRCL,LRCNT,LRCOL,LRDOC,LRDPF,LRDTM,LREND,LRIDT
  1.  K LRNOW,LRLL,LRLLOC,LRNOP,LROD0,LROD1,LROD3,LRODT,LROOS,LRORD,LROS,LROSD,LROT,LROV,LRROD
  1.  ;K LRSCNXB,LRSN,LRSPEC,LRSS,LRTC,LRTP,LRTSTS,LRT,LRTT,LRURG,LRUSI,LRUSNM,LRWRD,PNM,SEX,SSN,T,X,X1,X2,X3,X4,Y,Z,LRNATURE,ORIFN
  1.  ;-----BEGIN IHS MODIFICATION LR*5.2*1018
  1.  K LRSCNXB,LRSN,LRSPEC,LRSS,LRTC,LRTP,LRTSTS,LRT,LRTT,LRURG,LRUSI,LRUSNM,LRWRD,PNM,SEX,SSN,HRCN,T,X,X1,X2,X3,X4,Y,Z,LRNATURE,ORIFN
  1.  ;-----END IHS MODIFICATION
  1.  K LRCANK,LRTN,LRCCOM,LRCCOM1 D END^LRTSTOUT
  1.  K LRACN,LRJ,LRTSTI
  1.  Q