- 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
