LRPHSET1 ; VA/SLC/CJS - COLLECTION LIST TO ACCESSIONS ; 17-Oct-2014 09:23 ; MKK
;;5.2;LAB SERVICE;**121,191,221,1015,240,1018,423,1034**;NOV 01, 1997;Build 104
Q
EN ;from LRPHSET
K ^LRO(69,DT,1,"AD") S $P(^LAB(69.9,1,5),"^",10,12)=1_"^"_$H_"^"_$S($D(DUZ):DUZ,1:"")
S LRDFN=0 F S LRDFN=$O(^LRO(69,DT,1,"AA",LRDFN)) Q:LRDFN<1 K T D S6
S LRLOC="",LRCOUNT=0,LRDUZ(2)=$S($D(DUZ(2)):DUZ(2),1:"") F LRPH=0:0 S LRLOC=$O(^LRO(69,DT,1,"AD",LRLOC)) Q:LRLOC="" D S4
S $P(^LAB(69.9,1,5),"^",10)=0
G END
S4 K DIC S D="C",X=LRLOC,DIC(0)="Z",DIC=44 D IX^DIC S LRDUZ(2)=$S(Y<1:DUZ(2),1:$S($P(Y(0),U,4):$P(Y(0),U,4),1:DUZ(2)))
S LRDFN=0 F S LRDFN=$O(^LRO(69,DT,1,"AD",LRLOC,LRDFN)) Q:LRDFN<1 D S4A
Q
S4A S LRSN=0 F S LRSN=$O(^LRO(69,DT,1,"AD",LRLOC,LRDFN,LRSN)) Q:LRSN<1 D:$D(^LRO(69,DT,1,LRSN,1)) S4C D:'($D(^LRO(69,DT,1,LRSN,1))#2)&($D(^(0))) S4B
Q
S4B S X=^LRO(69,DT,1,LRSN,0) I $P(X,U,4)="LC",LRDFN=+X,$P(X,U,8)'>LRDTI S:$$GOT(DT,LRSN) LRCOUNT=LRCOUNT+1 D S5
Q
S4C I $P(^LRO(69,DT,1,LRSN,1),U)'>LRDTI S X=^(0) I $P(X,U,4)="LC",LRDFN=+X,$P(X,U,8)'>LRDTI D S5
Q
S5 S ^LRO(69,DT,1,"AC",LRLOC,LRSN)=1,LRSCR=$S($D(^LRO(69,DT,1,LRSN,1)):$P(^(1),U,3,99),1:""),^(1)=LRDTI_"^1^"_LRSCR,LRTJ=$P(^(0),U,3,4)_"^"_DT,LRSAMP=$P(LRTJ,U,1)
S LRSPEC=$P(^LAB(62,LRSAMP,0),U,2),I=$O(^LRO(69,DT,1,LRSN,6,0)) K LRSPCDSC S:I LRSPCDSC=^(I,0)
I $D(^LRO(69,DT,1,LRSN,1)),'$L($P(^(1),U,4)),$D(^(3)) S LRLLOC=$P(^LRO(69,DT,1,LRSN,0),U,7),LROLLOC=$P(^(0),U,9) D REUP^LRPHSET2
D OLD^LRORDST K LRTJ Q
S6 S T="",LRSN=0 F S LRSN=$O(^LRO(69,DT,1,"AA",LRDFN,LRSN)) Q:LRSN<1 D S6A
S LRSAMP=0 F S LRSAMP=$O(T(LRSAMP)) Q:LRSAMP<1 S LRSTEP=0 D S7^LRPHSET2 S LRSTEP=1 D S7^LRPHSET2
Q
S6A I '$S($D(^LRO(69,DT,1,LRSN,0)):$L($P(^(0),U,2)),1:0) Q
Q:$P(^LRO(69,DT,1,LRSN,0),U,4)'="LC" Q:$P(^(0),U,8)>LRDTI I $D(^(1)),$L($P(^(1),U,4)) Q
Q:'$D(^LRO(69,DT,1,LRSN,2,0)) Q:'$$GOT(DT,LRSN)
S LRSAMP=$P(^LRO(69,DT,1,LRSN,0),U,3),LRLLOC=$E($P(^(0),U,7),1,30),LROLLOC=$P(^(0),U,9)
S X=^LR(LRDFN,0),LRDPF=$P(X,U,2) I LRDPF=2,$D(^DPT(+$P(X,U,3),.1)) S LRLLOC=^(.1) D DPT^LRWU S $P(^LRO(69,DT,1,LRSN,0),U,7)=$S($L(LRLLOC):LRLLOC,1:"UNKNOWN")
1 S:'$L(LRLLOC) LRLLOC="UNKNOWN" Q:LRSAMP<1 S ^LRO(69,DT,1,"AD",LRLLOC,LRDFN,LRSN)=""
S I=0 F S I=$O(^LRO(69,DT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) I '$P(X,"^",6),'$P(X,"^",11) S T(LRSAMP,+X,LRSN)=I_U_$P(X,U,2)
Q
END Q ;BACK TO LRPHSET
GOT(ODT,SN) ;See if all tests have been canceled
N I S GOT=0
I $D(^LRO(69,ODT,1,SN)) S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
Q GOT
LRPHSET1 ; VA/SLC/CJS - COLLECTION LIST TO ACCESSIONS ; 17-Oct-2014 09:23 ; MKK
+1 ;;5.2;LAB SERVICE;**121,191,221,1015,240,1018,423,1034**;NOV 01, 1997;Build 104
+2 QUIT
EN ;from LRPHSET
+1 KILL ^LRO(69,DT,1,"AD")
SET $PIECE(^LAB(69.9,1,5),"^",10,12)=1_"^"_$HOROLOG_"^"_$SELECT($DATA(DUZ):DUZ,1:"")
+2 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LRO(69,DT,1,"AA",LRDFN))
IF LRDFN<1
QUIT
KILL T
DO S6
+3 SET LRLOC=""
SET LRCOUNT=0
SET LRDUZ(2)=$SELECT($DATA(DUZ(2)):DUZ(2),1:"")
FOR LRPH=0:0
SET LRLOC=$ORDER(^LRO(69,DT,1,"AD",LRLOC))
IF LRLOC=""
QUIT
DO S4
+4 SET $PIECE(^LAB(69.9,1,5),"^",10)=0
+5 GOTO END
S4 KILL DIC
SET D="C"
SET X=LRLOC
SET DIC(0)="Z"
SET DIC=44
DO IX^DIC
SET LRDUZ(2)=$SELECT(Y<1:DUZ(2),1:$SELECT($PIECE(Y(0),U,4):$PIECE(Y(0),U,4),1:DUZ(2)))
+1 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LRO(69,DT,1,"AD",LRLOC,LRDFN))
IF LRDFN<1
QUIT
DO S4A
+2 QUIT
S4A SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,DT,1,"AD",LRLOC,LRDFN,LRSN))
IF LRSN<1
QUIT
IF $DATA(^LRO(69,DT,1,LRSN,1))
DO S4C
IF '($DATA(^LRO(69,DT,1,LRSN,1))#2)&($DATA(^(0)))
DO S4B
+1 QUIT
S4B SET X=^LRO(69,DT,1,LRSN,0)
IF $PIECE(X,U,4)="LC"
IF LRDFN=+X
IF $PIECE(X,U,8)'>LRDTI
IF $$GOT(DT,LRSN)
SET LRCOUNT=LRCOUNT+1
DO S5
+1 QUIT
S4C IF $PIECE(^LRO(69,DT,1,LRSN,1),U)'>LRDTI
SET X=^(0)
IF $PIECE(X,U,4)="LC"
IF LRDFN=+X
IF $PIECE(X,U,8)'>LRDTI
DO S5
+1 QUIT
S5 SET ^LRO(69,DT,1,"AC",LRLOC,LRSN)=1
SET LRSCR=$SELECT($DATA(^LRO(69,DT,1,LRSN,1)):$PIECE(^(1),U,3,99),1:"")
SET ^(1)=LRDTI_"^1^"_LRSCR
SET LRTJ=$PIECE(^(0),U,3,4)_"^"_DT
SET LRSAMP=$PIECE(LRTJ,U,1)
+1 SET LRSPEC=$PIECE(^LAB(62,LRSAMP,0),U,2)
SET I=$ORDER(^LRO(69,DT,1,LRSN,6,0))
KILL LRSPCDSC
IF I
SET LRSPCDSC=^(I,0)
+2 IF $DATA(^LRO(69,DT,1,LRSN,1))
IF '$LENGTH($PIECE(^(1),U,4))
IF $DATA(^(3))
SET LRLLOC=$PIECE(^LRO(69,DT,1,LRSN,0),U,7)
SET LROLLOC=$PIECE(^(0),U,9)
DO REUP^LRPHSET2
+3 DO OLD^LRORDST
KILL LRTJ
QUIT
S6 SET T=""
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,DT,1,"AA",LRDFN,LRSN))
IF LRSN<1
QUIT
DO S6A
+1 SET LRSAMP=0
FOR
SET LRSAMP=$ORDER(T(LRSAMP))
IF LRSAMP<1
QUIT
SET LRSTEP=0
DO S7^LRPHSET2
SET LRSTEP=1
DO S7^LRPHSET2
+2 QUIT
S6A IF '$SELECT($DATA(^LRO(69,DT,1,LRSN,0)):$LENGTH($PIECE(^(0),U,2)),1:0)
QUIT
+1 IF $PIECE(^LRO(69,DT,1,LRSN,0),U,4)'="LC"
QUIT
IF $PIECE(^(0),U,8)>LRDTI
QUIT
IF $DATA(^(1))
IF $LENGTH($PIECE(^(1),U,4))
QUIT
+2 IF '$DATA(^LRO(69,DT,1,LRSN,2,0))
QUIT
IF '$$GOT(DT,LRSN)
QUIT
+3 SET LRSAMP=$PIECE(^LRO(69,DT,1,LRSN,0),U,3)
SET LRLLOC=$EXTRACT($PIECE(^(0),U,7),1,30)
SET LROLLOC=$PIECE(^(0),U,9)
+4 SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
IF LRDPF=2
IF $DATA(^DPT(+$PIECE(X,U,3),.1))
SET LRLLOC=^(.1)
DO DPT^LRWU
SET $PIECE(^LRO(69,DT,1,LRSN,0),U,7)=$SELECT($LENGTH(LRLLOC):LRLLOC,1:"UNKNOWN")
1 IF '$LENGTH(LRLLOC)
SET LRLLOC="UNKNOWN"
IF LRSAMP<1
QUIT
SET ^LRO(69,DT,1,"AD",LRLLOC,LRDFN,LRSN)=""
+1 SET I=0
FOR
SET I=$ORDER(^LRO(69,DT,1,LRSN,2,I))
IF I<1
QUIT
SET X=^(I,0)
IF '$PIECE(X,"^",6)
IF '$PIECE(X,"^",11)
SET T(LRSAMP,+X,LRSN)=I_U_$PIECE(X,U,2)
+2 QUIT
END ;BACK TO LRPHSET
QUIT
GOT(ODT,SN) ;See if all tests have been canceled
+1 NEW I
SET GOT=0
+2 IF $DATA(^LRO(69,ODT,1,SN))
SET I=0
FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,I))
IF I<1
QUIT
IF $DATA(^(I,0))
IF '$PIECE(^(0),"^",11)
SET GOT=1
QUIT
+3 QUIT GOT
