BPC7OGMU.m

BPC7OGMU ; IHS/OIT/MJL - Interim report rpc memo utility 6/6/97 16:15 ;

 ;;1.5;BPC;;MAY 26, 2005

 ;;

 ;;5.2;LAB SERVICE;**187**;Sep 27, 1994

 ;

NEWOLD(Y,DFN) ; from ORWLRR

 N LRDFN

 D DEMO^BPC7OGU(DFN,.LRDFN)

 S Y=$$NEWEST(LRDFN)_U_$$OLDEST(LRDFN)

 Q

 ;

NEWEST(LRDFN) ;

 N IDT,FIRSTCH,FIRSTMI

 S (FIRSTCH,FIRSTMI)=""

 S IDT=0 F  S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1  I $P($G(^(IDT,0)),U,3) S FIRSTCH=9999999-IDT Q

 S IDT=0 F  S IDT=$O(^LR(LRDFN,"MI",IDT)) Q:IDT<1  I $P($G(^(IDT,0)),U,1) S FIRSTMI=9999999-IDT Q

 I FIRSTCH>FIRSTMI Q FIRSTCH

 I FIRSTCH'>FIRSTMI Q FIRSTMI

 Q ""

 ;

OLDEST(LRDFN) ;

 N IDT,FIRSTCH,FIRSTMI

 S (FIRSTCH,FIRSTMI)=""

 S IDT="" F  S IDT=$O(^LR(LRDFN,"CH",IDT),-1) Q:IDT=""  I $P($G(^(IDT,0)),U,3) S FIRSTCH=9999999-IDT Q

 S IDT="" F  S IDT=$O(^LR(LRDFN,"MI",IDT),-1) Q:IDT=""  I $P($G(^(IDT,0)),U,1) S FIRSTMI=9999999-IDT Q

 I FIRSTMI="" Q FIRSTCH

 I FIRSTCH="" Q FIRSTMI

 I FIRSTCH<FIRSTMI Q FIRSTCH

 I FIRSTCH'<FIRSTMI Q FIRSTMI

 Q ""

BPC7OGMU  ; IHS/OIT/MJL - Interim report rpc memo utility 6/6/97 16:15 ;

 +1       ;;1.5;BPC;;MAY 26, 2005

 +2       ;;

 +3       ;;5.2;LAB SERVICE;**187**;Sep 27, 1994

 +4       ;

NEWOLD(Y,DFN) ; from ORWLRR

 +1        NEW LRDFN

 +2        DO DEMO^BPC7OGU(DFN,.LRDFN)

 +3        SET Y=$$NEWEST(LRDFN)_U_$$OLDEST(LRDFN)

 +4        QUIT 

 +5       ;

NEWEST(LRDFN) ;

 +1        NEW IDT,FIRSTCH,FIRSTMI

 +2        SET (FIRSTCH,FIRSTMI)=""

 +3        SET IDT=0

           FOR 

               SET IDT=$ORDER(^LR(LRDFN,"CH",IDT))

               IF IDT<1

                   QUIT 

               IF $PIECE($GET(^(IDT,0)),U,3)

                   SET FIRSTCH=9999999-IDT

                   QUIT 

 +4        SET IDT=0

           FOR 

               SET IDT=$ORDER(^LR(LRDFN,"MI",IDT))

               IF IDT<1

                   QUIT 

               IF $PIECE($GET(^(IDT,0)),U,1)

                   SET FIRSTMI=9999999-IDT

                   QUIT 

 +5        IF FIRSTCH>FIRSTMI

               QUIT FIRSTCH

 +6        IF FIRSTCH'>FIRSTMI

               QUIT FIRSTMI

 +7        QUIT ""

 +8       ;

OLDEST(LRDFN) ;

 +1        NEW IDT,FIRSTCH,FIRSTMI

 +2        SET (FIRSTCH,FIRSTMI)=""

 +3        SET IDT=""

           FOR 

               SET IDT=$ORDER(^LR(LRDFN,"CH",IDT),-1)

               IF IDT=""

                   QUIT 

               IF $PIECE($GET(^(IDT,0)),U,3)

                   SET FIRSTCH=9999999-IDT

                   QUIT 

 +4        SET IDT=""

           FOR 

               SET IDT=$ORDER(^LR(LRDFN,"MI",IDT),-1)

               IF IDT=""

                   QUIT 

               IF $PIECE($GET(^(IDT,0)),U,1)

                   SET FIRSTMI=9999999-IDT

                   QUIT 

 +5        IF FIRSTMI=""

               QUIT FIRSTCH

 +6        IF FIRSTCH=""

               QUIT FIRSTMI

 +7        IF FIRSTCH<FIRSTMI

               QUIT FIRSTCH

 +8        IF FIRSTCH'<FIRSTMI

               QUIT FIRSTMI

 +9        QUIT ""