26 lines
938 B
Mathematica
26 lines
938 B
Mathematica
LRPHITE2 ;SLC/CJS-LRPHITEM CONT ;2/23/88 10:44
|
|
;;5.2;LAB SERVICE;**221**;Sep 27, 1994
|
|
OUT ;from LRPHITEM
|
|
N LRX
|
|
S LRSS=$P(^LRO(68,LRAA,0),"^",2)
|
|
S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
|
|
S LRDFN=+LRX,LRDPF=$P(LRX,U,2)
|
|
I $P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,3) Q
|
|
D PT^LRX
|
|
SKPLR S LROSN=$P(LRX,U,5),LROID=$P(LRX,U,4),LRAOD=$P(X,U,3)
|
|
S LROCN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)):$P(^(.1),U),1:""),LRACC=$S($D(^(.2)):$P(^(.2),U),1:"")
|
|
S:'$D(LRLLOC) LRLLOC="" G:LRLLOC="" M
|
|
M1 S LRRB="" D
|
|
. N LRSN,LRODT
|
|
. S LRSN=LROSN,LRODT=LROID
|
|
. 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,M2
|
|
Q
|
|
M2 ;
|
|
F S LRRB=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB)) Q:LRRB="" D
|
|
. I $D(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LROSN,LRAA,LRAN,LRTSTS)) K ^(LRTSTS)
|
|
Q
|
|
M F S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC="" D M1
|
|
Q
|