Routine: LRPHITE2

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

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)

M F  S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC=""  D M1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPHITE2   963     printed  Apr 09, 2024@21:24:57                                                                                                                                                                                                     Page 2

LRPHITE2  ;SLC/CJS-LRPHITEM CONT ;2/23/88  10:44

 +1       ;;5.2;LAB SERVICE;**221**;Sep 27, 1994

OUT       ;from LRPHITEM

 +1        NEW LRX

 +2        SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)

 +3        SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)

 +4        SET LRDFN=+LRX

           SET LRDPF=$PIECE(LRX,U,2)

 +5        IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),U,3)

               QUIT

 +6        DO PT^LRX

SKPLR      SET LROSN=$PIECE(LRX,U,5)

           SET LROID=$PIECE(LRX,U,4)

           SET LRAOD=$PIECE(X,U,3)

 +1        SET LROCN=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)):$PIECE(^(.1),U),1:"")

           SET LRACC=$SELECT($DATA(^(.2)):$PIECE(^(.2),U),1:"")

 +2        if '$DATA(LRLLOC)

               SET LRLLOC=""

           if LRLLOC=""

               GOTO M

M1         SET LRRB=""

           Begin DoDot:1

 +1            NEW LRSN,LRODT

 +2            SET LRSN=LROSN

               SET LRODT=LROID

 +3            SET LRTSTS=0

FOR

                   SET LRTSTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))

                   if LRTSTS<1

                       QUIT

                   Begin DoDot:2

 +4                    SET LRTNM=$PIECE($GET(^LAB(60,+LRTSTS,0)),U)

 +5                    DO SET^LRTSTOUT

                       DO M2

                   End DoDot:2

           End DoDot:1

 +6        QUIT

M2        ;

 +1        FOR

               SET LRRB=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB))

               if LRRB=""

                   QUIT

               Begin DoDot:1

 +2                IF $DATA(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LROSN,LRAA,LRAN,LRTSTS))

                       KILL ^(LRTSTS)

               End DoDot:1

 +3        QUIT

M          FOR

               SET LRLLOC=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC))

               if LRLLOC=""

                   QUIT

               DO M1

 +1        QUIT

LRPHITE2.m