BLRAG05B ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
EP ; EP
N BLRLOG1
N LRPWL,LRPWDT,LRPWLE
D DT^LRX
Q:$G(LRKIL)
;D:$D(XRTL) T0^%ZOSV ; START RESPONSE TIME LOGGING
; S LRCDT=+^LRO(69,LRODT,1,LRSN,1),LREAL=$P(^(1),U,2),X=^(0),LRLLOC=$P(X,U,7),LROLLOC=$P(X,U,9),LRORIFN=$P(X,"^",11)
; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
; Need to remove the naked references because they are causing
; <UNDEFINED> errors at numerous IHS sites.
S LRCDT=+$G(^LRO(69,LRODT,1,LRSN,1))
S LREAL=$P($G(^LRO(69,LRODT,1,LRSN,1)),U,2)
S X=$G(^LRO(69,LRODT,1,LRSN,0))
S LRLLOC=$P(X,U,7)
S LROLLOC=$P(X,U,9)
S LRORIFN=$P(X,"^",11)
; ----- END IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
D LRAA
Q:BLREF
;
S BLRLOG1=BLRLOG,BLRLOG=1
S BLROPT1=BLROPT,BLROPT="ADDACC"
S:LRCDT<1 LRCDT=$$NOW^XLFDT
;
S:$G(MSCRLCLA)="" MSCRLCLA=$G(BLRRLCLA)
D ^LRWLST1
S BLRRLCLA=MSCRLCLA
;
S BLRLOG=BLRLOG1
S BLROPT=BLROPT1
;
S LRCDT=(+LRCDT)_"^"_LREAL
N BLR69DT,BLR69SP,BLR69TS,BLRMSCDT
S BLR69DT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
S BLR69SP=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
S BLR69TS=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
S BLRMSCDT=+$P($G(^LRO(69,BLR69DT,1,BLR69SP,2,BLR69TS,0)),U,3) S:BLRMSCDT'=0 ^LRO(69,"AFMSC",BLRMSCDT,BLR69DT_"|"_BLR69SP_"|"_BLR69TS)=""
S:BLRRLCLA $P(^LRO(69,BLR69DT,1,BLR69SP,2,BLR69TS,"MSC"),U,1)=BLRRLCLA
;
I '$L($P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)) S CONTROL=$S($L(LRORIFN):"SC",1:"SN") D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
K LRTSTS,^TMP("BLR",$J,"TMP"),LRNM,DIC,I,LRORIFN,LRBACK
;I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
Q
LRAA ;
K LRTSTS,^TMP("BLR",$J,"TMP")
S LRTSTS=0,LRIX=0,S5=0,LRTN=0
S LRTN=BLRTST
S X=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
I '$P(X,U,3),'$P(X,U,6),'$P(X,U,8),'$P(X,U,11) D
.S LRORIFN=$P(X,"^",7),LRBACK=$P(X,"^",14)
.D OR,SET ;OE/RR 2.5 can remove call to OR after 3.0
E I LRTN=BLRTST D
.; S BLR60NAM=$$GET1^DIQ(60,$P(X,U,1)_",",.01)
.S BLR60NAM=$$TESTNAME^BLRAGUT(+$P(X,U,1))
.S:$P(X,U,3) BLRRET="BLRAG05B: This Test has previously been accessioned: "_BLR60NAM,BLREF=1
.S:$P(X,U,6) BLRRET="BLRAG05B: This test has been 'Combined On Order': "_BLR60NAM,BLREF=1
.S:$P(X,U,8) BLRRET="BLRAG05B: Panel has no accession area and has been exploded and accessioned: "_BLR60NAM,BLREF=1
.S:$P(X,U,11) BLRRET="BLRAG05B: This test has been Canceled: "_BLR60NAM,BLREF=1
WL1 ;
S LRIX=$O(^TMP("BLR",$J,"TMP",LRIX)) Q:LRIX<1 S X=^TMP("BLR",$J,"TMP",LRIX) S LRTSTS=+X,LRURG=$P(X,"^",2),LRORIFN=$P(X,"^",4),LRBACK=$P(X,"^",5)
S LRST=^LAB(60,LRTSTS,0),LRAA=$S($D(^LAB(60,LRTSTS,8,$S($D(LRDUZ(2)):LRDUZ(2),1:DUZ(2)),0)):$P(^(0),U,2),1:""),LRNM=$P(LRST,U),LRUNQ=+$P(LRST,U,7)
D WL2
G WL1
WL2 ;
D FWL:LRAA="" Q:LRAA=""
S LRWL0=^LRO(68,LRAA,0),LRSS=$P(LRWL0,U,2),LRIDIV=$S($L($P(LRWL0,U,19)):$P(LRWL0,U,19),1:"CP")
I '$D(LRPHSET),$D(LRNCWL) S X="Y" Q:X="^" IF X["N" S LRAA="" G WL2
;added following line to support unique ID/DALISC/JRR
I $P($G(^LRO(68,LRAA,.4)),U)="" D S LRAA="" Q
. S BLRRET="BLRAG05B: You must enter a 'Numeric Identifier' in field .4 of the Accession file. "_"Accession Area "_$P($G(^LRO(68,+$G(LRAA),0)),U)
. ;W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!",!?10,"Accession Area ",$P($G(^LRO(68,+$G(LRAA),0)),U),!
. S BLREF=1
. D UNDO
S LRPWL=$P($G(^LRO(68,LRAA,0)),U,4)
I LRPWL,$P($G(^LRO(68,LRPWL,.4)),U)="" D S LRAA="" Q
. S BLRRET="BLRAG05B: You must enter a 'Numeric Identifier' in field .4 of the Accession file. "_"COMMON Accession Area "_$P($G(^LRO(68,+$G(LRPWL),0)),U)
. ;W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!"
. ;W !?10,"COMMON Accession Area ",$P($G(^LRO(68,+$G(LRPWL),0)),U),!
. D UNDO
;
S LRWLC=$P(LRWL0,U,4)
S:'LRWLC LRWLC=LRAA
S LRTSTS(LRWLC,LRUNQ,LRAA)=LRSS_U_$P(LRWL0,U,12),LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)=^TMP("BLR",$J,"TMP",LRIX)
Q
SET ;
S S5=S5+1,I5=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
I I5 S ^TMP("BLR",$J,"TMP",S5)=$P(I5,U)_U_$P(I5,U,2)_U_LRTN_U_LRORIFN_U_LRBACK_U_$S($G(LRTSP):LRTSP,1:$P(I5,U)),I5=LRTN
Q
FWL ;
I $O(^LAB(60,LRTSTS,2,0))>0 D EXP S $P(^LRO(69,LRODT,1,LRSN,2,$P(^TMP("BLR",$J,"TMP",LRIX),U,3),0),U,8)=1 Q
I '$D(LRNCWL),$D(LRPHSET),LRPHSET S BLRRET="BLRAG05B: NO ACCESSION AREA FOR ORDER NUMBER "_^LRO(69,LRODT,1,LRSN,.1)_" TEST "_$P(^LAB(60,LRTSTS,0),U) S BLREF=1 D UNDO Q
;I '$D(LRNCWL),$D(LRPHSET),LRPHSET W !,"NO ACCESSION AREA FOR ORDER NUMBER ",^LRO(69,LRODT,1,LRSN,.1)," TEST ",$P(^LAB(60,LRTSTS,0),U),! D UNDO Q
I '$D(LRNCWL) S BLRRET="BLRAG05B: "_LRNM_" does not have an appropriate accession area."_"ORDER # "_LRORD_" IS NOT ACCESSIONED" S BLREF=1 S LRAA="" D UNDO Q
;I '$D(LRNCWL) W !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",! S LRAA="" D UNDO Q
;
;W !,"For test: ",LRNM
K DIC
S DIC("S")="I '$L($P(^(0),U,17))",DIC="^LRO(68,",DIC(0)="FOZ"
D ^DIC
K DIC
I $D(DUOUT) S LRAA="" Q
G:Y<1 FWL
S LRAA=+Y
Q
EXP ;
S I=0
F S I=$O(^LAB(60,LRTSTS,2,I)) Q:I<1 S J=+^(I,0) I $D(^LAB(60,J,8,DUZ(2),0)) S S5=S5+1,I5=I5+1,^TMP("BLR",$J,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$S($G(LRTSP):LRTSP,1:LRTSTS)
Q
PRESET ; not used by GUI
Q
PR2 ; not used by GUI
Q
S LRNIDT=9999999-LRCDT
IF $D(^LR(LRDFN,LRSS,LRNIDT,0)) S LRCDT=LRCDT+.00001 G PR2
I $P(^LR(LROLRDFN,LRSS,LRIDT,0),U,3) S LREND=1 S BLRRET="BLRAG05B: CAN'T DO IT. The data has been verified for that log number." S BLREF=1 Q
S ^LR(LRDFN,LRSS,LRNIDT,0)=LRCDT_U_LREAL_U_$P(^LR(LROLRDFN,LRSS,LRIDT,0),U,3,4)_U_U_$P(^(0),U,6,99)
S J=0 F S J=$O(^LR(LROLRDFN,LRSS,LRIDT,J)) Q:J<1 S ^LR(LRDFN,LRSS,LRNIDT,J)=^LR(LROLRDFN,LRSS,LRIDT,J)
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LROSN=$P(X,U,5),LROID=$P(X,U,6),LROCN=$S($D(^(.1)):$P(^(.1),U),1:"")
K:$L(LROID) ^LRO(68,LRAA,1,LRAD,1,"C",LROID,LRAN)
K:$L(LROCN) ^LRO(68,LRAA,1,LRAD,1,"D",LROCN,LRAN)
K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LR(LROLRDFN,LRSS,LRIDT)
Q
YN ;
Q
UNDO ;Clean up ^LRO(69
N X,TST
S LRIFN=+$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,0)) Q:LRIFN<1
S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="U",$P(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
S X=$G(^LRO(69,LRODT,1,LRSN,2,LRIFN,0)) Q:'X S TST(+X)=""
S X=$S($D(^LRO(69,LRODT,1,LRSN,2,LRIFN,1.1,0)):$P(^(0),"^",3),1:0)+1,^(0)="^^"_X_"^"_X_"^"_DT,^(X,0)="Not accessioned - Test definition incomplete"
D NEW^LR7OB1(LRODT,LRSN,"OC",,.TST)
S BLRMSCDT=$P(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3)
S $P(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ
K:$G(BLRMSCDT)'="" ^LRO(69,"AFMSC",BLRMSCDT,LRODT_"|"_LRSN_"|"_LRIFN)
Q
OR ;from LRPHITEM
I $G(LRORDRR)="R" S LRTEST(LRTN)=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
;IHS/ITSC/TPF TESTING ; SET LRSAMP AND LRSPEC EVEN IF OE/RR 3 IS IN NEEDED FOR IHS MODS
I $$VER^LR7OU1>2.5 S LRI=LRTN,LRORD=+^LRO(69,LRODT,1,LRSN,.1),LRLWC=$P(^(0),"^",4),LRSAMP=$P(^(0),"^",3),LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:""),LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0) Q
;I 'LRORIFN S LRI=LRTN,LRORD=+^LRO(69,LRODT,1,LRSN,.1),LRLWC=$P(^(0),"^",4),LRSAMP=$P(^(0),"^",3),LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:""),LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0) D SET^LROR
;BEGIN IHS MODIFCATION LR*5.2*1018 FIXED DURING ALPHA IHS/ITSC/TPF 2/10/2004
;RESTORE ABOVE LINE. IT WAS INCORRECTLY COMMENTED OUT
;FOUND BECAUSE SPECIMEN WAS NOT PROPERLY DEFINED FOR MICROS
;RECEIVED MAIL MESSAGES FOR 'INCORRECT PROVIDER. ALSO DEFAULT PROMPT AT RESULTING USING
;RE WAS 0
I 'LRORIFN S LRI=LRTN,LRORD=+^LRO(69,LRODT,1,LRSN,.1),LRLWC=$P(^(0),"^",4),LRSAMP=$P(^(0),"^",3),LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:""),LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0) D SET^LROR
;BEGIN IHS MODIFCATION LR*5.2*1018 FIXED DURING ALPHA IHS/ITSC/TPF 2/10/2004
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;RESTORE CALL TO ORX
I LRORIFN S ORIFN=LRORIFN,ORSTS=6 D ST^ORX K ORSTS,ORIFN
;----- BEGIN IHS MODIFICATION LR*5.2*1018 MAY NOT NEED
;I LRORIFN S ORIFN=LRORIFN,ORSTS=6 K ORSTS,ORIFN ;IHS/DIR TUC/AAB 06/15/98
;----- END IHS MODIFICATION
Q
BLRAG05B ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
EP ; EP
+1 NEW BLRLOG1
+2 NEW LRPWL,LRPWDT,LRPWLE
+3 DO DT^LRX
+4 IF $GET(LRKIL)
QUIT
+5 ;D:$D(XRTL) T0^%ZOSV ; START RESPONSE TIME LOGGING
+6 ; S LRCDT=+^LRO(69,LRODT,1,LRSN,1),LREAL=$P(^(1),U,2),X=^(0),LRLLOC=$P(X,U,7),LROLLOC=$P(X,U,9),LRORIFN=$P(X,"^",11)
+7 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
+8 ; Need to remove the naked references because they are causing
+9 ; <UNDEFINED> errors at numerous IHS sites.
+10 SET LRCDT=+$GET(^LRO(69,LRODT,1,LRSN,1))
+11 SET LREAL=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,2)
+12 SET X=$GET(^LRO(69,LRODT,1,LRSN,0))
+13 SET LRLLOC=$PIECE(X,U,7)
+14 SET LROLLOC=$PIECE(X,U,9)
+15 SET LRORIFN=$PIECE(X,"^",11)
+16 ; ----- END IHS/OIT/MKK -- LR*5.2*1025 MODIFICATIONS
+17 DO LRAA
+18 IF BLREF
QUIT
+19 ;
+20 SET BLRLOG1=BLRLOG
SET BLRLOG=1
+21 SET BLROPT1=BLROPT
SET BLROPT="ADDACC"
+22 IF LRCDT<1
SET LRCDT=$$NOW^XLFDT
+23 ;
+24 IF $GET(MSCRLCLA)=""
SET MSCRLCLA=$GET(BLRRLCLA)
+25 DO ^LRWLST1
+26 SET BLRRLCLA=MSCRLCLA
+27 ;
+28 SET BLRLOG=BLRLOG1
+29 SET BLROPT=BLROPT1
+30 ;
+31 SET LRCDT=(+LRCDT)_"^"_LREAL
+32 NEW BLR69DT,BLR69SP,BLR69TS,BLRMSCDT
+33 SET BLR69DT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+34 SET BLR69SP=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+35 SET BLR69TS=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",3)
+36 SET BLRMSCDT=+$PIECE($GET(^LRO(69,BLR69DT,1,BLR69SP,2,BLR69TS,0)),U,3)
IF BLRMSCDT'=0
SET ^LRO(69,"AFMSC",BLRMSCDT,BLR69DT_"|"_BLR69SP_"|"_BLR69TS)=""
+37 IF BLRRLCLA
SET $PIECE(^LRO(69,BLR69DT,1,BLR69SP,2,BLR69TS,"MSC"),U,1)=BLRRLCLA
+38 ;
+39 IF '$LENGTH($PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7))
SET CONTROL=$SELECT($LENGTH(LRORIFN):"SC",1:"SN")
DO NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
+40 KILL LRTSTS,^TMP("BLR",$JOB,"TMP"),LRNM,DIC,I,LRORIFN,LRBACK
+41 ;I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV ; STOP RESPONSE TIME LOGGING
+42 QUIT
LRAA ;
+1 KILL LRTSTS,^TMP("BLR",$JOB,"TMP")
+2 SET LRTSTS=0
SET LRIX=0
SET S5=0
SET LRTN=0
+3 SET LRTN=BLRTST
+4 SET X=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
+5 IF '$PIECE(X,U,3)
IF '$PIECE(X,U,6)
IF '$PIECE(X,U,8)
IF '$PIECE(X,U,11)
Begin DoDot:1
+6 SET LRORIFN=$PIECE(X,"^",7)
SET LRBACK=$PIECE(X,"^",14)
+7 ;OE/RR 2.5 can remove call to OR after 3.0
DO OR
DO SET
End DoDot:1
+8 IF '$TEST
IF LRTN=BLRTST
Begin DoDot:1
+9 ; S BLR60NAM=$$GET1^DIQ(60,$P(X,U,1)_",",.01)
+10 SET BLR60NAM=$$TESTNAME^BLRAGUT(+$PIECE(X,U,1))
+11 IF $PIECE(X,U,3)
SET BLRRET="BLRAG05B: This Test has previously been accessioned: "_BLR60NAM
SET BLREF=1
+12 IF $PIECE(X,U,6)
SET BLRRET="BLRAG05B: This test has been 'Combined On Order': "_BLR60NAM
SET BLREF=1
+13 IF $PIECE(X,U,8)
SET BLRRET="BLRAG05B: Panel has no accession area and has been exploded and accessioned: "_BLR60NAM
SET BLREF=1
+14 IF $PIECE(X,U,11)
SET BLRRET="BLRAG05B: This test has been Canceled: "_BLR60NAM
SET BLREF=1
End DoDot:1
WL1 ;
+1 SET LRIX=$ORDER(^TMP("BLR",$JOB,"TMP",LRIX))
IF LRIX<1
QUIT
SET X=^TMP("BLR",$JOB,"TMP",LRIX)
SET LRTSTS=+X
SET LRURG=$PIECE(X,"^",2)
SET LRORIFN=$PIECE(X,"^",4)
SET LRBACK=$PIECE(X,"^",5)
+2 SET LRST=^LAB(60,LRTSTS,0)
SET LRAA=$SELECT($DATA(^LAB(60,LRTSTS,8,$SELECT($DATA(LRDUZ(2)):LRDUZ(2),1:DUZ(2)),0)):$PIECE(^(0),U,2),1:"")
SET LRNM=$PIECE(LRST,U)
SET LRUNQ=+$PIECE(LRST,U,7)
+3 DO WL2
+4 GOTO WL1
WL2 ;
+1 IF LRAA=""
DO FWL
IF LRAA=""
QUIT
+2 SET LRWL0=^LRO(68,LRAA,0)
SET LRSS=$PIECE(LRWL0,U,2)
SET LRIDIV=$SELECT($LENGTH($PIECE(LRWL0,U,19)):$PIECE(LRWL0,U,19),1:"CP")
+3 IF '$DATA(LRPHSET)
IF $DATA(LRNCWL)
SET X="Y"
IF X="^"
QUIT
IF X["N"
SET LRAA=""
GOTO WL2
+4 ;added following line to support unique ID/DALISC/JRR
+5 IF $PIECE($GET(^LRO(68,LRAA,.4)),U)=""
Begin DoDot:1
+6 SET BLRRET="BLRAG05B: You must enter a 'Numeric Identifier' in field .4 of the Accession file. "_"Accession Area "_$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U)
+7 ;W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!",!?10,"Accession Area ",$P($G(^LRO(68,+$G(LRAA),0)),U),!
+8 SET BLREF=1
+9 DO UNDO
End DoDot:1
SET LRAA=""
QUIT
+10 SET LRPWL=$PIECE($GET(^LRO(68,LRAA,0)),U,4)
+11 IF LRPWL
IF $PIECE($GET(^LRO(68,LRPWL,.4)),U)=""
Begin DoDot:1
+12 SET BLRRET="BLRAG05B: You must enter a 'Numeric Identifier' in field .4 of the Accession file. "_"COMMON Accession Area "_$PIECE($GET(^LRO(68,+$GET(LRPWL),0)),U)
+13 ;W:'$D(LRPHSET) !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!"
+14 ;W !?10,"COMMON Accession Area ",$P($G(^LRO(68,+$G(LRPWL),0)),U),!
+15 DO UNDO
End DoDot:1
SET LRAA=""
QUIT
+16 ;
+17 SET LRWLC=$PIECE(LRWL0,U,4)
+18 IF 'LRWLC
SET LRWLC=LRAA
+19 SET LRTSTS(LRWLC,LRUNQ,LRAA)=LRSS_U_$PIECE(LRWL0,U,12)
SET LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)=^TMP("BLR",$JOB,"TMP",LRIX)
+20 QUIT
SET ;
+1 SET S5=S5+1
SET I5=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
+2 IF I5
SET ^TMP("BLR",$JOB,"TMP",S5)=$PIECE(I5,U)_U_$PIECE(I5,U,2)_U_LRTN_U_LRORIFN_U_LRBACK_U_$SELECT($GET(LRTSP):LRTSP,1:$PIECE(I5,U))
SET I5=LRTN
+3 QUIT
FWL ;
+1 IF $ORDER(^LAB(60,LRTSTS,2,0))>0
DO EXP
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,$PIECE(^TMP("BLR",$JOB,"TMP",LRIX),U,3),0),U,8)=1
QUIT
+2 IF '$DATA(LRNCWL)
IF $DATA(LRPHSET)
IF LRPHSET
SET BLRRET="BLRAG05B: NO ACCESSION AREA FOR ORDER NUMBER "_^LRO(69,LRODT,1,LRSN,.1)_" TEST "_$PIECE(^LAB(60,LRTSTS,0),U)
SET BLREF=1
DO UNDO
QUIT
+3 ;I '$D(LRNCWL),$D(LRPHSET),LRPHSET W !,"NO ACCESSION AREA FOR ORDER NUMBER ",^LRO(69,LRODT,1,LRSN,.1)," TEST ",$P(^LAB(60,LRTSTS,0),U),! D UNDO Q
+4 IF '$DATA(LRNCWL)
SET BLRRET="BLRAG05B: "_LRNM_" does not have an appropriate accession area."_"ORDER # "_LRORD_" IS NOT ACCESSIONED"
SET BLREF=1
SET LRAA=""
DO UNDO
QUIT
+5 ;I '$D(LRNCWL) W !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",! S LRAA="" D UNDO Q
+6 ;
+7 ;W !,"For test: ",LRNM
+8 KILL DIC
+9 SET DIC("S")="I '$L($P(^(0),U,17))"
SET DIC="^LRO(68,"
SET DIC(0)="FOZ"
+10 DO ^DIC
+11 KILL DIC
+12 IF $DATA(DUOUT)
SET LRAA=""
QUIT
+13 IF Y<1
GOTO FWL
+14 SET LRAA=+Y
+15 QUIT
EXP ;
+1 SET I=0
+2 FOR
SET I=$ORDER(^LAB(60,LRTSTS,2,I))
IF I<1
QUIT
SET J=+^(I,0)
IF $DATA(^LAB(60,J,8,DUZ(2),0))
SET S5=S5+1
SET I5=I5+1
SET ^TMP("BLR",$JOB,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$SELECT($GET(LRTSP):LRTSP,1:LRTSTS)
+3 QUIT
PRESET ; not used by GUI
+1 QUIT
PR2 ; not used by GUI
+1 QUIT
+2 SET LRNIDT=9999999-LRCDT
+3 IF $DATA(^LR(LRDFN,LRSS,LRNIDT,0))
SET LRCDT=LRCDT+.00001
GOTO PR2
+4 IF $PIECE(^LR(LROLRDFN,LRSS,LRIDT,0),U,3)
SET LREND=1
SET BLRRET="BLRAG05B: CAN'T DO IT. The data has been verified for that log number."
SET BLREF=1
QUIT
+5 SET ^LR(LRDFN,LRSS,LRNIDT,0)=LRCDT_U_LREAL_U_$PIECE(^LR(LROLRDFN,LRSS,LRIDT,0),U,3,4)_U_U_$PIECE(^(0),U,6,99)
+6 SET J=0
FOR
SET J=$ORDER(^LR(LROLRDFN,LRSS,LRIDT,J))
IF J<1
QUIT
SET ^LR(LRDFN,LRSS,LRNIDT,J)=^LR(LROLRDFN,LRSS,LRIDT,J)
+7 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LROSN=$PIECE(X,U,5)
SET LROID=$PIECE(X,U,6)
SET LROCN=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
+8 IF $LENGTH(LROID)
KILL ^LRO(68,LRAA,1,LRAD,1,"C",LROID,LRAN)
+9 IF $LENGTH(LROCN)
KILL ^LRO(68,LRAA,1,LRAD,1,"D",LROCN,LRAN)
+10 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LR(LROLRDFN,LRSS,LRIDT)
+11 QUIT
YN ;
+1 QUIT
UNDO ;Clean up ^LRO(69
+1 NEW X,TST
+2 SET LRIFN=+$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,0))
IF LRIFN<1
QUIT
+3 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="U"
SET $PIECE(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
+4 SET X=$GET(^LRO(69,LRODT,1,LRSN,2,LRIFN,0))
IF 'X
QUIT
SET TST(+X)=""
+5 SET X=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,2,LRIFN,1.1,0)):$PIECE(^(0),"^",3),1:0)+1
SET ^(0)="^^"_X_"^"_X_"^"_DT
SET ^(X,0)="Not accessioned - Test definition incomplete"
+6 DO NEW^LR7OB1(LRODT,LRSN,"OC",,.TST)
+7 SET BLRMSCDT=$PIECE(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3)
+8 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
+9 IF $GET(BLRMSCDT)'=""
KILL ^LRO(69,"AFMSC",BLRMSCDT,LRODT_"|"_LRSN_"|"_LRIFN)
+10 QUIT
OR ;from LRPHITEM
+1 IF $GET(LRORDRR)="R"
SET LRTEST(LRTN)=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
QUIT
+2 ;IHS/ITSC/TPF TESTING ; SET LRSAMP AND LRSPEC EVEN IF OE/RR 3 IS IN NEEDED FOR IHS MODS
+3 IF $$VER^LR7OU1>2.5
SET LRI=LRTN
SET LRORD=+^LRO(69,LRODT,1,LRSN,.1)
SET LRLWC=$PIECE(^(0),"^",4)
SET LRSAMP=$PIECE(^(0),"^",3)
SET LRSPEC=$SELECT($ORDER(^(4,0))'="":$PIECE(^($ORDER(^(0)),0),"^"),1:"")
SET LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
QUIT
+4 ;I 'LRORIFN S LRI=LRTN,LRORD=+^LRO(69,LRODT,1,LRSN,.1),LRLWC=$P(^(0),"^",4),LRSAMP=$P(^(0),"^",3),LRSPEC=$S($O(^(4,0))'="":$P(^($O(^(0)),0),"^"),1:""),LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0) D SET^LROR
+5 ;BEGIN IHS MODIFCATION LR*5.2*1018 FIXED DURING ALPHA IHS/ITSC/TPF 2/10/2004
+6 ;RESTORE ABOVE LINE. IT WAS INCORRECTLY COMMENTED OUT
+7 ;FOUND BECAUSE SPECIMEN WAS NOT PROPERLY DEFINED FOR MICROS
+8 ;RECEIVED MAIL MESSAGES FOR 'INCORRECT PROVIDER. ALSO DEFAULT PROMPT AT RESULTING USING
+9 ;RE WAS 0
+10 IF 'LRORIFN
SET LRI=LRTN
SET LRORD=+^LRO(69,LRODT,1,LRSN,.1)
SET LRLWC=$PIECE(^(0),"^",4)
SET LRSAMP=$PIECE(^(0),"^",3)
SET LRSPEC=$SELECT($ORDER(^(4,0))'="":$PIECE(^($ORDER(^(0)),0),"^"),1:"")
SET LRTEST(LRI)=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
DO SET^LROR
+11 ;BEGIN IHS MODIFCATION LR*5.2*1018 FIXED DURING ALPHA IHS/ITSC/TPF 2/10/2004
+12 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+13 ;RESTORE CALL TO ORX
+14 IF LRORIFN
SET ORIFN=LRORIFN
SET ORSTS=6
DO ST^ORX
KILL ORSTS,ORIFN
+15 ;----- BEGIN IHS MODIFICATION LR*5.2*1018 MAY NOT NEED
+16 ;I LRORIFN S ORIFN=LRORIFN,ORSTS=6 K ORSTS,ORIFN ;IHS/DIR TUC/AAB 06/15/98
+17 ;----- END IHS MODIFICATION
+18 QUIT
