- 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 Feb 18, 2025@23:31:06 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 ""
