LR7OGMU ;DALOI/STAFF- Interim report rpc memo utility ;July 29, 2019@10:00
;;5.2;LAB SERVICE;**187,312,395,350,527**;Sep 27, 1994;Build 16
;
NEWOLD(Y,DFN) ; from ORWLRR
N LRDFN
D DEMO^LR7OGU(DFN,.LRDFN)
S Y=$$NEWEST(LRDFN)_U_$$OLDEST(LRDFN)
Q
;
;
NEWEST(LRDFN) ;
N ACDT,ACOMP,ANODE,AREA,CHKTYP,FIRSTCH,FIRSTMI,GOTNP,IDT,NUM,TESTNUM,UID,ZERO
S (FIRSTCH,FIRSTMI)=""
S IDT=0
F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1 S ZERO=^(IDT,0),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH
. I $P(ZERO,U,3) S FIRSTCH=9999999-IDT Q
. I UID'="" S UID=$$CHECKUID^LRWU4(UID) Q:'UID
. I 'UID,$P(ZERO,U,3) Q
. ;LR*5.2*527: commenting out line below so that tests marked as
. ; "not performed" will be eligible as "newest" in the
. ; range
. ;S GOTNP=0 D GETNP^LR7OGMC Q:GOTNP
. S AREA=$P(UID,"^",2),ACDT=$P(UID,"^",3),NUM=$P(UID,"^",4)
. I '$D(^LRO(68,+AREA,1,+ACDT,1,+NUM)) Q
. S (TESTNUM,CHKTYP,ACOMP)=0
. F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
. . Q:'$D(^LAB(60,TESTNUM,0)) I ("BO"[$P($G(^(0)),U,3)) S CHKTYP=1
. . I '$P(ANODE,"^",5) S ACOMP=1
. . ;LR*5.2*527: adding line below for same reason noted above
. . I $P(ANODE,"^",6)["*Not Performed" S ACOMP=1
. Q:'CHKTYP
. Q:'ACOMP
. S FIRSTCH=9999999-IDT
;
S IDT=$O(^LR(LRDFN,"MI",0))
I IDT>0 S FIRSTMI=9999999-IDT
I FIRSTCH>FIRSTMI Q FIRSTCH
I FIRSTCH'>FIRSTMI Q FIRSTMI
Q ""
;
;
OLDEST(LRDFN) ;
N ACDT,ACOMP,ANODE,AREA,CHKTYP,FIRSTCH,FIRSTMI,GOTNP,IDT,NUM,TESTNUM,UID,ZERO
S (FIRSTCH,FIRSTMI)=""
S IDT=""
F S IDT=$O(^LR(LRDFN,"CH",IDT),-1) Q:IDT<1 S ZERO=^(IDT,0),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH
. I $P(ZERO,U,3) S FIRSTCH=9999999-IDT Q
. I UID'="" S UID=$$CHECKUID^LRWU4(UID)
. I 'UID,$P(ZERO,U,3) Q
. ;LR*5.2*527: commenting out line below so that tests marked as
. ; "not performed" will be eligible as "oldest" in the
. ; range
. ;S GOTNP=0 D GETNP^LR7OGMC Q:GOTNP
. S AREA=$P(UID,"^",2),ACDT=$P(UID,"^",3),NUM=$P(UID,"^",4)
. I '$D(^LRO(68,+AREA,1,+ACDT,1,+NUM)) Q
. S (TESTNUM,CHKTYP,ACOMP)=0
. F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
. . Q:'$D(^LAB(60,TESTNUM,0)) I ("BO"[$P($G(^(0)),U,3)) S CHKTYP=1
. . I '$P(ANODE,"^",5) S ACOMP=1
. . ;LR*5.2*527: adding line below for same reason noted above
. . I $P(ANODE,"^",6)["*Not Performed" S ACOMP=1
. Q:'CHKTYP
. Q:'ACOMP
. S FIRSTCH=9999999-IDT
;
S IDT=$O(^LR(LRDFN,"MI",""),-1)
I IDT>0 S FIRSTMI=9999999-IDT
I FIRSTMI="" Q FIRSTCH
I FIRSTCH="" Q FIRSTMI
I FIRSTCH<FIRSTMI Q FIRSTCH
I FIRSTCH'<FIRSTMI Q FIRSTMI
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OGMU 2696 printed Dec 13, 2024@02:05:13 Page 2
LR7OGMU ;DALOI/STAFF- Interim report rpc memo utility ;July 29, 2019@10:00
+1 ;;5.2;LAB SERVICE;**187,312,395,350,527**;Sep 27, 1994;Build 16
+2 ;
NEWOLD(Y,DFN) ; from ORWLRR
+1 NEW LRDFN
+2 DO DEMO^LR7OGU(DFN,.LRDFN)
+3 SET Y=$$NEWEST(LRDFN)_U_$$OLDEST(LRDFN)
+4 QUIT
+5 ;
+6 ;
NEWEST(LRDFN) ;
+1 NEW ACDT,ACOMP,ANODE,AREA,CHKTYP,FIRSTCH,FIRSTMI,GOTNP,IDT,NUM,TESTNUM,UID,ZERO
+2 SET (FIRSTCH,FIRSTMI)=""
+3 SET IDT=0
+4 FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT))
if IDT<1
QUIT
SET ZERO=^(IDT,0)
SET UID=$PIECE($GET(^("ORU")),"^")
Begin DoDot:1
+5 IF $PIECE(ZERO,U,3)
SET FIRSTCH=9999999-IDT
QUIT
+6 IF UID'=""
SET UID=$$CHECKUID^LRWU4(UID)
if 'UID
QUIT
+7 IF 'UID
IF $PIECE(ZERO,U,3)
QUIT
+8 ;LR*5.2*527: commenting out line below so that tests marked as
+9 ; "not performed" will be eligible as "newest" in the
+10 ; range
+11 ;S GOTNP=0 D GETNP^LR7OGMC Q:GOTNP
+12 SET AREA=$PIECE(UID,"^",2)
SET ACDT=$PIECE(UID,"^",3)
SET NUM=$PIECE(UID,"^",4)
+13 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
QUIT
+14 SET (TESTNUM,CHKTYP,ACOMP)=0
+15 FOR
SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
if 'TESTNUM
QUIT
SET ANODE=^(TESTNUM,0)
Begin DoDot:2
+16 if '$DATA(^LAB(60,TESTNUM,0))
QUIT
IF ("BO"[$PIECE($GET(^(0)),U,3))
SET CHKTYP=1
+17 IF '$PIECE(ANODE,"^",5)
SET ACOMP=1
+18 ;LR*5.2*527: adding line below for same reason noted above
+19 IF $PIECE(ANODE,"^",6)["*Not Performed"
SET ACOMP=1
End DoDot:2
+20 if 'CHKTYP
QUIT
+21 if 'ACOMP
QUIT
+22 SET FIRSTCH=9999999-IDT
End DoDot:1
if FIRSTCH
QUIT
+23 ;
+24 SET IDT=$ORDER(^LR(LRDFN,"MI",0))
+25 IF IDT>0
SET FIRSTMI=9999999-IDT
+26 IF FIRSTCH>FIRSTMI
QUIT FIRSTCH
+27 IF FIRSTCH'>FIRSTMI
QUIT FIRSTMI
+28 QUIT ""
+29 ;
+30 ;
OLDEST(LRDFN) ;
+1 NEW ACDT,ACOMP,ANODE,AREA,CHKTYP,FIRSTCH,FIRSTMI,GOTNP,IDT,NUM,TESTNUM,UID,ZERO
+2 SET (FIRSTCH,FIRSTMI)=""
+3 SET IDT=""
+4 FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT),-1)
if IDT<1
QUIT
SET ZERO=^(IDT,0)
SET UID=$PIECE($GET(^("ORU")),"^")
Begin DoDot:1
+5 IF $PIECE(ZERO,U,3)
SET FIRSTCH=9999999-IDT
QUIT
+6 IF UID'=""
SET UID=$$CHECKUID^LRWU4(UID)
+7 IF 'UID
IF $PIECE(ZERO,U,3)
QUIT
+8 ;LR*5.2*527: commenting out line below so that tests marked as
+9 ; "not performed" will be eligible as "oldest" in the
+10 ; range
+11 ;S GOTNP=0 D GETNP^LR7OGMC Q:GOTNP
+12 SET AREA=$PIECE(UID,"^",2)
SET ACDT=$PIECE(UID,"^",3)
SET NUM=$PIECE(UID,"^",4)
+13 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
QUIT
+14 SET (TESTNUM,CHKTYP,ACOMP)=0
+15 FOR
SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
if 'TESTNUM
QUIT
SET ANODE=^(TESTNUM,0)
Begin DoDot:2
+16 if '$DATA(^LAB(60,TESTNUM,0))
QUIT
IF ("BO"[$PIECE($GET(^(0)),U,3))
SET CHKTYP=1
+17 IF '$PIECE(ANODE,"^",5)
SET ACOMP=1
+18 ;LR*5.2*527: adding line below for same reason noted above
+19 IF $PIECE(ANODE,"^",6)["*Not Performed"
SET ACOMP=1
End DoDot:2
+20 if 'CHKTYP
QUIT
+21 if 'ACOMP
QUIT
+22 SET FIRSTCH=9999999-IDT
End DoDot:1
if FIRSTCH
QUIT
+23 ;
+24 SET IDT=$ORDER(^LR(LRDFN,"MI",""),-1)
+25 IF IDT>0
SET FIRSTMI=9999999-IDT
+26 IF FIRSTMI=""
QUIT FIRSTCH
+27 IF FIRSTCH=""
QUIT FIRSTMI
+28 IF FIRSTCH<FIRSTMI
QUIT FIRSTCH
+29 IF FIRSTCH'<FIRSTMI
QUIT FIRSTMI
+30 QUIT ""
