LRORD1 ;DALOI/STAFF - LAZY ACCESSION LOGGING ;03/07/12 16:38
;;5.2;LAB SERVICE;**1,8,121,153,201,286,291,350**;Sep 27, 1994;Build 230
;
L2 Q:$G(LREND)
N LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP ; CIDC
K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
S LRWPC=LRWP G:$D(LROR) LRFIRST
I '$D(LRADDTST) K DFN,DIC S PNM="",DIC(0)="EMQ"_$S($P(LRPARAM,U,6)&$D(LRLABKY):"L",1:"") W ! D ^LRDPA I (LRDFN=-1)!$D(DUOUT)!$D(DTOUT) Q
I $D(LRADDTST),LRADDTST="" Q
S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
;
Q12 D LOC^LRWU G DROP:LREND
;
Q11 D PRAC^LRWU1 G DROP:LREND
K T,TT,LRDMAX,LRDTST,LRTMAX
S DA=0
F S DA=$O(^LRO(69,LRODT,1,"AA",LRDFN,DA)) Q:DA<1 I $S($D(^LRO(69,LRODT,1,DA,1)):$P(^(1),U,4)'="U",1:1) S S=$S($D(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0) D
. S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 I $D(^(I,0)) S T(+^(0),DA)=S,X=+^(0) S:'$D(TT(X,S)) TT(X,S)=0 S TT(X,S)=TT(X,S)+1
K DIC
I $D(LRADDTST) S LRORD=+LRADDTST,LRADDTST="" G LRFIRST
D ORDER^LROW2
I $D(LRFLOG),$P(LRFLOG,U,3)="MI",$G(LRORDRR)'="R" K DUOUT D MICRO G L2:$D(DUOUT)!$D(DTOUT)
;
LRFIRST S LRSX=1 G Q13:'LRFIRST!(LRWP<2)
W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
F I=1:1:LRWPD D
. N X
. S X=^TMP("LRSTIK",$J,"B",I)
. W !,X,?4,$P(^TMP("LRSTIK",$J,X),U,2)
. S X=$G(^TMP("LRSTIK",$J,"B",I+LRWPD))
. I X W ?39," ",X,?44,$P(^TMP("LRSTIK",$J,X),U,2)
Q13 S LREDO=0
;
LEDI ;
;
; If LEDI accessioning then check for pending orders in file #69.6
I $G(LRRSTAT)="I",$G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" D I $O(LROT(0)) G BAR
. D EN^LRORDB(LRSD("RUID"),LRRSITE("SMID"))
G:LRWP'>1 Q13A
W ! W:'LRFIRST "'?' for list, " S LRFIRST=0
R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
I LRSX=""!(LRSX["^") G BAR
F I=1:1:$L(LRSX,",") D Q:LREDO
. S LRSSX=$P(LRSX,",",I)
. I LRSSX'?1.3N.1"*" S LREDO=1 Q
. S LRSSX=$P(LRSSX,"*")
. I '$D(^TMP("LRSTIK",$J,LRSSX)) S LREDO=1
Q13A I LREDO W !,"Something was mistyped, try again." G Q13
F LRK=1:1 S LRSSX=$P(LRSX,",",LRK) Q:LRSSX="" D
. N X
. S LRST=$S(LRSSX["*":1,1:0),LRSSX=+LRSSX
. S X=^TMP("LRSTIK",$J,LRSSX)
. S LRSAMP=$P(X,U,3),LRSPEC=$P(X,U,5),LRTSTS=+X
. D Q20^LRORDD
BAR S LRM=LRWPC+1,K=0 G:$G(LRORDRR)="R" Q14 W !,"Other tests? N//" D % G Q14:'(%["Y")
LRM D MORE^LRORD2
Q14 D:$P(LRPARAM,U,17) ^LRORDD D ^LRORD2A D ENSTIK^LROW3 G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
S LRBEY=1 I $G(LRORDRR)'="R",+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D G DROP:'LRBEY
.D BALROR^LRBEBA3(.LRORD) ; CIDC
I ($D(LRBEY)<1)!$D(DUOUT)!$D(DTOUT) Q
W !!,"LAB Order number: ",LRORD,!!
I LRECT D G DROP:LRCDT<1
. I $G(LRORDRR)="R",$G(LRSD("CDT")) D Q
. . S LRCDT=LRSD("CDT")_"^"
. . S LRORDTIM=$P(LRSD("CDT"),".",2)
. . I 'LRORDTIM S $P(LRCDT,"^",2)=1
. D TIME^LROE
. I $G(LRCDT)<1 Q
. S LRORDTIM=$P($P(LRCDT,U),".",2)
D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
S LRIDT=9999999-LRCDT
D ^LRORDST Q:$D(LROR)
I $D(LRFASTS) D LRWU4^LRFASTS
Q:$G(LRKIL) G L2
;
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
;
;
Q20A ;from LRORD2
MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
N I7,I9,LRSN
I $D(TT(LRTSTS,LRSPEC)),$D(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN))) D EN2^LRORDD I %'["Y" Q
S (I7,I9)=0
F S I9=$O(T(LRTSTS,I9)) Q:I9="" I $D(^LAB(60,LRTSTS,3,+$O(^LAB(60,LRTSTS,3,"B",LRSAMP,0)),0)),+$P(^(0),U,5),LRSPEC=T(LRTSTS,I9) S I7=1
I I7 D
. W $C(7),!!,"You have a duplicate: "
. S LRSN=0
. F S LRSN=$O(T(LRTSTS,LRSN)) Q:LRSN<1 D
. . W " for ",$P(^LAB(60,LRTSTS,0),U)
. . N LRTSTS D ORDER^LROS
. W !,"You already have that test, do you really want another? N//" D %
Q
;
;
URGG W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
D URG^LRORD2
Q
;
;
DROP W !!,"ORDER CANCELED",$C(7),!! Q:$D(LROR) G L2 ; !($G(LREND)) G L2
;
;
MICRO W !,"Is there one sample for this patient's order"
S %=1 D YN^DICN
I %=2!(%=-1) S:%=-1 DUOUT=1 Q
I %=0 W !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient." G MICRO
D GSNO^LRORD3 Q:$D(DUOUT)!$D(DTOUT)
I +LRSAMP=-1&(LRSPEC=-1) W !,"Incompletely defined." G MICRO
S LRSAME=LRSAMP_U_LRSPEC
S LRECOM=0 D GCOM^LRORD2
Q
;
;
PRAC ;from LRFAST
S X=$S(+DIC("B"):$P(^VA(200,+DIC("B"),0),U),1:"")
W !,"PRACTITIONER: ",X,$S($L(X):"//",1:"")
R X:DTIME
I DIC("B"),X="" S Y=DIC("B") Q
D ^DIC K DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRORD1 4604 printed Dec 13, 2024@02:18:50 Page 2
LRORD1 ;DALOI/STAFF - LAZY ACCESSION LOGGING ;03/07/12 16:38
+1 ;;5.2;LAB SERVICE;**1,8,121,153,201,286,291,350**;Sep 27, 1994;Build 230
+2 ;
L2 if $GET(LREND)
QUIT
+1 ; CIDC
NEW LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
+2 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
+3 SET LRWPC=LRWP
if $DATA(LROR)
GOTO LRFIRST
+4 IF '$DATA(LRADDTST)
KILL DFN,DIC
SET PNM=""
SET DIC(0)="EMQ"_$SELECT($PIECE(LRPARAM,U,6)&$DATA(LRLABKY):"L",1:"")
WRITE !
DO ^LRDPA
IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+5 IF $DATA(LRADDTST)
IF LRADDTST=""
QUIT
+6 if '$DATA(LREND)
SET LREND=0
IF LRORDR=""
DO COLTY^LRWU
if LREND
GOTO DROP
+7 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+8 ;
Q12 DO LOC^LRWU
if LREND
GOTO DROP
+1 ;
Q11 DO PRAC^LRWU1
if LREND
GOTO DROP
+1 KILL T,TT,LRDMAX,LRDTST,LRTMAX
+2 SET DA=0
+3 FOR
SET DA=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN,DA))
if DA<1
QUIT
IF $SELECT($DATA(^LRO(69,LRODT,1,DA,1)):$PIECE(^(1),U,4)'="U",1:1)
SET S=$SELECT($DATA(^LRO(69,LRODT,1,DA,4,1,0)):+^(0),1:0)
Begin DoDot:1
+4 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,DA,2,I))
if I<1
QUIT
IF $DATA(^(I,0))
SET T(+^(0),DA)=S
SET X=+^(0)
if '$DATA(TT(X,S))
SET TT(X,S)=0
SET TT(X,S)=TT(X,S)+1
End DoDot:1
+5 KILL DIC
+6 IF $DATA(LRADDTST)
SET LRORD=+LRADDTST
SET LRADDTST=""
GOTO LRFIRST
+7 DO ORDER^LROW2
+8 IF $DATA(LRFLOG)
IF $PIECE(LRFLOG,U,3)="MI"
IF $GET(LRORDRR)'="R"
KILL DUOUT
DO MICRO
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO L2
+9 ;
LRFIRST SET LRSX=1
if 'LRFIRST!(LRWP<2)
GOTO Q13
+1 WRITE !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
+2 FOR I=1:1:LRWPD
Begin DoDot:1
+3 NEW X
+4 SET X=^TMP("LRSTIK",$JOB,"B",I)
+5 WRITE !,X,?4,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
+6 SET X=$GET(^TMP("LRSTIK",$JOB,"B",I+LRWPD))
+7 IF X
WRITE ?39," ",X,?44,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
End DoDot:1
Q13 SET LREDO=0
+1 ;
LEDI ;
+1 ;
+2 ; If LEDI accessioning then check for pending orders in file #69.6
+3 IF $GET(LRRSTAT)="I"
IF $GET(LRRSITE("SMID"))'=""
IF $GET(LRSD("RUID"))'=""
Begin DoDot:1
+4 DO EN^LRORDB(LRSD("RUID"),LRRSITE("SMID"))
End DoDot:1
IF $ORDER(LROT(0))
GOTO BAR
+5 if LRWP'>1
GOTO Q13A
+6 WRITE !
if 'LRFIRST
WRITE "'?' for list, "
SET LRFIRST=0
+7 READ "TEST number(s): ",LRSX:DTIME
if LRSX["?"
SET LRFIRST=1
if LRFIRST
GOTO LRFIRST
+8 IF LRSX=""!(LRSX["^")
GOTO BAR
+9 FOR I=1:1:$LENGTH(LRSX,",")
Begin DoDot:1
+10 SET LRSSX=$PIECE(LRSX,",",I)
+11 IF LRSSX'?1.3N.1"*"
SET LREDO=1
QUIT
+12 SET LRSSX=$PIECE(LRSSX,"*")
+13 IF '$DATA(^TMP("LRSTIK",$JOB,LRSSX))
SET LREDO=1
End DoDot:1
if LREDO
QUIT
Q13A IF LREDO
WRITE !,"Something was mistyped, try again."
GOTO Q13
+1 FOR LRK=1:1
SET LRSSX=$PIECE(LRSX,",",LRK)
if LRSSX=""
QUIT
Begin DoDot:1
+2 NEW X
+3 SET LRST=$SELECT(LRSSX["*":1,1:0)
SET LRSSX=+LRSSX
+4 SET X=^TMP("LRSTIK",$JOB,LRSSX)
+5 SET LRSAMP=$PIECE(X,U,3)
SET LRSPEC=$PIECE(X,U,5)
SET LRTSTS=+X
+6 DO Q20^LRORDD
End DoDot:1
BAR SET LRM=LRWPC+1
SET K=0
if $GET(LRORDRR)="R"
GOTO Q14
WRITE !,"Other tests? N//"
DO %
if '(%["Y")
GOTO Q14
LRM DO MORE^LRORD2
Q14 if $PIECE(LRPARAM,U,17)
DO ^LRORDD
DO ^LRORD2A
DO ENSTIK^LROW3
if '$DATA(%)&($DATA(LROT)'=11)
GOTO LRM
if $ORDER(LROT(-1))=""
GOTO DROP
if '$DATA(%)
GOTO LRM
if %[U
GOTO DROP
KILL DIC
if '$DATA(LROT)!(%["N")
GOTO DROP
+1 SET LRBEY=1
IF $GET(LRORDRR)'="R"
IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+2 ; CIDC
DO BALROR^LRBEBA3(.LRORD)
End DoDot:1
if 'LRBEY
GOTO DROP
+3 IF ($DATA(LRBEY)<1)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+4 WRITE !!,"LAB Order number: ",LRORD,!!
+5 IF LRECT
Begin DoDot:1
+6 IF $GET(LRORDRR)="R"
IF $GET(LRSD("CDT"))
Begin DoDot:2
+7 SET LRCDT=LRSD("CDT")_"^"
+8 SET LRORDTIM=$PIECE(LRSD("CDT"),".",2)
+9 IF 'LRORDTIM
SET $PIECE(LRCDT,"^",2)=1
End DoDot:2
QUIT
+10 DO TIME^LROE
+11 IF $GET(LRCDT)<1
QUIT
+12 SET LRORDTIM=$PIECE($PIECE(LRCDT,U),".",2)
End DoDot:1
if LRCDT<1
GOTO DROP
+13 DO NOW^%DTC
SET LRNT=%
if 'LRECT
SET LRCDT=LRNT_"^1"
+14 SET LRIDT=9999999-LRCDT
+15 DO ^LRORDST
if $DATA(LROR)
QUIT
+16 IF $DATA(LRFASTS)
DO LRWU4^LRFASTS
+17 if $GET(LRKIL)
QUIT
GOTO L2
+18 ;
+19 ;
% READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 ;
+2 ;
Q20A ;from LRORD2
MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
+1 NEW I7,I9,LRSN
+2 IF $DATA(TT(LRTSTS,LRSPEC))
IF $DATA(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN)))
DO EN2^LRORDD
IF %'["Y"
QUIT
+3 SET (I7,I9)=0
+4 FOR
SET I9=$ORDER(T(LRTSTS,I9))
if I9=""
QUIT
IF $DATA(^LAB(60,LRTSTS,3,+$ORDER(^LAB(60,LRTSTS,3,"B",LRSAMP,0)),0))
IF +$PIECE(^(0),U,5)
IF LRSPEC=T(LRTSTS,I9)
SET I7=1
+5 IF I7
Begin DoDot:1
+6 WRITE $CHAR(7),!!,"You have a duplicate: "
+7 SET LRSN=0
+8 FOR
SET LRSN=$ORDER(T(LRTSTS,LRSN))
if LRSN<1
QUIT
Begin DoDot:2
+9 WRITE " for ",$PIECE(^LAB(60,LRTSTS,0),U)
+10 NEW LRTSTS
DO ORDER^LROS
End DoDot:2
+11 WRITE !,"You already have that test, do you really want another? N//"
DO %
End DoDot:1
+12 QUIT
+13 ;
+14 ;
URGG WRITE !,"For ",$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,2)
+1 DO URG^LRORD2
+2 QUIT
+3 ;
+4 ;
DROP ; !($G(LREND)) G L2
WRITE !!,"ORDER CANCELED",$CHAR(7),!!
if $DATA(LROR)
QUIT
GOTO L2
+1 ;
+2 ;
MICRO WRITE !,"Is there one sample for this patient's order"
+1 SET %=1
DO YN^DICN
+2 IF %=2!(%=-1)
if %=-1
SET DUOUT=1
QUIT
+3 IF %=0
WRITE !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient."
GOTO MICRO
+4 DO GSNO^LRORD3
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+5 IF +LRSAMP=-1&(LRSPEC=-1)
WRITE !,"Incompletely defined."
GOTO MICRO
+6 SET LRSAME=LRSAMP_U_LRSPEC
+7 SET LRECOM=0
DO GCOM^LRORD2
+8 QUIT
+9 ;
+10 ;
PRAC ;from LRFAST
+1 SET X=$SELECT(+DIC("B"):$PIECE(^VA(200,+DIC("B"),0),U),1:"")
+2 WRITE !,"PRACTITIONER: ",X,$SELECT($LENGTH(X):"//",1:"")
+3 READ X:DTIME
+4 IF DIC("B")
IF X=""
SET Y=DIC("B")
QUIT
+5 DO ^DIC
KILL DIC
+6 QUIT
