LR7OGMU ;VA/SLC/STAFF- Interim report rpc memo utility ; 17-Oct-2014 09:22 ; MKK
;;5.2;LR;**187,312,1022,395,1031,1034**;NOV 01, 1997;Build 146
;
; IHS/MSC/MKK - LR*5.2*1034 - Naked References removed
;
NEWOLD(Y,DFN) ; from ORWLRR
N LRDFN
D DEMO^LR7OGU(DFN,.LRDFN)
S Y=$$NEWEST(LRDFN)_U_$$OLDEST(LRDFN)
Q
;
NEWEST(LRDFN) ;
N IDT,FIRSTCH,FIRSTMI,LRCAN,ZERO,UID,AREA,ACDT,NUM,TESTNUM,CHKTYP,ANODE,ACOMP,GOTNP
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
F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1 S ZERO=$G(^(IDT,0)),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH ; IHS/MSC/MKK - LR*5.2*1034
. I $P(ZERO,U,3) S FIRSTCH=9999999-IDT Q
. I UID'="" S UID=$$CHECKUID^LRWU4(UID) Q:'UID
. I 'UID,'$P(ZERO,"^",3) Q
. 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=0,CHKTYP=0,ACOMP=0
. ; F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
. F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=$G(^(TESTNUM,0)) D ; IHS/MSC/MKK - LR*5.2*1034
.. Q:'$D(^LAB(60,TESTNUM,0)) I ("BO"[$P($G(^(0)),U,3)) S CHKTYP=1
.. I '$P(ANODE,"^",5) S ACOMP=1
. Q:'CHKTYP
. Q:'ACOMP
. S FIRSTCH=9999999-IDT
. Q
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 IDT,FIRSTCH,FIRSTMI,LRCAN,ZERO,UID,AREA,ACDT,NUM,TESTNUM,CHKTYP,ANODE,ACOMP,GOTNP
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
F S IDT=$O(^LR(LRDFN,"CH",IDT),-1) Q:IDT<1 S ZERO=$G(^(IDT,0)),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH ; IHS/MSC/MKK - LR*5.2*1034
. I $P(ZERO,U,3) S FIRSTCH=9999999-IDT Q
. I UID'="" S UID=$$CHECKUID^LRWU4(UID)
. I 'UID,'$P(ZERO,"^",3) Q
. 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=0,CHKTYP=0,ACOMP=0
. ; F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
. F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=$G(^(TESTNUM,0)) D ; IHS/MSC/MKK - LR*5.2*1034
.. Q:'$D(^LAB(60,TESTNUM,0)) I ("BO"[$P($G(^(0)),U,3)) S CHKTYP=1
.. I '$P(ANODE,"^",5) S ACOMP=1
. Q:'CHKTYP
. Q:'ACOMP
. S FIRSTCH=9999999-IDT
. Q
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 ""
LR7OGMU ;VA/SLC/STAFF- Interim report rpc memo utility ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LR;**187,312,1022,395,1031,1034**;NOV 01, 1997;Build 146
+2 ;
+3 ; IHS/MSC/MKK - LR*5.2*1034 - Naked References removed
+4 ;
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 ;
NEWEST(LRDFN) ;
+1 NEW IDT,FIRSTCH,FIRSTMI,LRCAN,ZERO,UID,AREA,ACDT,NUM,TESTNUM,CHKTYP,ANODE,ACOMP,GOTNP
+2 SET (FIRSTCH,FIRSTMI)=""
+3 SET IDT=0
+4 ; F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1 S ZERO=^(IDT,0),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH
+5 ; IHS/MSC/MKK - LR*5.2*1034
FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT))
IF IDT<1
QUIT
SET ZERO=$GET(^(IDT,0))
SET UID=$PIECE($GET(^("ORU")),"^")
Begin DoDot:1
+6 IF $PIECE(ZERO,U,3)
SET FIRSTCH=9999999-IDT
QUIT
+7 IF UID'=""
SET UID=$$CHECKUID^LRWU4(UID)
IF 'UID
QUIT
+8 IF 'UID
IF '$PIECE(ZERO,"^",3)
QUIT
+9 SET GOTNP=0
DO GETNP^LR7OGMC
IF GOTNP
QUIT
+10 SET AREA=$PIECE(UID,"^",2)
SET ACDT=$PIECE(UID,"^",3)
SET NUM=$PIECE(UID,"^",4)
+11 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
QUIT
+12 SET TESTNUM=0
SET CHKTYP=0
SET ACOMP=0
+13 ; F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
+14 ; IHS/MSC/MKK - LR*5.2*1034
FOR
SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
IF 'TESTNUM
QUIT
SET ANODE=$GET(^(TESTNUM,0))
Begin DoDot:2
+15 IF '$DATA(^LAB(60,TESTNUM,0))
QUIT
IF ("BO"[$PIECE($GET(^(0)),U,3))
SET CHKTYP=1
+16 IF '$PIECE(ANODE,"^",5)
SET ACOMP=1
End DoDot:2
+17 IF 'CHKTYP
QUIT
+18 IF 'ACOMP
QUIT
+19 SET FIRSTCH=9999999-IDT
+20 QUIT
End DoDot:1
IF FIRSTCH
QUIT
+21 SET IDT=$ORDER(^LR(LRDFN,"MI",0))
IF IDT>0
SET FIRSTMI=9999999-IDT
+22 IF FIRSTCH>FIRSTMI
QUIT FIRSTCH
+23 IF FIRSTCH'>FIRSTMI
QUIT FIRSTMI
+24 QUIT ""
+25 ;
OLDEST(LRDFN) ;
+1 NEW IDT,FIRSTCH,FIRSTMI,LRCAN,ZERO,UID,AREA,ACDT,NUM,TESTNUM,CHKTYP,ANODE,ACOMP,GOTNP
+2 SET (FIRSTCH,FIRSTMI)=""
+3 SET IDT=""
+4 ; F S IDT=$O(^LR(LRDFN,"CH",IDT),-1) Q:IDT<1 S ZERO=^(IDT,0),UID=$P($G(^("ORU")),"^") D Q:FIRSTCH
+5 ; IHS/MSC/MKK - LR*5.2*1034
FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT),-1)
IF IDT<1
QUIT
SET ZERO=$GET(^(IDT,0))
SET UID=$PIECE($GET(^("ORU")),"^")
Begin DoDot:1
+6 IF $PIECE(ZERO,U,3)
SET FIRSTCH=9999999-IDT
QUIT
+7 IF UID'=""
SET UID=$$CHECKUID^LRWU4(UID)
+8 IF 'UID
IF '$PIECE(ZERO,"^",3)
QUIT
+9 SET GOTNP=0
DO GETNP^LR7OGMC
IF GOTNP
QUIT
+10 SET AREA=$PIECE(UID,"^",2)
SET ACDT=$PIECE(UID,"^",3)
SET NUM=$PIECE(UID,"^",4)
+11 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
QUIT
+12 SET TESTNUM=0
SET CHKTYP=0
SET ACOMP=0
+13 ; F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
+14 ; IHS/MSC/MKK - LR*5.2*1034
FOR
SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
IF 'TESTNUM
QUIT
SET ANODE=$GET(^(TESTNUM,0))
Begin DoDot:2
+15 IF '$DATA(^LAB(60,TESTNUM,0))
QUIT
IF ("BO"[$PIECE($GET(^(0)),U,3))
SET CHKTYP=1
+16 IF '$PIECE(ANODE,"^",5)
SET ACOMP=1
End DoDot:2
+17 IF 'CHKTYP
QUIT
+18 IF 'ACOMP
QUIT
+19 SET FIRSTCH=9999999-IDT
+20 QUIT
End DoDot:1
IF FIRSTCH
QUIT
+21 SET IDT=$ORDER(^LR(LRDFN,"MI",""),-1)
IF IDT>0
SET FIRSTMI=9999999-IDT
+22 IF FIRSTMI=""
QUIT FIRSTCH
+23 IF FIRSTCH=""
QUIT FIRSTMI
+24 IF FIRSTCH<FIRSTMI
QUIT FIRSTCH
+25 IF FIRSTCH'<FIRSTMI
QUIT FIRSTMI
+26 QUIT ""
