source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OMERG.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1LR7OMERG ;SLC/DCM,BNM,FHS-MERGE ACCESSION ;8/11/97
2 ;;5.2;LAB SERVICE;**121,221**;Sep 27, 1994
3EN ;Merge 2 accessions together
4 D END
5EN1 S COMP=0,LRACC=1 W !!,"Merge from..." D LRACC^LRTSTOUT Q:LRAN<1
6 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 W !?5,"This is not a valid Accession number ",!,$C(7) G EN1
7 L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !?5,"Someone else is editing this entry ",!,$C(7) G EN1
8 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))
9 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
10 D WRITE(LRAA,LRAD,LRAN,+SPEC1,.COMP,.LRT1SAD)
11 S LR1AA=LRAA,LR1AD=LRAD,LR1AN=LRAN
122 S LRACC=1 W !!,"Merge into..." D LRACC^LRTSTOUT I LRAN<1 D UL1 Q
13 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 W !?5,"This is not a valid Accession number ",!,$C(7) G 2
14 I LRAA=LR1AA,LRAD=LR1AD,LRAN=LR1AN W !!,$C(7),"Cannot merge into the same accession" G 2
15 I $P(^LRO(68,LRAA,0),"^",2)'=LRSS W !!,$C(7),"Cannot merge a """_LRSS_""" accession into a """_$P(^(0),"^",2)_""" accession" G EN1
16 L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !?5,"Someone else is editing this entry ",!,$C(7) G 2
17 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))
18 S LRCCOM="*Merge to:"_LRTOACC,LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
19 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
20 I +X'=+LRX1 W !!,$C(7),"Cannot merge accessions for different patients!" D UL2 G EN1
21 D WRITE(LRAA,LRAD,LRAN,+SPEC,.COMP,.LRTSAD)
22 I +SPEC'=+SPEC1 W !!,$C(7),"Cannot merge accessions with different specimens" D UL2 G EN1
23 I COMP W !!,$C(7),"Cannot merge accessions with completed results" D UL2 G EN1
24 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
25 . W !,"<<"_$P(^LAB(60,I,0),"^")_" normally belongs to accession area: "_$P(^LRO(68,J,0),"^")_">>",$C(7)
26OK S %=2 W !!,"Ok to merge" D YN^DICN
27 I %=0 W !!,"Enter 'Yes' to merge these accessions, 'No' to abort." G OK
28 I %'=1 W !!,"NOTHING MERGED!",! D UL1,UL2 Q
29 N LRLFTOVR,URG,LRTSORU,LRNLT,LRII
30 D CHK(.LRT1SAD,.LRTSAD,.LRLFTOVR)
31 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
32 . I '$D(LRTSORU(LRTSORU)) D ORUT^LRWLST11
33 . S LRTSORU(LRTSORU)=""
34 . I $D(LRLFTOVR(LRII)) D
35 .. I $O(^LAB(60,LRII,2,0)) D Q
36 ... N ARAT,SAME,SUB
37 ... S J=0 F S J=$O(^LAB(60,LRII,2,J)) Q:J<1 S ARAT(+^(J,0))=""
38 ... D CHK(.ARAT,.LRTSAD,.SUB)
39 ... 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
40 ... I SAME D SET68(LRII,URG,LRTSORU),SET69(LRODT,LRSN,LRII,URG,LRAA,LRAODT,LRAN) Q
41 ... 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)
42 .. D SET68(LRII,URG,LRTSORU),SET69(LRODT,LRSN,LRII,URG,LRAA,LRAD,LRAN)
43 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:"")
44 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)
45 D ZAP(LR1ODT,LR1SN,LR1AA,LR1AD,LR1AN,LRIDT1,1)
46 I '$D(^LRO(68,LR1AA,1,LR1AD,1,LR1AN)) D
47 . I $D(^LR(LRDFN,LRSS,LRIDT)),$D(^(LRIDT1,1)) M ^LR(LRDFN,LRSS,LRIDT,1)=^LR(LRDFN,LRSS,LRIDT1,1)
48 D UL1,UL2
49 W !!,"Accessions merged!"
50 W !!,"Accession #"_LRAN_" now looks like:" D WRITE(LRAA,LRAD,LRAN,+SPEC)
51 S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U) D:X EN^LA7ADL(X)
52 D END
53 W !,"Merge another accession" S %=1 D YN^DICN I %=1 G EN1
54 Q
55ZAP(LRODT,LRSN,LRAA,LRAD,LRAN,LRIDT,LRMERG) ;
56 Q:'$D(^LRO(69,LRODT,1,LRSN,0))#2
57 S LRNOW=$$NOW^XLFDT
58 S LRTSTS=0 F S LRTSTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 D
59 . S LRTNM=$P($G(^LAB(60,LRTSTS,0)),U)
60 . D SET^LRTSTOUT
61 Q
62PRAC(LRAA,LRAD,LRAN,Y) ;Find all ordering providers for a given accession
63 N LRODT,LRSN,I,PROV,X
64 Q:'$D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)) S X=^(0),PROV=$P(X,"^",8)
65 S LRODT=$P(X,"^",4),LRSN=$P(X,"^",5)
66 Q:'$D(^LRO(69,+LRODT,1,+LRSN,0)) S:$P(^(0),"^",6)'=PROV Y($P(^(0),"^",6))=""
67 S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1 S X=$P(^(I,0),"^",14) D
68 . I X,$D(^LRO(69,+X,1,+$P(X,";",2),0)),$P(^(0),"^",6)'=PROV S Y($P(^(0),"^",6))=""
69 Q
70UL2 ;Unlock 2nd accession
71 L -^LRO(68,LRAA,1,LRAD,1,LRAN)
72 Q
73UL1 ;Unlock 1st accession
74 L -^LRO(68,LR1AA,1,LR1AD,1,LR1AN)
75 Q
76CHK(ARAY1,ARAY2,OUT) ;Check for duplicate tests on accessions
77 ;ARAY1(tst)=test aray from accession being merged
78 ;ARAY2(tst)=test aray from accession being merged to
79 ;Output [OUT] is an array of tests from ARAY1 that are not duplicated in ARAY2
80 Q:'$O(ARAY2(0))
81 N IN2,I
82 S I=0 F S I=$O(ARAY1(I)) Q:I<1 I '$D(ARAY2(I)) S OUT(I)=ARAY1(I)
83 S I=0 F S I=$O(ARAY2(I)) Q:I<1 D EXPAND^LR7OU1(I,.IN2)
84 S I=0 F S I=$O(OUT(I)) Q:I<1 I $D(IN2(I)) K OUT(I)
85 Q
86WRITE(AA,AD,AN,SP,COMP,ARAY) ;Display accession with tests
87 ;AA=Accession area, AD=Accession Date, AN=Accession #, SP=ptr to 61 specimen
88 ;COMP=1 (returned) if all tests on accession are complete
89 ;ARAY(TST) (returned) for all tests on accession
90 Q:'$D(^LRO(68,+$G(AA),1,+$G(AD),1,+$G(AN))) W:$L($P($G(^(+AN,.3)),U)) !,"UID: ",$P(^(.3),U)
91 W !,$S($D(^LAB(61,+$G(SP),0)):$P(^(0),"^"),1:""),?35,"TESTS ON ACCESSION: "
92 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
93 Q
94SET68(LRTSTS,URG,LRPRIM) ;Set file 68
95 Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
96 S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)=LRTSTS_"^"_URG,$P(^(0),U,9)=LRPRIM
97 S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRTSTS,+LRTSTS)=""
98 S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",3)=LRTSTS,$P(^(0),"^",4)=$P(^(0),"^",4)+1
99 Q
100SET69(LRODT,LRSN,LRTS,LRURG,LRAA,LRAODT,LRAN) ;Set file 69
101 N X,Y,LRFLG,LRNATURE,LRPHSET,LRXDA,DA,DIC,DIE,DR,DLAYGO
102 S (LRFLG,LRPHSET)=1,LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
103 S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
104 S DIC(0)="LOX",DLAYGO=69,X=$P($G(^LAB(60,LRTS,0)),U)
105 D ^DIC Q:'$P(Y,U,3)
106 D 69^LRTSTSET
107 Q
108END ;
109 K COMP,X,X1,I,J,LRACC,LRSS,LRIDT,LRIDT1,LRORD,LRX1,LRAA,LRAD,LRAN,LR1AA,LR1AD,LR1AN,LR1ODT
110 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
111 K PNM,SEX,SSN,Y,DOB,DFN,LRWRD,VA,VADM,VAIN,VA200,VAERR,LRTOACC
112 D KVA^VADPT
113 K AGE,D0,DI,IFN,LRNOW,LRNLT,LRNATURE,LRLLOC,LRLFTOVR,LRII,LRCCOM
114 K LRAGE,LRTNM,LRTSORU,LRTSTS,URG
115 Q
Note: See TracBrowser for help on using the repository browser.