LR7OMERG.m

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