LRWLST ;FHS/DALOI - ACCESSION SETUP. LROE1,LRSTIK & LRFAST CALL HERE ; Aug 9, 2004
;;5.2;LAB SERVICE;**46,65,100,121,153,202,290,424,444,466**;Sep 27, 1994;Build 2
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)
D LRAA,^LRWLST1
S LRCDT=(+LRCDT)_"^"_LREAL
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,LRAAMSG,^TMP("LR",$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,LRAAMSG,^TMP("LR",$J,"TMP")
S LRTSTS=0,LRIX=0,S5=0,LRTN=0
F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
. N LRX
. S LRX=^(LRTN,0) I '$P(LRX,U,3),'$P(LRX,U,6),'$P(LRX,U,8),'$P(LRX,U,11) S LRORIFN=$P(LRX,"^",7),LRBACK=$P(LRX,"^",14) D SET
WL1 ;
; LRDAA is used by POC interface to specify the POC accession area.
S LRIX=0
F S LRIX=$O(^TMP("LR",$J,"TMP",LRIX)) Q:LRIX<1 D
. S X=^(LRIX),LRTSTS=+X,LRURG=$P(X,"^",2),LRORIFN=$P(X,"^",4),LRBACK=$P(X,"^",5)
. S LRST=^LAB(60,LRTSTS,0)
. S LRAA=$S($G(LRDAA)>0:LRDAA,$D(^LAB(60,LRTSTS,8,$S($G(LRDUZ(2))>0:LRDUZ(2),1:DUZ(2)),0)):$P(^(0),U,2),1:"")
. S LRNM=$P(LRST,U),LRUNQ=+$P(LRST,U,7)
. D WL2
Q
;
WL2 ;
D FWL:$G(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) W !,LRNM," TO ",$P(^LRO(68,LRAA,0),U)," accessions","? Y//" D YN 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
. 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),!
. 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
. I $G(LRQUIET) D UNDO Q
. 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("LR",$J,"TMP",LRIX)
Q
SET ;
I $G(LRORDRR)="R" S LRTEST(LRTN)=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
S S5=S5+1,I5=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
I I5 S ^TMP("LR",$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:$D(^LRO(69,LRODT,1,LRSN,2,$P(^TMP("LR",$J,"TMP",LRIX),U,3),0)) $P(^LRO(69,LRODT,1,LRSN,2,$P(^TMP("LR",$J,"TMP",LRIX),U,3),0),U,8)=1 Q
;
I '$D(LRNCWL) D
. N LRTEST,LRPARENT
. S LRTEST=$P(^TMP("LR",$J,"TMP",LRIX),U)
. S LRPARENT=$P(^TMP("LR",$J,"TMP",LRIX),U,6)
. I LRPARENT'="",LRTEST'=LRPARENT,'$D(LRAAMSG(LRPARENT)) D
. . W !,$P(^LAB(60,LRPARENT,0),U)," does not have an appropriate accession area",!
. . S LRAAMSG(LRPARENT)=""
;
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) 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)="AEFOQZ"
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),S5=S5+1,I5=I5+1,^TMP("LR",$J,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$S($G(LRTSP):LRTSP,1:LRTSTS)
Q
PRESET ;
I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) K ^LRO(68,LRAA,1,LRAD,1,LRAN) Q
S LROLRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
I $L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)) S LRDPF=$P(^LR(LROLRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM," ",SSN," has that log #." S LREND=1 Q ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q
S LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3)
Q:'$D(^LR(LROLRDFN,LRSS,LRIDT,0))
PR2 ;
S LRNIDT=9999999-LRCDT
F Q:'$D(^LR(LRDFN,LRSS,LRNIDT,0)) D
. S LRCDT=$$FMADD^XLFDT(LRCDT,,,,1)
. S LRNIDT=9999999-LRCDT
I $P(^LR(LROLRDFN,LRSS,LRIDT,0),U,3) S LREND=1 W !,$C(7),"CAN'T DO IT. The data has been verified for that log number." 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 ;
R X:DTIME
S:'$T DTOUT=1
Q:X=""!(X["N")!(X["Y")
W !,"Answer 'Y' or 'N': " G YN
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,2,LRIFN,0),"^",3,6)="^^^"
;S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="U" ;,$P(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
Q
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 $P(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ
Q
OR ;from LRPHITEM
I $G(LRORDRR)="R" S LRTEST(LRTN)=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWLST 5729 printed Sep 23, 2025@19:58:40 Page 2
LRWLST ;FHS/DALOI - ACCESSION SETUP. LROE1,LRSTIK & LRFAST CALL HERE ; Aug 9, 2004
+1 ;;5.2;LAB SERVICE;**46,65,100,121,153,202,290,424,444,466**;Sep 27, 1994;Build 2
+2 NEW LRPWL,LRPWDT,LRPWLE
+3 DO DT^LRX
+4 if $GET(LRKIL)
QUIT
+5 ; START RESPONSE TIME LOGGING
if $DATA(XRTL)
DO T0^%ZOSV
+6 SET LRCDT=+^LRO(69,LRODT,1,LRSN,1)
SET LREAL=$PIECE(^(1),U,2)
SET X=^(0)
SET LRLLOC=$PIECE(X,U,7)
SET LROLLOC=$PIECE(X,U,9)
SET LRORIFN=$PIECE(X,"^",11)
+7 DO LRAA
DO ^LRWLST1
+8 SET LRCDT=(+LRCDT)_"^"_LREAL
+9 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)
+10 KILL LRTSTS,LRAAMSG,^TMP("LR",$JOB,"TMP"),LRNM,DIC,I,LRORIFN,LRBACK
+11 ; STOP RESPONSE TIME LOGGING
IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+12 QUIT
+13 ;
LRAA ;
+1 KILL LRTSTS,LRAAMSG,^TMP("LR",$JOB,"TMP")
+2 SET LRTSTS=0
SET LRIX=0
SET S5=0
SET LRTN=0
+3 FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
if LRTN<1
QUIT
Begin DoDot:1
+4 NEW LRX
+5 SET LRX=^(LRTN,0)
IF '$PIECE(LRX,U,3)
IF '$PIECE(LRX,U,6)
IF '$PIECE(LRX,U,8)
IF '$PIECE(LRX,U,11)
SET LRORIFN=$PIECE(LRX,"^",7)
SET LRBACK=$PIECE(LRX,"^",14)
DO SET
End DoDot:1
WL1 ;
+1 ; LRDAA is used by POC interface to specify the POC accession area.
+2 SET LRIX=0
+3 FOR
SET LRIX=$ORDER(^TMP("LR",$JOB,"TMP",LRIX))
if LRIX<1
QUIT
Begin DoDot:1
+4 SET X=^(LRIX)
SET LRTSTS=+X
SET LRURG=$PIECE(X,"^",2)
SET LRORIFN=$PIECE(X,"^",4)
SET LRBACK=$PIECE(X,"^",5)
+5 SET LRST=^LAB(60,LRTSTS,0)
+6 SET LRAA=$SELECT($GET(LRDAA)>0:LRDAA,$DATA(^LAB(60,LRTSTS,8,$SELECT($GET(LRDUZ(2))>0:LRDUZ(2),1:DUZ(2)),0)):$PIECE(^(0),U,2),1:"")
+7 SET LRNM=$PIECE(LRST,U)
SET LRUNQ=+$PIECE(LRST,U,7)
+8 DO WL2
End DoDot:1
+9 QUIT
+10 ;
WL2 ;
+1 if $GET(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)
WRITE !,LRNM," TO ",$PIECE(^LRO(68,LRAA,0),U)," accessions","? Y//"
DO YN
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 if '$DATA(LRPHSET)
WRITE !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!",!?10,"Accession Area ",$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U),!
+7 DO UNDO
End DoDot:1
SET LRAA=""
QUIT
+8 SET LRPWL=$PIECE($GET(^LRO(68,LRAA,0)),U,4)
+9 IF LRPWL
IF $PIECE($GET(^LRO(68,LRPWL,.4)),U)=""
Begin DoDot:1
+10 IF $GET(LRQUIET)
DO UNDO
QUIT
+11 if '$DATA(LRPHSET)
WRITE !!?5,"You must enter a 'Numeric Identifier' in field .4 of the Accession file!!"
+12 WRITE !?10,"COMMON Accession Area ",$PIECE($GET(^LRO(68,+$GET(LRPWL),0)),U),!
+13 DO UNDO
End DoDot:1
SET LRAA=""
QUIT
+14 ;
+15 SET LRWLC=$PIECE(LRWL0,U,4)
+16 if 'LRWLC
SET LRWLC=LRAA
+17 SET LRTSTS(LRWLC,LRUNQ,LRAA)=LRSS_U_$PIECE(LRWL0,U,12)
SET LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)=^TMP("LR",$JOB,"TMP",LRIX)
+18 QUIT
SET ;
+1 IF $GET(LRORDRR)="R"
SET LRTEST(LRTN)=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
+2 SET S5=S5+1
SET I5=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
+3 IF I5
SET ^TMP("LR",$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
+4 QUIT
FWL ;
+1 IF $ORDER(^LAB(60,LRTSTS,2,0))>0
DO EXP
if $DATA(^LRO(69,LRODT,1,LRSN,2,$PIECE(^TMP("LR",$JOB,"TMP",LRIX),U,3),0))
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,$PIECE(^TMP("LR",$JOB,"TMP",LRIX),U,3),0),U,8)=1
QUIT
+2 ;
+3 IF '$DATA(LRNCWL)
Begin DoDot:1
+4 NEW LRTEST,LRPARENT
+5 SET LRTEST=$PIECE(^TMP("LR",$JOB,"TMP",LRIX),U)
+6 SET LRPARENT=$PIECE(^TMP("LR",$JOB,"TMP",LRIX),U,6)
+7 IF LRPARENT'=""
IF LRTEST'=LRPARENT
IF '$DATA(LRAAMSG(LRPARENT))
Begin DoDot:2
+8 WRITE !,$PIECE(^LAB(60,LRPARENT,0),U)," does not have an appropriate accession area",!
+9 SET LRAAMSG(LRPARENT)=""
End DoDot:2
End DoDot:1
+10 ;
+11 IF '$DATA(LRNCWL)
IF $DATA(LRPHSET)
IF LRPHSET
WRITE !,"NO ACCESSION AREA FOR ORDER NUMBER ",^LRO(69,LRODT,1,LRSN,.1)," TEST ",$PIECE(^LAB(60,LRTSTS,0),U),!
DO UNDO
QUIT
+12 IF '$DATA(LRNCWL)
WRITE !,LRNM," does not have an appropriate accession area.",!,"ORDER # ",LRORD," IS NOT ACCESSIONED",!
SET LRAA=""
DO UNDO
QUIT
+13 WRITE !,"For test: ",LRNM
+14 KILL DIC
+15 SET DIC("S")="I '$L($P(^(0),U,17))"
SET DIC="^LRO(68,"
SET DIC(0)="AEFOQZ"
+16 DO ^DIC
+17 KILL DIC
+18 IF $DATA(DUOUT)
SET LRAA=""
QUIT
+19 if Y<1
GOTO FWL
+20 SET LRAA=+Y
+21 QUIT
EXP ;
+1 SET I=0
+2 FOR
SET I=$ORDER(^LAB(60,LRTSTS,2,I))
if I<1
QUIT
SET J=+^(I,0)
SET S5=S5+1
SET I5=I5+1
SET ^TMP("LR",$JOB,"TMP",S5)=J_"^"_LRURG_"^"_I5_"^"_LRORIFN_"^"_LRBACK_"^"_$SELECT($GET(LRTSP):LRTSP,1:LRTSTS)
+3 QUIT
PRESET ;
+1 IF '($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2)
KILL ^LRO(68,LRAA,1,LRAD,1,LRAN)
QUIT
+2 SET LROLRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
+3 ;W !," OK to change it? N//" D YN I X=""!(X'["Y") S LREND=1 Q
IF $LENGTH($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5))
SET LRDPF=$PIECE(^LR(LROLRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE !,PNM," ",SSN," has that log #."
SET LREND=1
QUIT
+4 SET LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3)
+5 if '$DATA(^LR(LROLRDFN,LRSS,LRIDT,0))
QUIT
PR2 ;
+1 SET LRNIDT=9999999-LRCDT
+2 FOR
if '$DATA(^LR(LRDFN,LRSS,LRNIDT,0))
QUIT
Begin DoDot:1
+3 SET LRCDT=$$FMADD^XLFDT(LRCDT,,,,1)
+4 SET LRNIDT=9999999-LRCDT
End DoDot:1
+5 IF $PIECE(^LR(LROLRDFN,LRSS,LRIDT,0),U,3)
SET LREND=1
WRITE !,$CHAR(7),"CAN'T DO IT. The data has been verified for that log number."
QUIT
+6 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)
+7 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)
+8 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:"")
+9 if $LENGTH(LROID)
KILL ^LRO(68,LRAA,1,LRAD,1,"C",LROID,LRAN)
+10 if $LENGTH(LROCN)
KILL ^LRO(68,LRAA,1,LRAD,1,"D",LROCN,LRAN)
+11 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LR(LROLRDFN,LRSS,LRIDT)
+12 QUIT
YN ;
+1 READ X:DTIME
+2 if '$TEST
SET DTOUT=1
+3 if X=""!(X["N")!(X["Y")
QUIT
+4 WRITE !,"Answer 'Y' or 'N': "
GOTO YN
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,2,LRIFN,0),"^",3,6)="^^^"
+4 ;S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="U" ;,$P(^(1),U,6)=LRNM_" NOT ACCESSIONED - TEST DEFINITION INCOMPLETE"
+5 QUIT
+6 SET X=$GET(^LRO(69,LRODT,1,LRSN,2,LRIFN,0))
if 'X
QUIT
SET TST(+X)=""
+7 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"
+8 DO NEW^LR7OB1(LRODT,LRSN,"OC",,.TST)
+9 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRIFN,0),"^",3,6)="^^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
+10 QUIT
OR ;from LRPHITEM
+1 IF $GET(LRORDRR)="R"
SET LRTEST(LRTN)=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
QUIT
+2 QUIT
