source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRPHITE2.m@ 1604

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

initial load of WorldVistAEHR

File size: 938 bytes
Line 
1LRPHITE2 ;SLC/CJS-LRPHITEM CONT ;2/23/88 10:44
2 ;;5.2;LAB SERVICE;**221**;Sep 27, 1994
3OUT ;from LRPHITEM
4 N LRX
5 S LRSS=$P(^LRO(68,LRAA,0),"^",2)
6 S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
7 S LRDFN=+LRX,LRDPF=$P(LRX,U,2)
8 I $P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,3) Q
9 D PT^LRX
10SKPLR S LROSN=$P(LRX,U,5),LROID=$P(LRX,U,4),LRAOD=$P(X,U,3)
11 S LROCN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)):$P(^(.1),U),1:""),LRACC=$S($D(^(.2)):$P(^(.2),U),1:"")
12 S:'$D(LRLLOC) LRLLOC="" G:LRLLOC="" M
13M1 S LRRB="" D
14 . N LRSN,LRODT
15 . S LRSN=LROSN,LRODT=LROID
16 . S LRTSTS=0 F S LRTSTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 D
17 . . S LRTNM=$P($G(^LAB(60,+LRTSTS,0)),U)
18 . . D SET^LRTSTOUT,M2
19 Q
20M2 ;
21 F S LRRB=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB)) Q:LRRB="" D
22 . I $D(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LROSN,LRAA,LRAN,LRTSTS)) K ^(LRTSTS)
23 Q
24M F S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC="" D M1
25 Q
Note: See TracBrowser for help on using the repository browser.