LRORD1GU ;VA/DALOI/RWF - LAZY ACCESSION LOGGING ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**1027**;NOV 01, 1997
;;
; Cloned from LEDI III LRORD1 routine. Next two lines VA code
LRORD1 ;DALOI/RWF - LAZY ACCESSION LOGGING ; Feb 20, 2004
;;5.2;LAB SERVICE;**1,8,121,153,201,286,1027**;Sep 27, 1994
;;
; This code was removed from the previous IHS version of the LRORD1 routine
; and placed in this new routine due to the changes to the LRORD1 routine
; brought in with VA LR*5.2*286 --LEDI III.
;
; It was felt that the PATIENT CHART coding was overwhelming the logic
; flow of the LRORD1 routine.
;
; This code is invoked ONLY when BLRGUI=1. No need to check for that.
; All code that was skipped when BLRGUI=1 has been removed.
;
L2 ; EP ;
K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
S LRWPC=LRWP G:$D(LROR) LRFIRST
;
S LRDPF="2^DPT(",PNM=^DPT(DFN,0),SSN=$P(PNM,U,9),PNM=$P(PNM,U)
S HRCN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
S X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")",LRDFN=+$S($D(@X):@X,1:-1) G E3:LRDFN>0
L ^LR(0):1 S LRDFN=$P(^LR(0),"^",3)+1
E2 I $D(^LR(LRDFN)) S LRDFN=LRDFN+1 G E2
S ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN,@X=LRDFN,^(0)=$P(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$P(^(0),"^",4)),^LR("B",LRDFN,LRDFN)=""
L
E3 I LRDFN>0,$P(^LR(LRDFN,0),"^",2)'=+LRDPF!($P(^(0),"^",3)'=DFN) S RESULT(1)=-1,RESULT(2)="Database degradation on "_PNM_". Contact site manager." Q
BPC I LRDFN<1 S RESULT(1)=-1,RESULT(2)="No Lab LRDFN Defined" Q
S LRDPF=$P(^LR(LRDFN,0),U,2)
Q:$G(RESULT(1))=-1
;
Q12 ;
S LRLLOC=$P(BPCPARAM,";",5),LROLLOC=""
S Y=0,Y=$O(^SC("B",LRLLOC,Y))
;
; IHS/ITSC/TPF 12/19/02 **1015** PER F.J. EVANS fix for Fort Thompson not
; printing Verified results to the ward when using the Patient Chart
I Y S LROLLOC=Y,LRLLOC=$S($L($P($G(^SC(Y,0)),U,2)):$P(^(0),U,2),1:LRLLOC)
;
Q11 ;
S (LRPRAC,^LR(LRDFN,.2))=BLRPRAC ;IHS/ITSC/IHS 10/9/02 PATIENT CHART FIX **1014**
K T,TT,LRDMAX,LRDTST,LRTMAX
S DA=0
F S DA=$O(^LRO(69,LRODT,1,"AA",LRDFN,DA)) Q:DA<1 D
. I $S($D(^LRO(69,LRODT,1,DA,1)):$P(^LRO(69,LRODT,1,DA,1),U,4)'="U",1:1) D
.. S S=+$G(^LRO(69,LRODT,1,DA,4,1,0))
.. S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:+I<1 D
... S X=+^LRO(69,LRODT,1,DA,2,I,0),T(X,DA)=S
... 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)
;
Q13 S LREDO=0
LEDI ;
;
G:LRWP'>1 Q13A
S LRSX=BPCTL
F I=1:1 S LRSSX=$P(LRSX,",",I),LRSSX=$P(LRSSX,"*") Q:$P(LRSX,",",I,99)="" S LREDO=$S($L(LRSSX)>31:1,1:(+(LRSSX\1)'=LRSSX)!(LRSSX<1)!(LRSSX>LRWP)) Q:LREDO
;
Q13A ;
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
;
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:LRECT LRORDTIM="08"
D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
S LRIDT=9999999-LRCDT
D ^LRORDST Q:$D(LROR)
S RESULT(1)=1,RESULT(2)="Order: "_LRORD_" "_$G(BPCACC)
Q
;
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
;
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)
D URG^LRORD2
Q
;
;
DROP Q:$D(LROR) G L2 ; !($G(LREND)) G L2
;
;
MICRO ; EP
Q:$D(LRFLOG) ;IHS/ITSC/TPF 08/02/01 ;ACCESSION TEST GROUP ALREADY CHOSEN
D GSNO^LRORD3 Q:$D(DUOUT)!$D(DTOUT)
S LRSAMP=1,LRSPEC=1
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
LRORD1GU ;VA/DALOI/RWF - LAZY ACCESSION LOGGING ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**1027**;NOV 01, 1997
+2 ;;
+3 ; Cloned from LEDI III LRORD1 routine. Next two lines VA code
LRORD1 ;DALOI/RWF - LAZY ACCESSION LOGGING ; Feb 20, 2004
+1 ;;5.2;LAB SERVICE;**1,8,121,153,201,286,1027**;Sep 27, 1994
+2 ;;
+3 ; This code was removed from the previous IHS version of the LRORD1 routine
+4 ; and placed in this new routine due to the changes to the LRORD1 routine
+5 ; brought in with VA LR*5.2*286 --LEDI III.
+6 ;
+7 ; It was felt that the PATIENT CHART coding was overwhelming the logic
+8 ; flow of the LRORD1 routine.
+9 ;
+10 ; This code is invoked ONLY when BLRGUI=1. No need to check for that.
+11 ; All code that was skipped when BLRGUI=1 has been removed.
+12 ;
L2 ; EP ;
+1 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LR696IEN,LRNATURE
+2 SET LRWPC=LRWP
IF $DATA(LROR)
GOTO LRFIRST
+3 ;
+4 SET LRDPF="2^DPT("
SET PNM=^DPT(DFN,0)
SET SSN=$PIECE(PNM,U,9)
SET PNM=$PIECE(PNM,U)
+5 SET HRCN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
+6 SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
SET LRDFN=+$SELECT($DATA(@X):@X,1:-1)
IF LRDFN>0
GOTO E3
+7 LOCK ^LR(0):1
SET LRDFN=$PIECE(^LR(0),"^",3)+1
E2 IF $DATA(^LR(LRDFN))
SET LRDFN=LRDFN+1
GOTO E2
+1 SET ^LR(LRDFN,0)=LRDFN_"^"_+LRDPF_"^"_DFN
SET @X=LRDFN
SET ^(0)=$PIECE(^LR(0),"^",1,2)_"^"_LRDFN_"^"_(1+$PIECE(^(0),"^",4))
SET ^LR("B",LRDFN,LRDFN)=""
+2 LOCK
E3 IF LRDFN>0
IF $PIECE(^LR(LRDFN,0),"^",2)'=+LRDPF!($PIECE(^(0),"^",3)'=DFN)
SET RESULT(1)=-1
SET RESULT(2)="Database degradation on "_PNM_". Contact site manager."
QUIT
BPC IF LRDFN<1
SET RESULT(1)=-1
SET RESULT(2)="No Lab LRDFN Defined"
QUIT
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
+2 IF $GET(RESULT(1))=-1
QUIT
+3 ;
Q12 ;
+1 SET LRLLOC=$PIECE(BPCPARAM,";",5)
SET LROLLOC=""
+2 SET Y=0
SET Y=$ORDER(^SC("B",LRLLOC,Y))
+3 ;
+4 ; IHS/ITSC/TPF 12/19/02 **1015** PER F.J. EVANS fix for Fort Thompson not
+5 ; printing Verified results to the ward when using the Patient Chart
+6 IF Y
SET LROLLOC=Y
SET LRLLOC=$SELECT($LENGTH($PIECE($GET(^SC(Y,0)),U,2)):$PIECE(^(0),U,2),1:LRLLOC)
+7 ;
Q11 ;
+1 ;IHS/ITSC/IHS 10/9/02 PATIENT CHART FIX **1014**
SET (LRPRAC,^LR(LRDFN,.2))=BLRPRAC
+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
Begin DoDot:1
+5 IF $SELECT($DATA(^LRO(69,LRODT,1,DA,1)):$PIECE(^LRO(69,LRODT,1,DA,1),U,4)'="U",1:1)
Begin DoDot:2
+6 SET S=+$GET(^LRO(69,LRODT,1,DA,4,1,0))
+7 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,DA,2,I))
IF +I<1
QUIT
Begin DoDot:3
+8 SET X=+^LRO(69,LRODT,1,DA,2,I,0)
SET T(X,DA)=S
+9 IF '$DATA(TT(X,S))
SET TT(X,S)=0
SET TT(X,S)=TT(X,S)+1
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 KILL DIC
+12 IF $DATA(LRADDTST)
SET LRORD=+LRADDTST
SET LRADDTST=""
GOTO LRFIRST
+13 DO ORDER^LROW2
+14 IF $DATA(LRFLOG)
IF $PIECE(LRFLOG,U,3)="MI"
IF $GET(LRORDRR)'="R"
KILL DUOUT
DO MICRO
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO L2
+15 ;
LRFIRST SET LRSX=1
IF 'LRFIRST!(LRWP<2)
GOTO Q13
+1 ;
Q13 SET LREDO=0
LEDI ;
+1 ;
+2 IF LRWP'>1
GOTO Q13A
+3 SET LRSX=BPCTL
+4 FOR I=1:1
SET LRSSX=$PIECE(LRSX,",",I)
SET LRSSX=$PIECE(LRSSX,"*")
IF $PIECE(LRSX,",",I,99)=""
QUIT
SET LREDO=$SELECT($LENGTH(LRSSX)>31:1,1:(+(LRSSX\1)'=LRSSX)!(LRSSX<1)!(LRSSX>LRWP))
IF LREDO
QUIT
+5 ;
Q13A ;
+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
+7 ;
BAR SET LRM=LRWPC+1
SET K=0
+1 ;
LRM ; D MORE^LRORD2
+1 ;
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 IF LRECT
SET LRORDTIM="08"
+2 DO NOW^%DTC
SET LRNT=%
IF 'LRECT
SET LRCDT=LRNT_"^1"
+3 SET LRIDT=9999999-LRCDT
+4 DO ^LRORDST
IF $DATA(LROR)
QUIT
+5 SET RESULT(1)=1
SET RESULT(2)="Order: "_LRORD_" "_$GET(BPCACC)
+6 QUIT
+7 ;
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 ;
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 DO URG^LRORD2
+2 QUIT
+3 ;
+4 ;
DROP ; !($G(LREND)) G L2
IF $DATA(LROR)
QUIT
GOTO L2
+1 ;
+2 ;
MICRO ; EP
+1 ;IHS/ITSC/TPF 08/02/01 ;ACCESSION TEST GROUP ALREADY CHOSEN
IF $DATA(LRFLOG)
QUIT
+2 DO GSNO^LRORD3
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 SET LRSAMP=1
SET LRSPEC=1
+4 IF +LRSAMP=-1&(LRSPEC=-1)
WRITE !,"Incompletely defined."
GOTO MICRO
+5 SET LRSAME=LRSAMP_U_LRSPEC
+6 SET LRECOM=0
DO GCOM^LRORD2
+7 QUIT
+8 ;
+9 ;
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
