BLRORD1 ;SLC/RWF/TPF - LAZY ACCESSION LOGGING ;8/11/97 [ 08/01/2002 8:20 AM ]
;;5.2;LR;**1,1013**;JUL 31, 1997
;;5.2;LAB SERVICE;**1,8,121**;Sep 27, 1994
L2 K LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LRNATURE
S LRWPC=LRWP G:$D(LROR) LRFIRST
; MJL 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
; MJL I $D(LRADDTST),LRADDTST="" Q
; MJL S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
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) 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)
Q12 ; MJL D LOC^LRWU G DROP:LREND
S LRLLOC=$P(BPCPARAM,";",5),LROLLOC="",LROLLOC=$O(^SC("C",LRLLOC,LROLLOC))
Q11 ; MJL D PRAC^LRWU1 G DROP:LREND
S (LRPRAC,^LR(LRDFN,.2))=DUZ
K T,TT,LRDMAX,LRDTST,LRTMAX
;FHL 7/31/97
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
; MJL 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) S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 S T(+^(I,0),DA)=S D EN^LRORDD
K DIC I $D(LRADDTST) S LRORD=+LRADDTST,LRADDTST="" G LRFIRST
D ORDER^BLROW2 I $D(LRFLOG),$P(LRFLOG,U,3)="MI" K DUOUT D MICRO G L2:$D(DUOUT)!$D(DTOUT)
LRFIRST S LRSX=1 G Q13:'LRFIRST!(LRWP<2) ; MJL W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
; MJL F I=1:1:LRWPD W !,I,?4,$P(LRSTIK(I),U,2) W:$D(LRSTIK(I+LRWPD)) ?39," ",I+LRWPD,?44,$P(LRSTIK(I+LRWPD),U,2)
Q13 S LREDO=0 G:LRWP'>1 Q13A
; MJL W ! W:'LRFIRST "'?' for list, " S LRFIRST=0 R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
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 ; MJL I LREDO W !,"Something was mistyped, try again." G Q13
F LRK=1:1 S LRSSX=$P(LRSX,",",LRK) Q:LRSSX="" S LRST=$S(LRSSX["*":1,1:0),LRSSX=+LRSSX,LRSAMP=$P(LRSTIK(LRSSX),U,3),LRSPEC=$P(LRSTIK(LRSSX),U,5),LRTSTS=+LRSTIK(LRSSX) D Q20^BLRORDD
S LRM=LRWPC+1,K=0 ; MJL W !,"Other tests? N//" D % G Q14:'(%["Y")
LRM ; MJL D MORE^LRORD2
Q14 ;FHL D:$P(LRPARAM,U,17) ^BLRORDD G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
D:$P(LRPARAM,U,17) ^BLRORDD
; MJL 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")
; MJL W !!,"LAB Order number: ",LRORD,!!
; MJL I LRECT D TIME^LROE G DROP:LRCDT<1 S LRORDTIM=$P(Y,".",2)
S:LRECT LRORDTIM="08"
D NOW^%DTC S LRNT=% S:'LRECT LRCDT=LRNT_"^1"
S LRIDT=9999999-LRCDT
D ^BLRORDST Q:$D(LROR)
S RESULT(1)=1,RESULT(2)="Order: "_LRORD_" "_$G(BPCACC) Q
; MJL I $D(LRFASTS) D LRWU4^LRFASTS
; MJL D:BLRLOG ^BLRSLTL("C","O",$G(BLROPT)) ;IHS/OIRM TUC/AAB 11/14/96
Q:$G(LRKIK) G L2
% 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(LRSTIK(LRSSX),U,2) D URG^LRORD2 Q
DROP G L2 ;FHL 1/8/98 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
BLRORD1 ;SLC/RWF/TPF - LAZY ACCESSION LOGGING ;8/11/97 [ 08/01/2002 8:20 AM ]
+1 ;;5.2;LR;**1,1013**;JUL 31, 1997
+2 ;;5.2;LAB SERVICE;**1,8,121**;Sep 27, 1994
L2 KILL LROT,LRSAME,LRKIL,LRGCOM,LRCCOM,LRNATURE
+1 SET LRWPC=LRWP
IF $DATA(LROR)
GOTO LRFIRST
+2 ; MJL 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
+3 ; MJL I $D(LRADDTST),LRADDTST="" Q
+4 ; MJL S:'$D(LREND) LREND=0 I LRORDR="" D COLTY^LRWU G DROP:LREND
+5 SET LRDPF="2^DPT("
SET PNM=^DPT(DFN,0)
SET SSN=$PIECE(PNM,U,9)
SET PNM=$PIECE(PNM,U)
+6 SET HRCN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0),"^?"),U,2)
+7 SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
SET LRDFN=+$SELECT($DATA(@X):@X,1:-1)
IF LRDFN>0
GOTO E3
+8 LOCK ^LR(0)
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)=""
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)
Q12 ; MJL D LOC^LRWU G DROP:LREND
+1 SET LRLLOC=$PIECE(BPCPARAM,";",5)
SET LROLLOC=""
SET LROLLOC=$ORDER(^SC("C",LRLLOC,LROLLOC))
Q11 ; MJL D PRAC^LRWU1 G DROP:LREND
+1 SET (LRPRAC,^LR(LRDFN,.2))=DUZ
+2 KILL T,TT,LRDMAX,LRDTST,LRTMAX
+3 ;FHL 7/31/97
+4 SET DA=0
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 ; MJL 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) S I=0 F S I=$O(^LRO(69,LRODT,1,DA,2,I)) Q:I<1 S T(+^(I,0),DA)=S D EN^LRORDD
+11 KILL DIC
IF $DATA(LRADDTST)
SET LRORD=+LRADDTST
SET LRADDTST=""
GOTO LRFIRST
+12 DO ORDER^BLROW2
IF $DATA(LRFLOG)
IF $PIECE(LRFLOG,U,3)="MI"
KILL DUOUT
DO MICRO
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO L2
LRFIRST ; MJL W !,"Choose one (or more, separated by commas) ('*' AFTER NUMBER TO CHANGE URGENCY) "
SET LRSX=1
IF 'LRFIRST!(LRWP<2)
GOTO Q13
+1 ; MJL F I=1:1:LRWPD W !,I,?4,$P(LRSTIK(I),U,2) W:$D(LRSTIK(I+LRWPD)) ?39," ",I+LRWPD,?44,$P(LRSTIK(I+LRWPD),U,2)
Q13 SET LREDO=0
IF LRWP'>1
GOTO Q13A
+1 ; MJL W ! W:'LRFIRST "'?' for list, " S LRFIRST=0 R "TEST number(s): ",LRSX:DTIME S:LRSX["?" LRFIRST=1 G LRFIRST:LRFIRST
+2 SET LRSX=BPCTL
+3 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
Q13A ; MJL I LREDO W !,"Something was mistyped, try again." G Q13
+1 FOR LRK=1:1
SET LRSSX=$PIECE(LRSX,",",LRK)
IF LRSSX=""
QUIT
SET LRST=$SELECT(LRSSX["*":1,1:0)
SET LRSSX=+LRSSX
SET LRSAMP=$PIECE(LRSTIK(LRSSX),U,3)
SET LRSPEC=$PIECE(LRSTIK(LRSSX),U,5)
SET LRTSTS=+LRSTIK(LRSSX)
DO Q20^BLRORDD
+2 ; MJL W !,"Other tests? N//" D % G Q14:'(%["Y")
SET LRM=LRWPC+1
SET K=0
LRM ; MJL D MORE^LRORD2
Q14 ;FHL D:$P(LRPARAM,U,17) ^BLRORDD G LRM:'$D(%)&($D(LROT)'=11),DROP:$O(LROT(-1))="",LRM:'$D(%),DROP:%[U K DIC G DROP:'$D(LROT)!(%["N")
+1 IF $PIECE(LRPARAM,U,17)
DO ^BLRORDD
+2 ; MJL 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")
+3 ; MJL W !!,"LAB Order number: ",LRORD,!!
+4 ; MJL I LRECT D TIME^LROE G DROP:LRCDT<1 S LRORDTIM=$P(Y,".",2)
+5 IF LRECT
SET LRORDTIM="08"
+6 DO NOW^%DTC
SET LRNT=%
IF 'LRECT
SET LRCDT=LRNT_"^1"
+7 SET LRIDT=9999999-LRCDT
+8 DO ^BLRORDST
IF $DATA(LROR)
QUIT
+9 SET RESULT(1)=1
SET RESULT(2)="Order: "_LRORD_" "_$GET(BPCACC)
QUIT
+10 ; MJL I $D(LRFASTS) D LRWU4^LRFASTS
+11 ; MJL D:BLRLOG ^BLRSLTL("C","O",$G(BLROPT)) ;IHS/OIRM TUC/AAB 11/14/96
+12 IF $GET(LRKIK)
QUIT
GOTO L2
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
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
URGG WRITE !,"For ",$PIECE(LRSTIK(LRSSX),U,2)
DO URG^LRORD2
QUIT
DROP ;FHL 1/8/98 W !!,"ORDER CANCELED",$C(7),!! Q:$D(LROR) G L2 ; !($G(LREND)) G L2
GOTO L2
MICRO WRITE !,"Is there one sample for this patient's order"
SET %=1
DO YN^DICN
IF %=2!(%=-1)
IF %=-1
SET DUOUT=1
QUIT
+1 IF %=0
WRITE !,"The collection sample and site/specimen will be used for all tests ordered",!,"at this time for this patient."
GOTO MICRO
+2 DO GSNO^LRORD3
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 IF +LRSAMP=-1&(LRSPEC=-1)
WRITE !,"Incompletely defined."
GOTO MICRO
+4 SET LRSAME=LRSAMP_U_LRSPEC
+5 SET LRECOM=0
DO GCOM^LRORD2
+6 QUIT
PRAC ;from LRFAST
+1 SET X=$SELECT(+DIC("B"):$PIECE(^VA(200,+DIC("B"),0),U),1:"")
WRITE !,"PRACTITIONER: ",X,$SELECT($LENGTH(X):"//",1:"")
READ X:DTIME
IF DIC("B")
IF X=""
SET Y=DIC("B")
QUIT
+2 DO ^DIC
KILL DIC
+3 QUIT
