LR7OMERG ;DALOI/STAFF-MERGE ACCESSION ;Jul 04, 2023@16:45
;;5.2;LAB SERVICE;**121,221,386,350,445,566**;Sep 27, 1994;Build 12
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
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):DILOCKTM 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):DILOCKTM 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 D
. S J=$P($G(^LAB(60,I,8,+DUZ(2),0)),U,2)
. I J,J'=LRAA 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
;
;LR*5.2*566 new LRSOF
N LRLFTOVR,LRORDTYP,LRTSORU,LRNLT,LRII,URG,LRSOF
; Set order type to (R)evised
S $P(LRORDTYP,"^",2)=$$FIND1^DIC(64.061,"","OX","R","D","I $P(^(0),U,5)=""0065""")
;
D CHK(.LRT1SAD,.LRTSAD,.LRLFTOVR)
S LRII=0
F S LRII=$O(LRT1SAD(LRII)) Q:LRII<1 D
. S X=LRT1SAD(LRII),URG=$P(X,"^",2),LRTSORU=$P(X,U,9)
. I '$D(LRTSORU(LRTSORU)) D ;Set variables for call to update ORUT node in #63
. . N LRORIFN,LRPRAC,LRSAMP,LRSPEC,LRURG,LRX
. . S LRX=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRII,0))
. . S LRORIFN=$S(LRX>0:$P($G(^LRO(69,LR1ODT,1,LR1SN,2,LRX,0)),U,7),1:"")
. . S LRPRAC=$P($G(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,0)),U,8)
. . S LRURG=URG,LRSPEC=$P(SPEC,U),LRSAMP=$P(SPEC,U,2)
. . 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
. . . ;LR*5.2*566: Replace variable J with LRSUBJ to prevent errors when downstream
. . . ; logic kills J.
. . . N LRSUBJ
. . . S LRSUBJ=0
. . . F S LRSUBJ=$O(SUB(LRSUBJ)) Q:LRSUBJ<1 D SET68(LRSUBJ,URG,LRTSORU),SET69(LRODT,LRSN,LRSUBJ,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)
;
; Release locks
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)
I X'="" D 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) ;
;
;LR*5.2*566: initialize LRCOMX and LRORDTST
N LRNOW,LRTNM,LRTSTS,LRCOMX,LRORDTST
;
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)
I LRODT=""!(LRSN="") Q
Q:'$D(^LRO(69,+LRODT,1,+LRSN,0)) I $P(^(0),"^",6),$P(^(0),"^",6)'=PROV S 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
;
;ZEXCEPT: LRAA,LRAD,LRAN
;
L -^LRO(68,LRAA,1,LRAD,1,LRAN)
Q
;
;
UL1 ;Unlock 1st accession
;
;ZEXCEPT: LR1AA,LR1AD,LR1AN
;
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
;
N I
;
Q:'$D(^LRO(68,+$G(AA),1,+$G(AD),1,+$G(AN)))
I $P($G(^LRO(68,+$G(AA),1,+$G(AD),1,+$G(AN),.3)),U)'="" W !,"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 D
. I $P($G(^LAB(60,I,0)),"^",4)="WK" Q ; Don't include workload tests.
. S ARAY(I)=^LRO(68,AA,1,AD,1,AN,4,I,0)
. W !,?40,$P(^LAB(60,I,0),U)
. I $P(ARAY(I),"^",5) W ?65,$S($P(ARAY(I),U,6)'="":$P(ARAY(I),U,6),1:" Verified") S COMP=1
Q
;
;
SET68(LRTSTS,URG,LRPRIM) ;Set file 68
;
;ZEXCEPT: LRAA,LRAD,LRAN
;
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 DA,DIC,DIE,DINUM,DO,DR,LRFLG,LRNATURE,LRPHSET,LRXDA,X,Y
;
S (LRFLG,LRPHSET)=1,LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
;
; Test already on order - update order with merged accession info when merging accession on same order entry (LRODT, LRSN)
I $D(^LRO(69,LRODT,1,LRSN,2,"B",LRTS)) D Q
. N LRDIE,LRFDA,LRIENS,LRXDA
. S LRSOF=1 ;set same order flag for LRTSTOUT
. S LRXDA=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTS,0)),LRIENS=LRXDA_","_LRSN_","_LRODT_","
. S LRXDA(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
. S LRFDA(1,69.03,LRIENS,2)=LRAODT
. S LRFDA(1,69.03,LRIENS,3)=LRAA
. S LRFDA(1,69.03,LRIENS,4)=LRAN
. I $P(LRXDA(3),"^")'="" S LRFDA(1,69.03,LRIENS,13)=$P(LRXDA(3),"^")
. D FILE^DIE("","LRFDA(1)","LRDIE(1)")
;
; Add stub entry for new test.
S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
S DIC(0)="F",X=+LRTS
D FILE^DICN
;
; Update new entry
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OMERG 8914 printed Dec 13, 2024@02:05:15 Page 2
LR7OMERG ;DALOI/STAFF-MERGE ACCESSION ;Jul 04, 2023@16:45
+1 ;;5.2;LAB SERVICE;**121,221,386,350,445,566**;Sep 27, 1994;Build 12
+2 ;
+3 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+4 ; used in conjunction with Eclipse M-editor.
+5 ;
EN ;Merge 2 accessions together
+1 DO END
+2 ;
EN1 ;
+1 SET COMP=0
SET LRACC=1
+2 WRITE !!,"Merge from..."
DO LRACC^LRTSTOUT
if LRAN<1
QUIT
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
GOTO EN1
+4 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):DILOCKTM
IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
GOTO EN1
+5 ;
+6 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))
+7 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)
+8 DO PT^LRX
+9 WRITE ?35,PNM,?65,SSN
+10 DO WRITE(LRAA,LRAD,LRAN,+SPEC1,.COMP,.LRT1SAD)
+11 SET LR1AA=LRAA
SET LR1AD=LRAD
SET LR1AN=LRAN
+12 ;
2 ;
+1 SET LRACC=1
WRITE !!,"Merge into..."
DO LRACC^LRTSTOUT
IF LRAN<1
DO UL1
QUIT
+2 ;
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
WRITE !?5,"This is not a valid Accession number ",!,$CHAR(7)
GOTO 2
+4 IF LRAA=LR1AA
IF LRAD=LR1AD
IF LRAN=LR1AN
WRITE !!,$CHAR(7),"Cannot merge into the same accession"
GOTO 2
+5 IF $PIECE(^LRO(68,LRAA,0),"^",2)'=LRSS
WRITE !!,$CHAR(7),"Cannot merge a """_LRSS_""" accession into a """_$PIECE(^(0),"^",2)_""" accession"
GOTO EN
+6 ;
+7 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):DILOCKTM
IF '$TEST
WRITE !?5,"Someone else is editing this entry ",!,$CHAR(7)
GOTO 2
+8 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))
+9 SET LRCCOM="*Merge to:"_LRTOACC
SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+10 ;
+11 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
+12 IF +X'=+LRX1
WRITE !!,$CHAR(7),"Cannot merge accessions for different patients!"
DO UL2
GOTO EN
+13 ;
+14 DO WRITE(LRAA,LRAD,LRAN,+SPEC,.COMP,.LRTSAD)
+15 ;
+16 IF +SPEC'=+SPEC1
WRITE !!,$CHAR(7),"Cannot merge accessions with different specimens"
DO UL2
GOTO EN
+17 IF COMP
WRITE !!,$CHAR(7),"Cannot merge accessions with completed results"
DO UL2
GOTO EN
+18 ;
+19 WRITE !
+20 SET I=0
+21 FOR
SET I=$ORDER(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,4,I))
if I<1
QUIT
Begin DoDot:1
+22 SET J=$PIECE($GET(^LAB(60,I,8,+DUZ(2),0)),U,2)
+23 IF J
IF J'=LRAA
WRITE !,"<<"_$PIECE(^LAB(60,I,0),"^")_" normally belongs to accession area: "_$PIECE(^LRO(68,J,0),"^")_">>",$CHAR(7)
End DoDot:1
+24 ;
+25 ;
OK ;
+1 SET %=2
WRITE !!,"Ok to merge"
DO YN^DICN
+2 IF %=0
WRITE !!,"Enter 'Yes' to merge these accessions, 'No' to abort."
GOTO OK
+3 IF %'=1
WRITE !!,"NOTHING MERGED!",!
DO UL1
DO UL2
QUIT
+4 ;
+5 ;LR*5.2*566 new LRSOF
+6 NEW LRLFTOVR,LRORDTYP,LRTSORU,LRNLT,LRII,URG,LRSOF
+7 ; Set order type to (R)evised
+8 SET $PIECE(LRORDTYP,"^",2)=$$FIND1^DIC(64.061,"","OX","R","D","I $P(^(0),U,5)=""0065""")
+9 ;
+10 DO CHK(.LRT1SAD,.LRTSAD,.LRLFTOVR)
+11 SET LRII=0
+12 FOR
SET LRII=$ORDER(LRT1SAD(LRII))
if LRII<1
QUIT
Begin DoDot:1
+13 SET X=LRT1SAD(LRII)
SET URG=$PIECE(X,"^",2)
SET LRTSORU=$PIECE(X,U,9)
+14 ;Set variables for call to update ORUT node in #63
IF '$DATA(LRTSORU(LRTSORU))
Begin DoDot:2
+15 NEW LRORIFN,LRPRAC,LRSAMP,LRSPEC,LRURG,LRX
+16 SET LRX=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRII,0))
+17 SET LRORIFN=$SELECT(LRX>0:$PIECE($GET(^LRO(69,LR1ODT,1,LR1SN,2,LRX,0)),U,7),1:"")
+18 SET LRPRAC=$PIECE($GET(^LRO(68,LR1AA,1,LR1AD,1,LR1AN,0)),U,8)
+19 SET LRURG=URG
SET LRSPEC=$PIECE(SPEC,U)
SET LRSAMP=$PIECE(SPEC,U,2)
+20 DO ORUT^LRWLST11
End DoDot:2
+21 SET LRTSORU(LRTSORU)=""
+22 IF $DATA(LRLFTOVR(LRII))
Begin DoDot:2
+23 IF $ORDER(^LAB(60,LRII,2,0))
Begin DoDot:3
+24 NEW ARAT,SAME,SUB
+25 SET J=0
+26 FOR
SET J=$ORDER(^LAB(60,LRII,2,J))
if J<1
QUIT
SET ARAT(+^(J,0))=""
+27 DO CHK(.ARAT,.LRTSAD,.SUB)
+28 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
+29 IF SAME
DO SET68(LRII,URG,LRTSORU)
DO SET69(LRODT,LRSN,LRII,URG,LRAA,LRAODT,LRAN)
QUIT
+30 ;LR*5.2*566: Replace variable J with LRSUBJ to prevent errors when downstream
+31 ; logic kills J.
+32 NEW LRSUBJ
+33 SET LRSUBJ=0
+34 FOR
SET LRSUBJ=$ORDER(SUB(LRSUBJ))
if LRSUBJ<1
QUIT
DO SET68(LRSUBJ,URG,LRTSORU)
DO SET69(LRODT,LRSN,LRSUBJ,URG,LRAA,LRAD,LRAN)
End DoDot:3
QUIT
+35 DO SET68(LRII,URG,LRTSORU)
DO SET69(LRODT,LRSN,LRII,URG,LRAA,LRAD,LRAN)
End DoDot:2
End DoDot:1
+36 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:"")
+37 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)
+38 DO ZAP(LR1ODT,LR1SN,LR1AA,LR1AD,LR1AN,LRIDT1,1)
+39 ;
+40 IF '$DATA(^LRO(68,LR1AA,1,LR1AD,1,LR1AN))
Begin DoDot:1
+41 IF $DATA(^LR(LRDFN,LRSS,LRIDT))
IF $DATA(^(LRIDT1,1))
MERGE ^LR(LRDFN,LRSS,LRIDT,1)=^LR(LRDFN,LRSS,LRIDT1,1)
End DoDot:1
+42 ;
+43 ; Release locks
+44 DO UL1
DO UL2
+45 ;
+46 WRITE !!,"Accessions merged!"
+47 WRITE !!,"Accession #"_LRAN_" now looks like:"
DO WRITE(LRAA,LRAD,LRAN,+SPEC)
+48 ;
+49 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
+50 IF X'=""
DO EN^LA7ADL(X)
+51 ;
+52 DO END
+53 WRITE !,"Merge another accession"
+54 SET %=1
DO YN^DICN
IF %=1
GOTO EN1
+55 QUIT
+56 ;
+57 ;
ZAP(LRODT,LRSN,LRAA,LRAD,LRAN,LRIDT,LRMERG) ;
+1 ;
+2 ;LR*5.2*566: initialize LRCOMX and LRORDTST
+3 NEW LRNOW,LRTNM,LRTSTS,LRCOMX,LRORDTST
+4 ;
+5 if '$DATA(^LRO(69,LRODT,1,LRSN,0))#2
QUIT
+6 SET LRNOW=$$NOW^XLFDT
+7 SET LRTSTS=0
+8 FOR
SET LRTSTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
if LRTSTS<1
QUIT
Begin DoDot:1
+9 SET LRTNM=$PIECE($GET(^LAB(60,LRTSTS,0)),U)
+10 DO SET^LRTSTOUT
End DoDot:1
+11 QUIT
+12 ;
+13 ;
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 IF LRODT=""!(LRSN="")
QUIT
+5 if '$DATA(^LRO(69,+LRODT,1,+LRSN,0))
QUIT
IF $PIECE(^(0),"^",6)
IF $PIECE(^(0),"^",6)'=PROV
SET Y($PIECE(^(0),"^",6))=""
+6 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
+7 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
+8 QUIT
+9 ;
+10 ;
UL2 ;Unlock 2nd accession
+1 ;
+2 ;ZEXCEPT: LRAA,LRAD,LRAN
+3 ;
+4 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+5 QUIT
+6 ;
+7 ;
UL1 ;Unlock 1st accession
+1 ;
+2 ;ZEXCEPT: LR1AA,LR1AD,LR1AN
+3 ;
+4 LOCK -^LRO(68,LR1AA,1,LR1AD,1,LR1AN)
+5 QUIT
+6 ;
+7 ;
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
+10 ;
+11 ;
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 ;
+5 NEW I
+6 ;
+7 if '$DATA(^LRO(68,+$GET(AA),1,+$GET(AD),1,+$GET(AN)))
QUIT
+8 IF $PIECE($GET(^LRO(68,+$GET(AA),1,+$GET(AD),1,+$GET(AN),.3)),U)'=""
WRITE !,"UID: ",$PIECE(^(.3),U)
+9 WRITE !,$SELECT($DATA(^LAB(61,+$GET(SP),0)):$PIECE(^(0),"^"),1:""),?35,"TESTS ON ACCESSION: "
+10 SET I=0
+11 FOR
SET I=$ORDER(^LRO(68,AA,1,AD,1,AN,4,I))
if I<1
QUIT
Begin DoDot:1
+12 ; Don't include workload tests.
IF $PIECE($GET(^LAB(60,I,0)),"^",4)="WK"
QUIT
+13 SET ARAY(I)=^LRO(68,AA,1,AD,1,AN,4,I,0)
+14 WRITE !,?40,$PIECE(^LAB(60,I,0),U)
+15 IF $PIECE(ARAY(I),"^",5)
WRITE ?65,$SELECT($PIECE(ARAY(I),U,6)'="":$PIECE(ARAY(I),U,6),1:" Verified")
SET COMP=1
End DoDot:1
+16 QUIT
+17 ;
+18 ;
SET68(LRTSTS,URG,LRPRIM) ;Set file 68
+1 ;
+2 ;ZEXCEPT: LRAA,LRAD,LRAN
+3 ;
+4 if $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
QUIT
+5 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)=LRTSTS_"^"_URG
SET $PIECE(^(0),U,9)=LRPRIM
+6 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRTSTS,+LRTSTS)=""
+7 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",3)=LRTSTS
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+8 QUIT
+9 ;
+10 ;
SET69(LRODT,LRSN,LRTS,LRURG,LRAA,LRAODT,LRAN) ;Set file 69
+1 NEW DA,DIC,DIE,DINUM,DO,DR,LRFLG,LRNATURE,LRPHSET,LRXDA,X,Y
+2 ;
+3 SET (LRFLG,LRPHSET)=1
SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+4 ;
+5 ; Test already on order - update order with merged accession info when merging accession on same order entry (LRODT, LRSN)
+6 IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",LRTS))
Begin DoDot:1
+7 NEW LRDIE,LRFDA,LRIENS,LRXDA
+8 ;set same order flag for LRTSTOUT
SET LRSOF=1
+9 SET LRXDA=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRTS,0))
SET LRIENS=LRXDA_","_LRSN_","_LRODT_","
+10 SET LRXDA(3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+11 SET LRFDA(1,69.03,LRIENS,2)=LRAODT
+12 SET LRFDA(1,69.03,LRIENS,3)=LRAA
+13 SET LRFDA(1,69.03,LRIENS,4)=LRAN
+14 IF $PIECE(LRXDA(3),"^")'=""
SET LRFDA(1,69.03,LRIENS,13)=$PIECE(LRXDA(3),"^")
+15 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
End DoDot:1
QUIT
+16 ;
+17 ; Add stub entry for new test.
+18 SET DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,"
SET DA(2)=LRODT
SET DA(1)=LRSN
+19 SET DIC(0)="F"
SET X=+LRTS
+20 DO FILE^DICN
+21 ;
+22 ; Update new entry
+23 DO 69^LRTSTSET
+24 QUIT
+25 ;
+26 ;
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
