source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPHSET2.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1LRPHSET2 ;SLC/RWA - COLLECTION LIST TO ACCESSIONS CONT ;8/11/97
2 ;;5.2;LAB SERVICE;**121,202**;Sep 27, 1994
3REUP ;FROM LRPHSET1 - ADD TO OR REBUILD TO COLLECTION LIST
4 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRRB=$S(LRDPF=2&$D(^DPT(DFN,.101)):^(.101),1:0),LRRB=$S($L(LRRB):LRRB,1:"")
5 S I=0 F S I=$O(^LRO(69,DT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) I $L($P(X,U,3)) S LRAA($P(X,U,4))=$P(X,U,3)_"^"_$P(X,U,4)_"^"_$P(X,U,5)
6 S LRK=0 F S LRK=$O(^LRO(69,DT,1,LRSN,2,LRK)) Q:LRK<1 S X=^(LRK,0) I '$L($P(X,U,3)),'$P(X,"^",11) D
7 . S LRTS=+X,LRAA=$S($D(^LAB(60,LRTS,8,DUZ(2),0)):$P(^(0),U,2),1:"")
8 . I LRAA'="",$D(LRAA(LRAA)),$P(^LAB(60,LRTS,0),U,7)'=1 D JAM
9 S LRI=0 F S LRI=$O(^LRO(69,DT,1,LRSN,2,LRI)) Q:LRI<1 S X=^(LRI,0) I '$P(X,U,6),$P(X,U,3) S LRTSTN=+X,LRAD=$P(X,U,3),LRAA=$P(X,U,4),LRAN=$P(X,U,5) I '$D(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,+LRTSTN)) D REUP1
10 I $D(REUP) S LRCOUNT=LRCOUNT+1,^LRO(69,DT,1,LRSN,3)=LRDTI
11 I '$D(REUP) S $P(^LRO(69,DT,1,LRSN,1),U)=$P(^LRO(69,DT,1,LRSN,3),U)
12 K LRAD,LRI,LRAN,LRAA,LRDPF,DFN,LRZ3,LRZB,LRZ1,LRTSTN,LRRB,LRURG,REUP,I,J,LRK,F,LRAODT Q
13REUP1 L +^LRO(69.1,LRTE):90 I '$T G REUP1
14 S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
15 I '$D(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) S REUP=1
16REUP2 S LRZ3=LRZ3+1
17 G:$D(^LRO(69.1,LRTE,1,LRZ3)) REUP2
18 S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTSTN,LRIFN=LRZ3
19 D Z^LRWU
20 L -^LRO(69.1,LRTE)
21 S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTSTN_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_LROLLOC,^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTSTN)=+LRTSTN
22 Q
23JAM S LRAA=$P(LRAA(LRAA),U,2),LRAD=$P(LRAA(LRAA),U),LRAODT=LRAD,LRAN=$P(LRAA(LRAA),U,3),(LRURG,Y)=$P(X,U,2)
24 D EN^LRTSTSET
25 Q
26S7 ;FROM LRPHSET1 - COMBINE OR MERGE TESTS ON ORDERS
27 S T=0 F S T=$O(T(LRSAMP,T)) Q:T<1 D S7A
28 Q
29S7A S LRPSN=0 F S LRPSN=$O(T(LRSAMP,T,LRPSN)) Q:LRPSN<1 D @$S(LRSTEP=0:"S8",1:"S9")
30 Q
31S8 S J=T
32 D COMBINE
33 S J=0 F S J=$O(T(LRSAMP,J)) Q:J<1 D SCAN60
34 Q
35S9 S J=0 F S J=$O(T(LRSAMP,J)) Q:J<1 D MERG
36 Q
37SCAN60 S K=0 F S K=$O(^LAB(60,T,2,K)) Q:K<1 I +^(K,0)=J S LRSN=0,LRSN=$O(T(LRSAMP,J,LRSN)) D @$S(LRPSN>LRSN:"MERG",1:"COMBINE")
38 Q
39COMBINE S LRSN=0 F S LRSN=$O(T(LRSAMP,J,LRSN)) Q:LRSN<1 D:LRPSN>LRSN SWAP I LRSN'=LRPSN D CB2
40 Q
41CB2 I $L($P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6)),$D(^LRO(69,DT,1,LRSN,.1)),$D(^LRO(69,DT,1,+$O(^LRO(69,"C",+^(.1),DT,0)),1)),$L($P(^(1),U,4)) Q
42 I $P(T(LRSAMP,T,LRPSN),U,2)'=$P(T(LRSAMP,J,LRSN),U,2) D URGENCY S $P(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),U,2)=LRURG
43 S $P(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
44 N X,XI,X1,I,TST
45 S X1=^LRO(69,DT,1,LRPSN,.1),TST=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),$P(^(0),U,6)=X1,$P(^LRO(69,DT,1,LRSN,1),U,4)="M",XI=$P(^(1),U,7),XI=XI_X1_"/",$P(^(1),U,7)=XI
46 D OERR(TST)
47 K T(LRSAMP,J,LRSN)
48 Q
49MERG S LRSN=0 F S LRSN=$O(T(LRSAMP,J,LRSN)) Q:LRSN<1 D:LRPSN>LRSN SWAP,SWAP1 I LRSN'=LRPSN D M1
50 Q
51M1 Q:$L($P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6))
52 S X=$P(^LRO(69,DT,1,LRPSN,2,0),"^",3)
53LP S X=X+1
54 I $D(^LRO(69,DT,1,LRPSN,2,X)) G LP
55 S ^LRO(69,DT,1,LRPSN,2,X,0)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),$P(^(0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN),^LRO(69,DT,1,LRPSN,2,"B",J,X)="",$P(^LRO(69,DT,1,LRPSN,2,0),"^",3,4)=X_"^"_X
56 N I,XI,X1,TST
57 S X1=^LRO(69,DT,1,LRPSN,.1),$P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),"^",6)=X1
58 S TST=^LRO(69,DT,1,LRPSN,2,X,0),LRURG=$P(TST,"^",2),T(LRSAMP,J,LRPSN)=T(LRSAMP,J,LRSN),$P(T(LRSAMP,J,LRPSN),"^")=X
59 S $P(^LRO(69,DT,1,LRSN,1),U,4)="M",XI=$P(^(1),U,7),XI=XI_X1_"/",$P(^LRO(69,DT,1,LRSN,1),U,7)=XI
60 D OERR(TST)
61 K T(LRSAMP,J,LRSN)
62 Q
63SWAP S LRSWAP=LRSN,LRSN=LRPSN,LRPSN=LRSWAP K LRSWAP
64 Q
65SWAP1 S LRSWAP=J,J=T,T=LRSWAP
66 Q
67URGENCY S LRURG1=$P(T(LRSAMP,T,LRPSN),U,2),LRURG2=$P(T(LRSAMP,J,LRSN),U,2),LRURG=$S(LRURG1<LRURG2:LRURG1,1:LRURG2)
68 K LRURG1,LRURG2
69 Q
70OERR(TSTNODE) ;OE/RR - CPRS calls
71 I $$VER^LR7OU1<3 D Q ;OE/RR 2.5
72 . N I,ORIFN,OREASON,ORSTS
73 . S ORIFN=$P(TSTNODE,U,7)
74 . I ORIFN S ORSTS=1,OREASON="D" D ST^ORX
75 N X,TTT,LRNATURE,LRSJ ;OE/RR 3.0
76 S LRSJ=J,X=$O(^ORD(100.03,"C","LRDUP",0)),LRNATURE=$$DC1^LROR6(X,"Combined with LB #"_X1)
77 S TTT(+TSTNODE)="",DIE="^LRO(69,DT,1,LRSN,2,",DA=+T(LRSAMP,LRSJ,LRSN),DA(1)=LRSN,DA(2)=DT,DR="99.1///DUPLICATE TEST: "_$S($L($P($G(LRNATURE),"^",5)):$P(LRNATURE,"^",5),1:"")
78 D ^DIE
79 D NEW^LR7OB1(DT,LRSN,"OC",$G(LRNATURE),.TTT)
80 S $P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),0),"^",3,5)="^^",$P(^(0),"^",9,11)="CA^L^"_DUZ,J=LRSJ
81 Q
Note: See TracBrowser for help on using the repository browser.