LRORD1 ;DALOI/CJS/JAH - LAZY ACCESSION LOGGING ;8/10/04
;;5.2;LAB SERVICE;**1003,1004,1006,1009,1010,1011,1013,1014,1015,1021,1027,1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 1,8,121,153,201,286,291
;
L2 ; EP
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 ; EP
D LOC^LRWU G DROP:LREND
Q11 ; EP
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 ; EP
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 ; EP
;
; 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 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")
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
D Q14A
D ENSTIK^LROW3 ; IHS/MSC/MKK - LR*5.2*1031
G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U
K DIC
G DROP:'$D(LROT)!(%["N")
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
;
S LRBEY=1 I +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)
;
D ASKATORD^BLRAAORU(LRORD) ; IHS/OIT/MKK - LR*5.2*1030
;
I $D(LRFASTS) D LRWU4^LRFASTS
;
; --- BEGIN IHS MODIFICATION cmi/anch/maw REF LAB -- LR*5.2*1021
I '$G(BLRGUI),$G(^BLRSITE(DUZ(2),"RL")),'$P($G(^BLRSITE(DUZ(2),"RL")),U,22) D BLRRL^LROE ;cmi/flag/maw 7/28/03 for reference lab shipping manifest 6/22/10 added check of LEDI
;--- END IHS MODIFICATION cmi/anch/maw end REF LAB -- LR*5.2*1021
;
Q:$G(LRKIK) G L2
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
; Being done because the % variable is being reset somewhere
Q14A ; EP
NEW %ORIGQ14
S %ORIGQ14=$G(%) ; Save off original % variable
;
NEW %
S %=$G(%ORIGQ14) ; Done in case the other routines need the % variable to be set
D:$P(LRPARAM,U,17) ^LRORDD
D ^LRORD2A
; D ENSTIK^LROW3 ; IHS/MSC/MKK - LR*5.2*1031 -- Don't call ENSTIK^LROW3 here
;
Q
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
Q20A ;from LRORD2
MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
I $D(TT(LRTSTS,LRSPEC)),$D(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN))) D EN2^LRORDD I %'["Y" Q
S I7=0 F I9=0:0 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 W $C(7),!!,"You have a duplicate: " S LRSN=0 F S LRSN=$O(T(LRTSTS,LRSN)) Q:LRSN<1 W " for ",$P(^LAB(60,LRTSTS,0),U) S LRZT=LRTSTS D ORDER^LROS S LRTSTS=LRZT
I I7 W !,"You already have that test, do you really want another? N//" D %
Q
;
URGG ; W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
W:'$G(BLRGUI) !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2) ; IHS/OIT/MKK - LR*5.2*1027
D URG^LRORD2
Q
;
;
DROP W !!,"ORDER CANCELED",$C(7),!! Q:$D(LROR) G L2 ; !($G(LREND)) G L2
;
;
MICRO ; EP
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
LRORD1 ;DALOI/CJS/JAH - LAZY ACCESSION LOGGING ;8/10/04
+1 ;;5.2;LAB SERVICE;**1003,1004,1006,1009,1010,1011,1013,1014,1015,1021,1027,1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 1,8,121,153,201,286,291
+4 ;
L2 ; EP
+1 IF $GET(LREND)
QUIT
+2 ; CIDC
NEW LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
+3 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
+4 SET LRWPC=LRWP
IF $DATA(LROR)
GOTO LRFIRST
+5 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
+6 IF $DATA(LRADDTST)
IF LRADDTST=""
QUIT
+7 IF '$DATA(LREND)
SET LREND=0
IF LRORDR=""
DO COLTY^LRWU
IF LREND
GOTO DROP
+8 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
Q12 ; EP
+1 DO LOC^LRWU
IF LREND
GOTO DROP
Q11 ; EP
+1 DO PRAC^LRWU1
IF LREND
GOTO DROP
+2 KILL T,TT,LRDMAX,LRDTST,LRTMAX
+3 SET DA=0
+4 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
+5 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
+6 KILL DIC
+7 IF $DATA(LRADDTST)
SET LRORD=+LRADDTST
SET LRADDTST=""
GOTO LRFIRST
+8 DO ORDER^LROW2
+9 IF $DATA(LRFLOG)
IF $PIECE(LRFLOG,U,3)="MI"
IF $GET(LRORDRR)'="R"
KILL DUOUT
DO MICRO
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO L2
+10 ;
LRFIRST ; EP
+1 SET LRSX=1
IF 'LRFIRST!(LRWP<2)
GOTO Q13
+2 WRITE !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
+3 FOR I=1:1:LRWPD
Begin DoDot:1
+4 NEW X
+5 SET X=^TMP("LRSTIK",$JOB,"B",I)
+6 WRITE !,X,?4,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
+7 SET X=$GET(^TMP("LRSTIK",$JOB,"B",I+LRWPD))
+8 IF X
WRITE ?39," ",X,?44,$PIECE(^TMP("LRSTIK",$JOB,X),U,2)
End DoDot:1
Q13 SET LREDO=0
LEDI ; EP
+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 ;
+2 FOR LRK=1:1
SET LRSSX=$PIECE(LRSX,",",LRK)
IF LRSSX=""
QUIT
Begin DoDot:1
+3 NEW X
+4 SET LRST=$SELECT(LRSSX["*":1,1:0)
SET LRSSX=+LRSSX
+5 SET X=^TMP("LRSTIK",$JOB,LRSSX)
+6 SET LRSAMP=$PIECE(X,U,3)
SET LRSPEC=$PIECE(X,U,5)
SET LRTSTS=+X
+7 DO Q20^LRORDD
End DoDot:1
+8 ;
BAR SET LRM=LRWPC+1
SET K=0
WRITE !,"Other tests? N//"
DO %
IF '(%["Y")
GOTO Q14
+1 ;
LRM DO MORE^LRORD2
+1 ;
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")
+1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+2 DO Q14A
+3 ; IHS/MSC/MKK - LR*5.2*1031
DO ENSTIK^LROW3
+4 IF '$DATA(%)&($DATA(LROT)'=11)
GOTO LRM
IF $ORDER(LROT(-1))=""
GOTO DROP
IF '$DATA(%)
GOTO LRM
IF %[U
GOTO DROP
+5 KILL DIC
+6 IF '$DATA(LROT)!(%["N")
GOTO DROP
+7 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+8 ;
+9 ;
+10 SET LRBEY=1
IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+11 ; CIDC
DO BALROR^LRBEBA3(.LRORD)
End DoDot:1
IF 'LRBEY
GOTO DROP
+12 IF ($DATA(LRBEY)<1)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+13 ;
+14 WRITE !!,"LAB Order number: ",LRORD,!!
+15 IF LRECT
Begin DoDot:1
+16 IF $GET(LRORDRR)="R"
IF $GET(LRSD("CDT"))
Begin DoDot:2
+17 SET LRCDT=LRSD("CDT")_"^"
+18 SET LRORDTIM=$PIECE(LRSD("CDT"),".",2)
+19 IF 'LRORDTIM
SET $PIECE(LRCDT,"^",2)=1
End DoDot:2
QUIT
+20 DO TIME^LROE
+21 IF $GET(LRCDT)<1
QUIT
+22 SET LRORDTIM=$PIECE($PIECE(LRCDT,U),".",2)
End DoDot:1
IF LRCDT<1
GOTO DROP
+23 DO NOW^%DTC
SET LRNT=%
IF 'LRECT
SET LRCDT=LRNT_"^1"
+24 SET LRIDT=9999999-LRCDT
+25 DO ^LRORDST
IF $DATA(LROR)
QUIT
+26 ;
+27 ; IHS/OIT/MKK - LR*5.2*1030
DO ASKATORD^BLRAAORU(LRORD)
+28 ;
+29 IF $DATA(LRFASTS)
DO LRWU4^LRFASTS
+30 ;
+31 ; --- BEGIN IHS MODIFICATION cmi/anch/maw REF LAB -- LR*5.2*1021
+32 ;cmi/flag/maw 7/28/03 for reference lab shipping manifest 6/22/10 added check of LEDI
IF '$GET(BLRGUI)
IF $GET(^BLRSITE(DUZ(2),"RL"))
IF '$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,22)
DO BLRRL^LROE
+33 ;--- END IHS MODIFICATION cmi/anch/maw end REF LAB -- LR*5.2*1021
+34 ;
+35 IF $GET(LRKIK)
QUIT
GOTO L2
+36 ;
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 ;
+2 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+3 ; Being done because the % variable is being reset somewhere
Q14A ; EP
+1 NEW %ORIGQ14
+2 ; Save off original % variable
SET %ORIGQ14=$GET(%)
+3 ;
+4 NEW %
+5 ; Done in case the other routines need the % variable to be set
SET %=$GET(%ORIGQ14)
+6 IF $PIECE(LRPARAM,U,17)
DO ^LRORDD
+7 DO ^LRORD2A
+8 ; D ENSTIK^LROW3 ; IHS/MSC/MKK - LR*5.2*1031 -- Don't call ENSTIK^LROW3 here
+9 ;
+10 QUIT
+11 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+12 ;
Q20A ;from LRORD2
MAX ; CHECK FOR MAXIUM ORDER FREQUENCY
+1 IF $DATA(TT(LRTSTS,LRSPEC))
IF $DATA(^LAB(60,LRTSTS,3,"B",LRCS(LRCSN)))
DO EN2^LRORDD
IF %'["Y"
QUIT
+2 SET I7=0
FOR I9=0:0
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
+3 IF I7
WRITE $CHAR(7),!!,"You have a duplicate: "
SET LRSN=0
FOR
SET LRSN=$ORDER(T(LRTSTS,LRSN))
IF LRSN<1
QUIT
WRITE " for ",$PIECE(^LAB(60,LRTSTS,0),U)
SET LRZT=LRTSTS
DO ORDER^LROS
SET LRTSTS=LRZT
+4 IF I7
WRITE !,"You already have that test, do you really want another? N//"
DO %
+5 QUIT
+6 ;
URGG ; W !,"For ",$P(^TMP("LRSTIK",$J,LRSSX),U,2)
+1 ; IHS/OIT/MKK - LR*5.2*1027
IF '$GET(BLRGUI)
WRITE !,"For ",$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,2)
+2 DO URG^LRORD2
+3 QUIT
+4 ;
+5 ;
DROP ; !($G(LREND)) G L2
WRITE !!,"ORDER CANCELED",$CHAR(7),!!
IF $DATA(LROR)
QUIT
GOTO L2
+1 ;
+2 ;
MICRO ; EP
+1 WRITE !,"Is there one sample for this patient's order"
+2 SET %=1
DO YN^DICN
+3 IF %=2!(%=-1)
IF %=-1
SET DUOUT=1
QUIT
+4 IF %=0
WRITE !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient."
GOTO MICRO
+5 DO GSNO^LRORD3
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+6 IF +LRSAMP=-1&(LRSPEC=-1)
WRITE !,"Incompletely defined."
GOTO MICRO
+7 SET LRSAME=LRSAMP_U_LRSPEC
+8 SET LRECOM=0
DO GCOM^LRORD2
+9 QUIT
+10 ;
+11 ;
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
