116 lines
6.5 KiB
Mathematica
116 lines
6.5 KiB
Mathematica
LR7OMERG ;SLC/DCM,BNM,FHS-MERGE ACCESSION ;8/11/97
|
|
;;5.2;LAB SERVICE;**121,221**;Sep 27, 1994
|
|
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 EN1
|
|
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 EN1
|
|
D WRITE(LRAA,LRAD,LRAN,+SPEC,.COMP,.LRTSAD)
|
|
I +SPEC'=+SPEC1 W !!,$C(7),"Cannot merge accessions with different specimens" D UL2 G EN1
|
|
I COMP W !!,$C(7),"Cannot merge accessions with completed results" D UL2 G EN1
|
|
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)
|
|
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
|