- 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 ""
