LR7OMERG ;VA/SLC/DCM,BNM,FHS-MERGE ACCESSION ;8/11/97
;;5.2;LAB SERVICE;**1003,1024,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 121,221,386
;
EN ;Merge 2 accessions together
D END
EN1 S COMP=0,LRACC=1 W !!,"Merge from..." D LRACC^LRTSTOUT Q:LRAN<1
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 W !?5,"This is not a valid Accession number ",!,$C(7) G EN1
L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !?5,"Someone else is editing this entry ",!,$C(7) G EN1
S LRSS=$P(^LRO(68,LRAA,0),"^",2),(LRX1,X)=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT1=$P($G(^(3)),"^",5),SPEC1=$O(^(5,0)),SPEC1=$G(^(SPEC1,0))
S LRDFN=$P(X,U),LRAODT=$P(X,U,3),LR1ODT=$P(X,U,4),LR1SN=$P(X,U,5),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W ?35,PNM,?65,SSN
D WRITE(LRAA,LRAD,LRAN,+SPEC1,.COMP,.LRT1SAD)
S LR1AA=LRAA,LR1AD=LRAD,LR1AN=LRAN
2 S LRACC=1 W !!,"Merge into..." D LRACC^LRTSTOUT I LRAN<1 D UL1 Q
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 W !?5,"This is not a valid Accession number ",!,$C(7) G 2
I LRAA=LR1AA,LRAD=LR1AD,LRAN=LR1AN W !!,$C(7),"Cannot merge into the same accession" G 2
I $P(^LRO(68,LRAA,0),"^",2)'=LRSS W !!,$C(7),"Cannot merge a """_LRSS_""" accession into a """_$P(^(0),"^",2)_""" accession" G EN
L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !?5,"Someone else is editing this entry ",!,$C(7) G 2
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRORD=$G(^(.1)),LRIDT=$P($G(^(3)),"^",5),LRTOACC=$G(^(.1))_"/"_$G(^(.2)),SPEC=$O(^(5,0)),SPEC=$G(^(SPEC,0))
S LRCCOM="*Merge to:"_LRTOACC,LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
S LRDFN=$P(X,U),LRAODT=$P(X,U,3),LRODT=$P(X,U,4),LRSN=$P(X,U,5),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W ?35,PNM,?65,SSN
I +X'=+LRX1 W !!,$C(7),"Cannot merge accessions for different patients!" D UL2 G EN
D WRITE(LRAA,LRAD,LRAN,+SPEC,.COMP,.LRTSAD)
I +SPEC'=+SPEC1 W !!,$C(7),"Cannot merge accessions with different specimens" D UL2 G EN
I COMP W !!,$C(7),"Cannot merge accessions with completed results" D UL2 G EN
W ! S I=0 F S I=$O(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,4,I)) Q:I<1 I $D(^LAB(60,I,8,+DUZ(2),0)) S J=$P(^LAB(60,I,8,+DUZ(2),0),U,2) I J,J'=LRAA D
. W !,"<<"_$P(^LAB(60,I,0),"^")_" normally belongs to accession area: "_$P(^LRO(68,J,0),"^")_">>",$C(7)
OK S %=2 W !!,"Ok to merge" D YN^DICN
I %=0 W !!,"Enter 'Yes' to merge these accessions, 'No' to abort." G OK
I %'=1 W !!,"NOTHING MERGED!",! D UL1,UL2 Q
N LRLFTOVR,URG,LRTSORU,LRNLT,LRII
D CHK(.LRT1SAD,.LRTSAD,.LRLFTOVR)
S LRII=0 F S LRII=$O(LRT1SAD(LRII)) Q:LRII<1 S X=LRT1SAD(LRII),URG=$P(X,"^",2),LRTSORU=$P(X,U,9) D
. I '$D(LRTSORU(LRTSORU)) D ORUT^LRWLST11
. S LRTSORU(LRTSORU)=""
. I $D(LRLFTOVR(LRII)) D
.. I $O(^LAB(60,LRII,2,0)) D Q
... N ARAT,SAME,SUB
... S J=0 F S J=$O(^LAB(60,LRII,2,J)) Q:J<1 S ARAT(+^(J,0))=""
... D CHK(.ARAT,.LRTSAD,.SUB)
... S SAME=1,J=0 F S J=$O(^LAB(60,LRII,2,J)) Q:J<1 I '$D(SUB(+^(J,0))) S SAME=0 Q
... I SAME D SET68(LRII,URG,LRTSORU),SET69(LRODT,LRSN,LRII,URG,LRAA,LRAODT,LRAN) Q
... S J=0 F S J=$O(SUB(J)) Q:J<1 D SET68(J,URG,LRTSORU),SET69(LRODT,LRSN,J,URG,LRAA,LRAD,LRAN)
.. D SET68(LRII,URG,LRTSORU),SET69(LRODT,LRSN,LRII,URG,LRAA,LRAD,LRAN)
S X=^LRO(68,LR1AA,1,LR1AD,1,LR1AN,0),LROSN=$P(X,U,5),LROID=$P(X,U,6),LROCN=$S($D(^(.1)):$P(^(.1),U),1:"")
S LRCWDT=$S($D(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,9)):^(9),1:LR1AD),LROWDT=$P(^(0),U,3),LROWDT=$S($D(^LRO(68,LR1AA,1,LROWDT,1,LR1AN,0)):LROWDT,1:LR1AD)
D ZAP(LR1ODT,LR1SN,LR1AA,LR1AD,LR1AN,LRIDT1,1)
I '$D(^LRO(68,LR1AA,1,LR1AD,1,LR1AN)) D
. I $D(^LR(LRDFN,LRSS,LRIDT)),$D(^(LRIDT1,1)) M ^LR(LRDFN,LRSS,LRIDT,1)=^LR(LRDFN,LRSS,LRIDT1,1)
D UL1,UL2
W !!,"Accessions merged!"
W !!,"Accession #"_LRAN_" now looks like:" D WRITE(LRAA,LRAD,LRAN,+SPEC)
S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U) D:X EN^LA7ADL(X)
D END
W !,"Merge another accession" S %=1 D YN^DICN I %=1 G EN1
Q
ZAP(LRODT,LRSN,LRAA,LRAD,LRAN,LRIDT,LRMERG) ;
Q:'$D(^LRO(69,LRODT,1,LRSN,0))#2
S LRNOW=$$NOW^XLFDT
S LRTSTS=0 F S LRTSTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 D
. S LRTNM=$P($G(^LAB(60,LRTSTS,0)),U)
. D SET^LRTSTOUT
Q
PRAC(LRAA,LRAD,LRAN,Y) ;Find all ordering providers for a given accession
N LRODT,LRSN,I,PROV,X
Q:'$D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)) S X=^(0),PROV=$P(X,"^",8)
S LRODT=$P(X,"^",4),LRSN=$P(X,"^",5)
; ----- BEGIN IHS/OIT/MKK LR*5.2*1024 MODIFICATION
; Make sure variables are valid; if not, skip
Q:$G(LRODT)=""!($G(LRSN)="")!($G(PROV)="")
; ----- END IHS/OIT/MKK LR*5.2*1024
Q:'$D(^LRO(69,+LRODT,1,+LRSN,0)) S:$P(^(0),"^",6)'=PROV Y($P(^(0),"^",6))=""
S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X=$P(^(I,0),"^",14) D
. I X,$D(^LRO(69,+X,1,+$P(X,";",2),0)),$P(^(0),"^",6)'=PROV S Y($P(^(0),"^",6))=""
Q
UL2 ;Unlock 2nd accession
L -^LRO(68,LRAA,1,LRAD,1,LRAN)
Q
UL1 ;Unlock 1st accession
L -^LRO(68,LR1AA,1,LR1AD,1,LR1AN)
Q
CHK(ARAY1,ARAY2,OUT) ;Check for duplicate tests on accessions
;ARAY1(tst)=test aray from accession being merged
;ARAY2(tst)=test aray from accession being merged to
;Output [OUT] is an array of tests from ARAY1 that are not duplicated in ARAY2
Q:'$O(ARAY2(0))
N IN2,I
S I=0 F S I=$O(ARAY1(I)) Q:I<1 I '$D(ARAY2(I)) S OUT(I)=ARAY1(I)
S I=0 F S I=$O(ARAY2(I)) Q:I<1 D EXPAND^LR7OU1(I,.IN2)
S I=0 F S I=$O(OUT(I)) Q:I<1 I $D(IN2(I)) K OUT(I)
Q
WRITE(AA,AD,AN,SP,COMP,ARAY) ;Display accession with tests
;AA=Accession area, AD=Accession Date, AN=Accession #, SP=ptr to 61 specimen
;COMP=1 (returned) if all tests on accession are complete
;ARAY(TST) (returned) for all tests on accession
Q:'$D(^LRO(68,+$G(AA),1,+$G(AD),1,+$G(AN))) W:$L($P($G(^(+AN,.3)),U)) !,"UID: ",$P(^(.3),U)
W !,$S($D(^LAB(61,+$G(SP),0)):$P(^(0),"^"),1:""),?35,"TESTS ON ACCESSION: "
S I=0 F S I=$O(^LRO(68,AA,1,AD,1,AN,4,I)) Q:I<1 S ARAY(I)=^(I,0) W !,?40,$P(^LAB(60,I,0),U) I $P(ARAY(I),"^",5) W ?65,$S($L($P(ARAY(I),U,6)):$P(ARAY(I),U,6),1:" Verified") S COMP=1
Q
SET68(LRTSTS,URG,LRPRIM) ;Set file 68
Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)=LRTSTS_"^"_URG,$P(^(0),U,9)=LRPRIM
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRTSTS,+LRTSTS)=""
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",3)=LRTSTS,$P(^(0),"^",4)=$P(^(0),"^",4)+1
Q
SET69(LRODT,LRSN,LRTS,LRURG,LRAA,LRAODT,LRAN) ;Set file 69
N X,Y,LRFLG,LRNATURE,LRPHSET,LRXDA,DA,DIC,DIE,DR,DLAYGO
S (LRFLG,LRPHSET)=1,LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
S DIC(0)="LOX",DLAYGO=69,X=$P($G(^LAB(60,LRTS,0)),U)
D ^DIC Q:'$P(Y,U,3)
D 69^LRTSTSET
Q
END ;
K COMP,X,X1,I,J,LRACC,LRSS,LRIDT,LRIDT1,LRORD,LRX1,LRAA,LRAD,LRAN,LR1AA,LR1AD,LR1AN,LR1ODT
K LR1SN,TST,LRDFN,SPEC,SPEC1,DA,LREND,LRIDIV,LRX,LRAODT,LRDPF,LRODT,LRPRAC,LRRB,LRSN,LRTREA,LRTSAD,LRT1SAD,LRWRD,LRF,LRCWDT,LROWDT,LROSN,LROID,LROCN
K PNM,SEX,SSN,Y,DOB,DFN,LRWRD,VA,VADM,VAIN,VA200,VAERR,LRTOACC
D KVA^VADPT
K AGE,D0,DI,IFN,LRNOW,LRNLT,LRNATURE,LRLLOC,LRLFTOVR,LRII,LRCCOM
K LRAGE,LRTNM,LRTSORU,LRTSTS,URG
Q
LR7OMERG ;VA/SLC/DCM,BNM,FHS-MERGE ACCESSION ;8/11/97
+1 ;;5.2;LAB SERVICE;**1003,1024,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 121,221,386
+4 ;
EN ;Merge 2 accessions together
+1 DO END
EN1 SET COMP=0
SET LRACC=1
WRITE !!,"Merge from..."
DO LRACC^LRTSTOUT
IF LRAN<1
QUIT
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
GOTO EN1
+2 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):1
IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
GOTO EN1
+3 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
SET (LRX1,X)=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRIDT1=$PIECE($GET(^(3)),"^",5)
SET SPEC1=$ORDER(^(5,0))
SET SPEC1=$GET(^(SPEC1,0))
+4 SET LRDFN=$PIECE(X,U)
SET LRAODT=$PIECE(X,U,3)
SET LR1ODT=$PIECE(X,U,4)
SET LR1SN=$PIECE(X,U,5)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE ?35,PNM,?65,SSN
+5 DO WRITE(LRAA,LRAD,LRAN,+SPEC1,.COMP,.LRT1SAD)
+6 SET LR1AA=LRAA
SET LR1AD=LRAD
SET LR1AN=LRAN
2 SET LRACC=1
WRITE !!,"Merge into..."
DO LRACC^LRTSTOUT
IF LRAN<1
DO UL1
QUIT
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
GOTO 2
+2 IF LRAA=LR1AA
IF LRAD=LR1AD
IF LRAN=LR1AN
WRITE !!,$CHAR(7),"Cannot merge into the same accession"
GOTO 2
+3 IF $PIECE(^LRO(68,LRAA,0),"^",2)'=LRSS
WRITE !!,$CHAR(7),"Cannot merge a """_LRSS_""" accession into a """_$PIECE(^(0),"^",2)_""" accession"
GOTO EN
+4 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):1
IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
GOTO 2
+5 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRORD=$GET(^(.1))
SET LRIDT=$PIECE($GET(^(3)),"^",5)
SET LRTOACC=$GET(^(.1))_"/"_$GET(^(.2))
SET SPEC=$ORDER(^(5,0))
SET SPEC=$GET(^(SPEC,0))
+6 SET LRCCOM="*Merge to:"_LRTOACC
SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+7 SET LRDFN=$PIECE(X,U)
SET LRAODT=$PIECE(X,U,3)
SET LRODT=$PIECE(X,U,4)
SET LRSN=$PIECE(X,U,5)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE ?35,PNM,?65,SSN
+8 IF +X'=+LRX1
WRITE !!,$CHAR(7),"Cannot merge accessions for different patients!"
DO UL2
GOTO EN
+9 DO WRITE(LRAA,LRAD,LRAN,+SPEC,.COMP,.LRTSAD)
+10 IF +SPEC'=+SPEC1
WRITE !!,$CHAR(7),"Cannot merge accessions with different specimens"
DO UL2
GOTO EN
+11 IF COMP
WRITE !!,$CHAR(7),"Cannot merge accessions with completed results"
DO UL2
GOTO EN
+12 WRITE !
SET I=0
FOR
SET I=$ORDER(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,4,I))
IF I<1
QUIT
IF $DATA(^LAB(60,I,8,+DUZ(2),0))
SET J=$PIECE(^LAB(60,I,8,+DUZ(2),0),U,2)
IF J
IF J'=LRAA
Begin DoDot:1
+13 WRITE !,"<<"_$PIECE(^LAB(60,I,0),"^")_" normally belongs to accession area: "_$PIECE(^LRO(68,J,0),"^")_">>",$CHAR(7)
End DoDot:1
OK SET %=2
WRITE !!,"Ok to merge"
DO YN^DICN
+1 IF %=0
WRITE !!,"Enter 'Yes' to merge these accessions, 'No' to abort."
GOTO OK
+2 IF %'=1
WRITE !!,"NOTHING MERGED!",!
DO UL1
DO UL2
QUIT
+3 NEW LRLFTOVR,URG,LRTSORU,LRNLT,LRII
+4 DO CHK(.LRT1SAD,.LRTSAD,.LRLFTOVR)
+5 SET LRII=0
FOR
SET LRII=$ORDER(LRT1SAD(LRII))
IF LRII<1
QUIT
SET X=LRT1SAD(LRII)
SET URG=$PIECE(X,"^",2)
SET LRTSORU=$PIECE(X,U,9)
Begin DoDot:1
+6 IF '$DATA(LRTSORU(LRTSORU))
DO ORUT^LRWLST11
+7 SET LRTSORU(LRTSORU)=""
+8 IF $DATA(LRLFTOVR(LRII))
Begin DoDot:2
+9 IF $ORDER(^LAB(60,LRII,2,0))
Begin DoDot:3
+10 NEW ARAT,SAME,SUB
+11 SET J=0
FOR
SET J=$ORDER(^LAB(60,LRII,2,J))
IF J<1
QUIT
SET ARAT(+^(J,0))=""
+12 DO CHK(.ARAT,.LRTSAD,.SUB)
+13 SET SAME=1
SET J=0
FOR
SET J=$ORDER(^LAB(60,LRII,2,J))
IF J<1
QUIT
IF '$DATA(SUB(+^(J,0)))
SET SAME=0
QUIT
+14 IF SAME
DO SET68(LRII,URG,LRTSORU)
DO SET69(LRODT,LRSN,LRII,URG,LRAA,LRAODT,LRAN)
QUIT
+15 SET J=0
FOR
SET J=$ORDER(SUB(J))
IF J<1
QUIT
DO SET68(J,URG,LRTSORU)
DO SET69(LRODT,LRSN,J,URG,LRAA,LRAD,LRAN)
End DoDot:3
QUIT
+16 DO SET68(LRII,URG,LRTSORU)
DO SET69(LRODT,LRSN,LRII,URG,LRAA,LRAD,LRAN)
End DoDot:2
End DoDot:1
+17 SET X=^LRO(68,LR1AA,1,LR1AD,1,LR1AN,0)
SET LROSN=$PIECE(X,U,5)
SET LROID=$PIECE(X,U,6)
SET LROCN=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")
+18 SET LRCWDT=$SELECT($DATA(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,9)):^(9),1:LR1AD)
SET LROWDT=$PIECE(^(0),U,3)
SET LROWDT=$SELECT($DATA(^LRO(68,LR1AA,1,LROWDT,1,LR1AN,0)):LROWDT,1:LR1AD)
+19 DO ZAP(LR1ODT,LR1SN,LR1AA,LR1AD,LR1AN,LRIDT1,1)
+20 IF '$DATA(^LRO(68,LR1AA,1,LR1AD,1,LR1AN))
Begin DoDot:1
+21 IF $DATA(^LR(LRDFN,LRSS,LRIDT))
IF $DATA(^(LRIDT1,1))
MERGE ^LR(LRDFN,LRSS,LRIDT,1)=^LR(LRDFN,LRSS,LRIDT1,1)
End DoDot:1
+22 DO UL1
DO UL2
+23 WRITE !!,"Accessions merged!"
+24 WRITE !!,"Accession #"_LRAN_" now looks like:"
DO WRITE(LRAA,LRAD,LRAN,+SPEC)
+25 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
IF X
DO EN^LA7ADL(X)
+26 DO END
+27 WRITE !,"Merge another accession"
SET %=1
DO YN^DICN
IF %=1
GOTO EN1
+28 QUIT
ZAP(LRODT,LRSN,LRAA,LRAD,LRAN,LRIDT,LRMERG) ;
+1 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))#2
QUIT
+2 SET LRNOW=$$NOW^XLFDT
+3 SET LRTSTS=0
FOR
SET LRTSTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
IF LRTSTS<1
QUIT
Begin DoDot:1
+4 SET LRTNM=$PIECE($GET(^LAB(60,LRTSTS,0)),U)
+5 DO SET^LRTSTOUT
End DoDot:1
+6 QUIT
PRAC(LRAA,LRAD,LRAN,Y) ;Find all ordering providers for a given accession
+1 NEW LRODT,LRSN,I,PROV,X
+2 IF '$DATA(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0))
QUIT
SET X=^(0)
SET PROV=$PIECE(X,"^",8)
+3 SET LRODT=$PIECE(X,"^",4)
SET LRSN=$PIECE(X,"^",5)
+4 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1024 MODIFICATION
+5 ; Make sure variables are valid; if not, skip
+6 IF $GET(LRODT)=""!($GET(LRSN)="")!($GET(PROV)="")
QUIT
+7 ; ----- END IHS/OIT/MKK LR*5.2*1024
+8 IF '$DATA(^LRO(69,+LRODT,1,+LRSN,0))
QUIT
IF $PIECE(^(0),"^",6)'=PROV
SET Y($PIECE(^(0),"^",6))=""
+9 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,I))
IF I<1
QUIT
SET X=$PIECE(^(I,0),"^",14)
Begin DoDot:1
+10 IF X
IF $DATA(^LRO(69,+X,1,+$PIECE(X,";",2),0))
IF $PIECE(^(0),"^",6)'=PROV
SET Y($PIECE(^(0),"^",6))=""
End DoDot:1
+11 QUIT
UL2 ;Unlock 2nd accession
+1 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+2 QUIT
UL1 ;Unlock 1st accession
+1 LOCK -^LRO(68,LR1AA,1,LR1AD,1,LR1AN)
+2 QUIT
CHK(ARAY1,ARAY2,OUT) ;Check for duplicate tests on accessions
+1 ;ARAY1(tst)=test aray from accession being merged
+2 ;ARAY2(tst)=test aray from accession being merged to
+3 ;Output [OUT] is an array of tests from ARAY1 that are not duplicated in ARAY2
+4 IF '$ORDER(ARAY2(0))
QUIT
+5 NEW IN2,I
+6 SET I=0
FOR
SET I=$ORDER(ARAY1(I))
IF I<1
QUIT
IF '$DATA(ARAY2(I))
SET OUT(I)=ARAY1(I)
+7 SET I=0
FOR
SET I=$ORDER(ARAY2(I))
IF I<1
QUIT
DO EXPAND^LR7OU1(I,.IN2)
+8 SET I=0
FOR
SET I=$ORDER(OUT(I))
IF I<1
QUIT
IF $DATA(IN2(I))
KILL OUT(I)
+9 QUIT
WRITE(AA,AD,AN,SP,COMP,ARAY) ;Display accession with tests
+1 ;AA=Accession area, AD=Accession Date, AN=Accession #, SP=ptr to 61 specimen
+2 ;COMP=1 (returned) if all tests on accession are complete
+3 ;ARAY(TST) (returned) for all tests on accession
+4 IF '$DATA(^LRO(68,+$GET(AA),1,+$GET(AD),1,+$GET(AN)))
QUIT
IF $LENGTH($PIECE($GET(^(+AN,.3)),U))
WRITE !,"UID: ",$PIECE(^(.3),U)
+5 WRITE !,$SELECT($DATA(^LAB(61,+$GET(SP),0)):$PIECE(^(0),"^"),1:""),?35,"TESTS ON ACCESSION: "
+6 SET I=0
FOR
SET I=$ORDER(^LRO(68,AA,1,AD,1,AN,4,I))
IF I<1
QUIT
SET ARAY(I)=^(I,0)
WRITE !,?40,$PIECE(^LAB(60,I,0),U)
IF $PIECE(ARAY(I),"^",5)
WRITE ?65,$SELECT($LENGTH($PIECE(ARAY(I),U,6)):$PIECE(ARAY(I),U,6),1:" Verified")
SET COMP=1
+7 QUIT
SET68(LRTSTS,URG,LRPRIM) ;Set file 68
+1 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
QUIT
+2 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)=LRTSTS_"^"_URG
SET $PIECE(^(0),U,9)=LRPRIM
+3 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRTSTS,+LRTSTS)=""
+4 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",3)=LRTSTS
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+5 QUIT
SET69(LRODT,LRSN,LRTS,LRURG,LRAA,LRAODT,LRAN) ;Set file 69
+1 NEW X,Y,LRFLG,LRNATURE,LRPHSET,LRXDA,DA,DIC,DIE,DR,DLAYGO
+2 SET (LRFLG,LRPHSET)=1
SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+3 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DA(2)=LRODT
SET DA(1)=LRSN
+4 SET DIC(0)="LOX"
SET DLAYGO=69
SET X=$PIECE($GET(^LAB(60,LRTS,0)),U)
+5 DO ^DIC
IF '$PIECE(Y,U,3)
QUIT
+6 DO 69^LRTSTSET
+7 QUIT
END ;
+1 KILL COMP,X,X1,I,J,LRACC,LRSS,LRIDT,LRIDT1,LRORD,LRX1,LRAA,LRAD,LRAN,LR1AA,LR1AD,LR1AN,LR1ODT
+2 KILL LR1SN,TST,LRDFN,SPEC,SPEC1,DA,LREND,LRIDIV,LRX,LRAODT,LRDPF,LRODT,LRPRAC,LRRB,LRSN,LRTREA,LRTSAD,LRT1SAD,LRWRD,LRF,LRCWDT,LROWDT,LROSN,LROID,LROCN
+3 KILL PNM,SEX,SSN,Y,DOB,DFN,LRWRD,VA,VADM,VAIN,VA200,VAERR,LRTOACC
+4 DO KVA^VADPT
+5 KILL AGE,D0,DI,IFN,LRNOW,LRNLT,LRNATURE,LRLLOC,LRLFTOVR,LRII,LRCCOM
+6 KILL LRAGE,LRTNM,LRTSORU,LRTSTS,URG
+7 QUIT
