BPC7OGM ; IHS/OIT/MJL - Interim report rpc memo 10/15/98 22:21 ;
;;1.5;BPC;;MAY 26, 2005
;;
;;5.2;LAB SERVICE;**187,220**;Sep 27, 1994
;
TEST ; test use only
N TESTS,I K TESTS,^TMP("BPC7OGX",$J)
;S TESTS(548)=548
;F I=1:1:10 I $D(^LAB(60,I,0)) S TESTS(I)=I
D SELECT(2,2970202,2920202,.TESTS,0,-1)
S I=0 F S I=$O(^TMP("BPC7OGX",$J,"OUTPUT",I)) Q:I<1 W !,^(I)
K ^TMP("BPC7OGX",$J)
Q
;
INTERIM(ROOT,DFN,SDATE,EDATE) ; EP from ORWLRR
N FORMAT,MICROCHK,TESTS K TESTS
S (FORMAT,MICROCHK)=""
S ROOT=$NA(^TMP("BPC7OGX",$J,"OUTPUT"))
D SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK) ;
N BPCLAST S BPCLAST=$O(^TMP("BPC7OGX",$J,"OUTPUT",""),-1) S:+BPCLAST ^TMP("BPC7OGX",$J,"OUTPUT",.5)=BPCLAST+1 ;FJE
Q
;
INTERIMG(ROOT,DFN,SDATE,DIR,FORMAT) ; from ORWLRR
N MICROCHK,TESTS K TESTS
S MICROCHK=1,FORMAT=$G(FORMAT,1)
S ROOT=$NA(^TMP("BPC7OGX",$J,"OUTPUT"))
D SELECT(DFN,SDATE,DIR,.TESTS,FORMAT,MICROCHK) ;
Q
;
INTERIMS(ROOT,DFN,SDATE,EDATE,TESTLIST) ; from ORWLRR
N FORMAT,MICROCHK,NUM,TESTS K TESTS
S (FORMAT,MICROCHK)=""
S NUM=0 F S NUM=$O(TESTLIST(NUM)) Q:NUM<1 S TESTS(+TESTLIST(NUM))=""
S ROOT=$NA(^TMP("BPC7OGX",$J,"OUTPUT"))
D SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK) ;
Q
;
MICRO(ROOT,DFN,SDATE,EDATE) ; from ORWLRR
N FORMAT,MICROCHK,TESTS K TESTS
S FORMAT="",MICROCHK=-1
S ROOT=$NA(^TMP("BPC7OGX",$J,"OUTPUT"))
D SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK) ;
Q
;
SELECT(DFN,SDATE,EDATE,TESTS,FORMAT,MICROCHK) ;
; get patient info, and expand tests
; route setup chem and/or micro data
; 9th piece of output indicates format (2: CH of CH/MI exact date/time, 3: MI of CH/MI, else 1 or "")
N AGE,ALL,ASK,AVAIL,CNIDT,DIRECT,DONE,EDT,FOK,IDT,LRDFN,MICROSUB,MNIDT,OUTCNT,PNM,ROUTE,SEX,SDT K MICROSUB
K ^TMP("BPC7OG",$J),^TMP("BPC7OGX",$J,"OUTPUT")
S OUTCNT=1,DONE=0
D DEMO^BPC7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX)
I '$G(LRDFN) Q
S ^TMP("BPC7OG",$J,"G")=DFN_U_PNM_U_LRDFN_U_AGE_U_SEX_"^8"
S ALL=$S($O(TESTS(0)):0,1:1)
I 'ALL D TESTSGET^BPC7OGU(.TESTS,.MICROSUB)
S DIRECT=1
I FORMAT S DIRECT=EDATE,EDATE=2700101
S EDATE=EDATE\1
S (IDT,SDT)=9999999-SDATE,EDT=9999999-EDATE
I FORMAT>1 S FOK=0 D I FOK Q
.I DIRECT=1 D Q
..I FORMAT=2 D Q
...D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
...S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=3
...S FOK=1
..I FORMAT=3 D Q
...S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=1
.I DIRECT=-1 D Q
..I FORMAT=2 D Q
...S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=1
..I FORMAT=3 D Q
...D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
...S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=2
...S FOK=1
I ALL S ASK="BOTH"
E I $O(MICROSUB(0)) D
.S ASK="MI" I $O(^TMP("BPC7OG",$J,"TMP",0)) S ASK="BOTH"
E S ASK="CH"
S CNIDT=+$O(^LR(LRDFN,"CH",IDT),DIRECT),MNIDT=+$O(^LR(LRDFN,"MI",IDT),DIRECT)
S AVAIL="NONE"
I CNIDT,CNIDT'>EDT D
.S AVAIL="CH" I MNIDT,MNIDT'>EDT S AVAIL="BOTH"
E I MNIDT,MNIDT'>EDT S AVAIL="MI"
I DIRECT=-1 S AVAIL="BOTH"
S ROUTE="NONE"
I ASK="BOTH" S ROUTE=AVAIL
I ASK="CH",AVAIL="CH"!(AVAIL="BOTH") S ROUTE="CH"
I ASK="MI",AVAIL="MI"!(AVAIL="BOTH") S ROUTE="MI"
I MICROCHK=-1 S ROUTE="MI"
I ROUTE="NONE" D Q
.K ^TMP("BPC7OG",$J)
I ROUTE="CH" D Q
.F S IDT=$O(^LR(LRDFN,"CH",IDT),DIRECT) Q:IDT<1 Q:IDT>EDT D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE) Q:DONE
.K ^TMP("BPC7OG",$J)
I ROUTE="MI" D Q
.F S IDT=$O(^LR(LRDFN,"MI",IDT),DIRECT) Q:IDT<1 Q:IDT>EDT D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE) Q:DONE
.K ^TMP("BPC7OG",$J)
F S CNIDT=+$O(^LR(LRDFN,"CH",IDT),DIRECT),MNIDT=+$O(^LR(LRDFN,"MI",IDT),DIRECT) Q:'CNIDT&'MNIDT D Q:IDT>EDT Q:DONE
.I CNIDT=MNIDT D Q ; both chem and micro at this date/time
..S IDT=CNIDT
..I IDT'>EDT D
...I FORMAT D Q
....I SDT=(9999999-2700101)!(DIRECT=-1) D Q
.....D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
.....S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=3
....D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
....S $P(^TMP("BPC7OGX",$J,"OUTPUT",1),U,9)=2
...I MICROCHK'=1 D Q:DONE
....D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
....I FORMAT S MICROCHK=1
...D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
.I 'MNIDT D Q ; no micro since this date/time, only chem at this date/time
..S IDT=CNIDT
..I IDT'>EDT D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
.I 'CNIDT D Q ; no chem since this date/time, only micro at this date/time
..S IDT=MNIDT
..I IDT'>EDT D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
.I (DIRECT=1&(CNIDT<MNIDT))!(DIRECT=-1&(CNIDT>MNIDT)) D Q ;chem and micro data, chem is more recent
..S IDT=CNIDT
..I IDT'>EDT D CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
.S IDT=MNIDT
.I IDT'>EDT D MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
K ^TMP("BPC7OG",$J)
Q
BPC7OGM ; IHS/OIT/MJL - Interim report rpc memo 10/15/98 22:21 ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;;
+3 ;;5.2;LAB SERVICE;**187,220**;Sep 27, 1994
+4 ;
TEST ; test use only
+1 NEW TESTS,I
KILL TESTS,^TMP("BPC7OGX",$JOB)
+2 ;S TESTS(548)=548
+3 ;F I=1:1:10 I $D(^LAB(60,I,0)) S TESTS(I)=I
+4 DO SELECT(2,2970202,2920202,.TESTS,0,-1)
+5 SET I=0
FOR
SET I=$ORDER(^TMP("BPC7OGX",$JOB,"OUTPUT",I))
IF I<1
QUIT
WRITE !,^(I)
+6 KILL ^TMP("BPC7OGX",$JOB)
+7 QUIT
+8 ;
INTERIM(ROOT,DFN,SDATE,EDATE) ; EP from ORWLRR
+1 NEW FORMAT,MICROCHK,TESTS
KILL TESTS
+2 SET (FORMAT,MICROCHK)=""
+3 SET ROOT=$NAME(^TMP("BPC7OGX",$JOB,"OUTPUT"))
+4 ;
DO SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK)
+5 ;FJE
NEW BPCLAST
SET BPCLAST=$ORDER(^TMP("BPC7OGX",$JOB,"OUTPUT",""),-1)
IF +BPCLAST
SET ^TMP("BPC7OGX",$JOB,"OUTPUT",.5)=BPCLAST+1
+6 QUIT
+7 ;
INTERIMG(ROOT,DFN,SDATE,DIR,FORMAT) ; from ORWLRR
+1 NEW MICROCHK,TESTS
KILL TESTS
+2 SET MICROCHK=1
SET FORMAT=$GET(FORMAT,1)
+3 SET ROOT=$NAME(^TMP("BPC7OGX",$JOB,"OUTPUT"))
+4 ;
DO SELECT(DFN,SDATE,DIR,.TESTS,FORMAT,MICROCHK)
+5 QUIT
+6 ;
INTERIMS(ROOT,DFN,SDATE,EDATE,TESTLIST) ; from ORWLRR
+1 NEW FORMAT,MICROCHK,NUM,TESTS
KILL TESTS
+2 SET (FORMAT,MICROCHK)=""
+3 SET NUM=0
FOR
SET NUM=$ORDER(TESTLIST(NUM))
IF NUM<1
QUIT
SET TESTS(+TESTLIST(NUM))=""
+4 SET ROOT=$NAME(^TMP("BPC7OGX",$JOB,"OUTPUT"))
+5 ;
DO SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK)
+6 QUIT
+7 ;
MICRO(ROOT,DFN,SDATE,EDATE) ; from ORWLRR
+1 NEW FORMAT,MICROCHK,TESTS
KILL TESTS
+2 SET FORMAT=""
SET MICROCHK=-1
+3 SET ROOT=$NAME(^TMP("BPC7OGX",$JOB,"OUTPUT"))
+4 ;
DO SELECT(DFN,SDATE,EDATE,.TESTS,FORMAT,MICROCHK)
+5 QUIT
+6 ;
SELECT(DFN,SDATE,EDATE,TESTS,FORMAT,MICROCHK) ;
+1 ; get patient info, and expand tests
+2 ; route setup chem and/or micro data
+3 ; 9th piece of output indicates format (2: CH of CH/MI exact date/time, 3: MI of CH/MI, else 1 or "")
+4 NEW AGE,ALL,ASK,AVAIL,CNIDT,DIRECT,DONE,EDT,FOK,IDT,LRDFN,MICROSUB,MNIDT,OUTCNT,PNM,ROUTE,SEX,SDT
KILL MICROSUB
+5 KILL ^TMP("BPC7OG",$JOB),^TMP("BPC7OGX",$JOB,"OUTPUT")
+6 SET OUTCNT=1
SET DONE=0
+7 DO DEMO^BPC7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX)
+8 IF '$GET(LRDFN)
QUIT
+9 SET ^TMP("BPC7OG",$JOB,"G")=DFN_U_PNM_U_LRDFN_U_AGE_U_SEX_"^8"
+10 SET ALL=$SELECT($ORDER(TESTS(0)):0,1:1)
+11 IF 'ALL
DO TESTSGET^BPC7OGU(.TESTS,.MICROSUB)
+12 SET DIRECT=1
+13 IF FORMAT
SET DIRECT=EDATE
SET EDATE=2700101
+14 SET EDATE=EDATE\1
+15 SET (IDT,SDT)=9999999-SDATE
SET EDT=9999999-EDATE
+16 IF FORMAT>1
SET FOK=0
Begin DoDot:1
+17 IF DIRECT=1
Begin DoDot:2
+18 IF FORMAT=2
Begin DoDot:3
+19 DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
+20 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=3
+21 SET FOK=1
End DoDot:3
QUIT
+22 IF FORMAT=3
Begin DoDot:3
+23 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=1
End DoDot:3
QUIT
End DoDot:2
QUIT
+24 IF DIRECT=-1
Begin DoDot:2
+25 IF FORMAT=2
Begin DoDot:3
+26 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=1
End DoDot:3
QUIT
+27 IF FORMAT=3
Begin DoDot:3
+28 DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
+29 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=2
+30 SET FOK=1
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
IF FOK
QUIT
+31 IF ALL
SET ASK="BOTH"
+32 IF '$TEST
IF $ORDER(MICROSUB(0))
Begin DoDot:1
+33 SET ASK="MI"
IF $ORDER(^TMP("BPC7OG",$JOB,"TMP",0))
SET ASK="BOTH"
End DoDot:1
+34 IF '$TEST
SET ASK="CH"
+35 SET CNIDT=+$ORDER(^LR(LRDFN,"CH",IDT),DIRECT)
SET MNIDT=+$ORDER(^LR(LRDFN,"MI",IDT),DIRECT)
+36 SET AVAIL="NONE"
+37 IF CNIDT
IF CNIDT'>EDT
Begin DoDot:1
+38 SET AVAIL="CH"
IF MNIDT
IF MNIDT'>EDT
SET AVAIL="BOTH"
End DoDot:1
+39 IF '$TEST
IF MNIDT
IF MNIDT'>EDT
SET AVAIL="MI"
+40 IF DIRECT=-1
SET AVAIL="BOTH"
+41 SET ROUTE="NONE"
+42 IF ASK="BOTH"
SET ROUTE=AVAIL
+43 IF ASK="CH"
IF AVAIL="CH"!(AVAIL="BOTH")
SET ROUTE="CH"
+44 IF ASK="MI"
IF AVAIL="MI"!(AVAIL="BOTH")
SET ROUTE="MI"
+45 IF MICROCHK=-1
SET ROUTE="MI"
+46 IF ROUTE="NONE"
Begin DoDot:1
+47 KILL ^TMP("BPC7OG",$JOB)
End DoDot:1
QUIT
+48 IF ROUTE="CH"
Begin DoDot:1
+49 FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT),DIRECT)
IF IDT<1
QUIT
IF IDT>EDT
QUIT
DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
IF DONE
QUIT
+50 KILL ^TMP("BPC7OG",$JOB)
End DoDot:1
QUIT
+51 IF ROUTE="MI"
Begin DoDot:1
+52 FOR
SET IDT=$ORDER(^LR(LRDFN,"MI",IDT),DIRECT)
IF IDT<1
QUIT
IF IDT>EDT
QUIT
DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
IF DONE
QUIT
+53 KILL ^TMP("BPC7OG",$JOB)
End DoDot:1
QUIT
+54 FOR
SET CNIDT=+$ORDER(^LR(LRDFN,"CH",IDT),DIRECT)
SET MNIDT=+$ORDER(^LR(LRDFN,"MI",IDT),DIRECT)
IF 'CNIDT&'MNIDT
QUIT
Begin DoDot:1
+55 ; both chem and micro at this date/time
IF CNIDT=MNIDT
Begin DoDot:2
+56 SET IDT=CNIDT
+57 IF IDT'>EDT
Begin DoDot:3
+58 IF FORMAT
Begin DoDot:4
+59 IF SDT=(9999999-2700101)!(DIRECT=-1)
Begin DoDot:5
+60 DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
+61 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=3
End DoDot:5
QUIT
+62 DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
+63 SET $PIECE(^TMP("BPC7OGX",$JOB,"OUTPUT",1),U,9)=2
End DoDot:4
QUIT
+64 IF MICROCHK'=1
Begin DoDot:4
+65 DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
+66 IF FORMAT
SET MICROCHK=1
End DoDot:4
IF DONE
QUIT
+67 DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
End DoDot:3
End DoDot:2
QUIT
+68 ; no micro since this date/time, only chem at this date/time
IF 'MNIDT
Begin DoDot:2
+69 SET IDT=CNIDT
+70 IF IDT'>EDT
DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
End DoDot:2
QUIT
+71 ; no chem since this date/time, only micro at this date/time
IF 'CNIDT
Begin DoDot:2
+72 SET IDT=MNIDT
+73 IF IDT'>EDT
DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
End DoDot:2
QUIT
+74 ;chem and micro data, chem is more recent
IF (DIRECT=1&(CNIDT<MNIDT))!(DIRECT=-1&(CNIDT>MNIDT))
Begin DoDot:2
+75 SET IDT=CNIDT
+76 IF IDT'>EDT
DO CH^BPC7OGMC(LRDFN,IDT,ALL,.OUTCNT,FORMAT,.DONE)
End DoDot:2
QUIT
+77 SET IDT=MNIDT
+78 IF IDT'>EDT
DO MI^BPC7OGMM(LRDFN,IDT,.MICROSUB,ALL,.OUTCNT,FORMAT,.DONE)
End DoDot:1
IF IDT>EDT
QUIT
IF DONE
QUIT
+79 KILL ^TMP("BPC7OG",$JOB)
+80 QUIT
