- 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
