- LRRP3 ;SLC/RWF/BA - INTERIM REPORT FOR SELECTED TESTS ;2/19/91 11:38
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**283**;Sep 27, 1994
- ;from option LRRP3
- BEGIN D:'$D(LRPARAM) ^LRPARAM W !!?20,"GENERAL LAB DATA DISPLAY" S LREND=0 F S (LRSTOP,LRPG,LRPRTPG)=0 D PAT Q:$G(LREND) W !!
- END D ^LRRK
- Q
- PAT K DIC D ^LRDPA I LRDFN=-1 S LREND=1 Q
- I $O(^LR(LRDFN,0))="" W !,"NO LAB DATA ON THIS PATIENT!",$C(7) Q
- K ^TMP("LR",$J),LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRHI,LRLO,LRUN,LRMI,LRMIEC,LRMF
- S (LRONESPC,LRONETST)="",LRTSTS=0,DIC="^LAB(60,",DIC(0)="AEMOQ",DIC("S")="I $P(^(0),U,4)=""CH""!($P(^(0),U,4)=""MI"")"_$S('$D(LRLABKY):",""BO""[$P(^(0),U,3)",1:"") D ^DIC I Y<1 K DIC Q
- F S LRTEST=+Y D @$S($P(^LAB(60,LRTEST,0),U,4)="CH":"CHEM",1:"MICRO") D ^DIC Q:Y'>0
- K DIC,^TMP("LR",$J,"T"),LRORD Q:'LRTSTS
- S LREDT="T-7",LRCW=8 D ^LRWU3 Q:LREND S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT
- S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO"
- D ^DIR K DIR
- I Y S LRPRTPG=1
- S ZTSAVE("^TMP(""LR"",$J,")="",ZTSAVE("DFN")="",ZTRTN="DQ^LRRP3" D IO^LRWU
- Q
- CHEM S LREXPD="S LRSUB=$P(^TMP(""LR"",$J,""T"",X),U,5),^TMP(""LR"",$J,""TMP"",$P(LRSUB,"";"",2))=X" D ^LREXPD
- Q
- MICRO S LRMI(LRTEST)="",LRTSTS=LRTSTS+1,LRMIEC=+$P(^LAB(60,LRTEST,0),U,14),LRMIEC=$S($D(^LAB(62.07,LRMIEC,.1)):^(.1),1:"")
- S:LRMIEC["11.5" LRMF(1)="" S:LRMIEC["11.6" LRMF(2)="" S:LRMIEC["15" LRMF(5)="" S:LRMIEC["19" LRMF(8)="" S:LRMIEC["23" LRMF(11)="" S:LRMIEC["34" LRMF(16)="" I '$D(LRMF) K LRMIC(LRTEST) S LRTSTS=LRTSTS-1
- Q
- DQ ;dequeued
- D EN^LRPARAM Q:$G(LREND)
- U IO S:$D(ZTQUEUED) ZTREQ="@"
- D PT^LRX S LRHF=1,LRFOOT=0,LRIDT=LRSDT
- F S LRCNIDT=+$O(^LR(LRDFN,"CH",LRIDT)),LRMNIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:'LRCNIDT&'LRMNIDT D SWITCH Q:LREND!LRSTOP!(LRIDT>LREDT)
- D FOOT^LRRP1
- D:LRPRTPG PLSPG^LRRP2
- W @IOF D ^LRRK
- Q
- SWITCH I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH,MI Q
- I 'LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
- I 'LRCNIDT S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI Q
- I LRCNIDT<LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
- S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI
- Q
- CH Q:'$P(^LR(LRDFN,"CH",LRIDT,0),U,3)
- S LRDN=0 F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN="" I $D(^TMP("LR",$J,"TMP",LRDN)) D GO Q
- Q
- MI S (LROK,LRMF)=0 F S LRMF=+$O(LRMF(LRMF)) Q:LRMF<1 I $D(^LR(LRDFN,"MI",LRIDT,LRMF)) S LROK=1 Q
- Q:'LROK S LRCDT=9999999-LRIDT,^TMP("LR",$J,"TP",1)="^MI",^(1,LRCDT)="",^(LRCDT,-1)="",LRSS="MI" S LRH=1 D:LRFOOT FOOT^LRRP1 Q:LRSTOP D EN1^LRMIPC S LRHF=1,LRFOOT=0 K A,Z,LRH S:LREND LREND=0,LRSTOP=1
- Q
- GO K ^TMP("LR",$J,"TP") S LR0=^LR(LRDFN,"CH",LRIDT,0),LRCDT=+LR0,LRSS="CH",LRAA="",LROC=$P(LR0,U,11),LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5)
- D GO^LRRP
- Q
- LRRP3 ;SLC/RWF/BA - INTERIM REPORT FOR SELECTED TESTS ;2/19/91 11:38
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**283**;Sep 27, 1994
- +3 ;from option LRRP3
- BEGIN IF '$DATA(LRPARAM)
- DO ^LRPARAM
- WRITE !!?20,"GENERAL LAB DATA DISPLAY"
- SET LREND=0
- FOR
- SET (LRSTOP,LRPG,LRPRTPG)=0
- DO PAT
- IF $GET(LREND)
- QUIT
- WRITE !!
- END DO ^LRRK
- +1 QUIT
- PAT KILL DIC
- DO ^LRDPA
- IF LRDFN=-1
- SET LREND=1
- QUIT
- +1 IF $ORDER(^LR(LRDFN,0))=""
- WRITE !,"NO LAB DATA ON THIS PATIENT!",$CHAR(7)
- QUIT
- +2 KILL ^TMP("LR",$JOB),LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRHI,LRLO,LRUN,LRMI,LRMIEC,LRMF
- +3 SET (LRONESPC,LRONETST)=""
- SET LRTSTS=0
- SET DIC="^LAB(60,"
- SET DIC(0)="AEMOQ"
- SET DIC("S")="I $P(^(0),U,4)=""CH""!($P(^(0),U,4)=""MI"")"_$SELECT('$DATA(LRLABKY):",""BO""[$P(^(0),U,3)",1:"")
- DO ^DIC
- IF Y<1
- KILL DIC
- QUIT
- +4 FOR
- SET LRTEST=+Y
- DO @$SELECT($PIECE(^LAB(60,LRTEST,0),U,4)="CH":"CHEM",1:"MICRO")
- DO ^DIC
- IF Y'>0
- QUIT
- +5 KILL DIC,^TMP("LR",$JOB,"T"),LRORD
- IF 'LRTSTS
- QUIT
- +6 SET LREDT="T-7"
- SET LRCW=8
- DO ^LRWU3
- IF LREND
- QUIT
- SET LRSDT=9999999-LRSDT
- SET LREDT=9999999-LREDT
- +7 SET DIR(0)="Y"
- SET DIR("A")="Print address page"
- SET DIR("B")="NO"
- +8 DO ^DIR
- KILL DIR
- +9 IF Y
- SET LRPRTPG=1
- +10 SET ZTSAVE("^TMP(""LR"",$J,")=""
- SET ZTSAVE("DFN")=""
- SET ZTRTN="DQ^LRRP3"
- DO IO^LRWU
- +11 QUIT
- CHEM SET LREXPD="S LRSUB=$P(^TMP(""LR"",$J,""T"",X),U,5),^TMP(""LR"",$J,""TMP"",$P(LRSUB,"";"",2))=X"
- DO ^LREXPD
- +1 QUIT
- MICRO SET LRMI(LRTEST)=""
- SET LRTSTS=LRTSTS+1
- SET LRMIEC=+$PIECE(^LAB(60,LRTEST,0),U,14)
- SET LRMIEC=$SELECT($DATA(^LAB(62.07,LRMIEC,.1)):^(.1),1:"")
- +1 IF LRMIEC["11.5"
- SET LRMF(1)=""
- IF LRMIEC["11.6"
- SET LRMF(2)=""
- IF LRMIEC["15"
- SET LRMF(5)=""
- IF LRMIEC["19"
- SET LRMF(8)=""
- IF LRMIEC["23"
- SET LRMF(11)=""
- IF LRMIEC["34"
- SET LRMF(16)=""
- IF '$DATA(LRMF)
- KILL LRMIC(LRTEST)
- SET LRTSTS=LRTSTS-1
- +2 QUIT
- DQ ;dequeued
- +1 DO EN^LRPARAM
- IF $GET(LREND)
- QUIT
- +2 USE IO
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 DO PT^LRX
- SET LRHF=1
- SET LRFOOT=0
- SET LRIDT=LRSDT
- +4 FOR
- SET LRCNIDT=+$ORDER(^LR(LRDFN,"CH",LRIDT))
- SET LRMNIDT=+$ORDER(^LR(LRDFN,"MI",LRIDT))
- IF 'LRCNIDT&'LRMNIDT
- QUIT
- DO SWITCH
- IF LREND!LRSTOP!(LRIDT>LREDT)
- QUIT
- +5 DO FOOT^LRRP1
- +6 IF LRPRTPG
- DO PLSPG^LRRP2
- +7 WRITE @IOF
- DO ^LRRK
- +8 QUIT
- SWITCH IF LRCNIDT=LRMNIDT
- SET LRIDT=LRCNIDT
- IF LRIDT>LREDT
- QUIT
- DO CH
- DO MI
- QUIT
- +1 IF 'LRMNIDT
- SET LRIDT=LRCNIDT
- IF LRIDT>LREDT
- QUIT
- DO CH
- QUIT
- +2 IF 'LRCNIDT
- SET LRIDT=LRMNIDT
- IF LRIDT>LREDT
- QUIT
- DO MI
- QUIT
- +3 IF LRCNIDT<LRMNIDT
- SET LRIDT=LRCNIDT
- IF LRIDT>LREDT
- QUIT
- DO CH
- QUIT
- +4 SET LRIDT=LRMNIDT
- IF LRIDT>LREDT
- QUIT
- DO MI
- +5 QUIT
- CH IF '$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)
- QUIT
- +1 SET LRDN=0
- FOR
- SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
- IF LRDN=""
- QUIT
- IF $DATA(^TMP("LR",$JOB,"TMP",LRDN))
- DO GO
- QUIT
- +2 QUIT
- MI SET (LROK,LRMF)=0
- FOR
- SET LRMF=+$ORDER(LRMF(LRMF))
- IF LRMF<1
- QUIT
- IF $DATA(^LR(LRDFN,"MI",LRIDT,LRMF))
- SET LROK=1
- QUIT
- +1 IF 'LROK
- QUIT
- SET LRCDT=9999999-LRIDT
- SET ^TMP("LR",$JOB,"TP",1)="^MI"
- SET ^(1,LRCDT)=""
- SET ^(LRCDT,-1)=""
- SET LRSS="MI"
- SET LRH=1
- IF LRFOOT
- DO FOOT^LRRP1
- IF LRSTOP
- QUIT
- DO EN1^LRMIPC
- SET LRHF=1
- SET LRFOOT=0
- KILL A,Z,LRH
- IF LREND
- SET LREND=0
- SET LRSTOP=1
- +2 QUIT
- GO KILL ^TMP("LR",$JOB,"TP")
- SET LR0=^LR(LRDFN,"CH",LRIDT,0)
- SET LRCDT=+LR0
- SET LRSS="CH"
- SET LRAA=""
- SET LROC=$PIECE(LR0,U,11)
- SET LRAAO=1
- SET LRTC=0
- SET LRSPEC=$PIECE(LR0,U,5)
- +1 DO GO^LRRP
- +2 QUIT
