LRRP3 ;SLC/RWF/BA - INTERIM REPORT FOR SELECTED TESTS ;2/19/91 11:38
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP3 2672 printed Nov 22, 2024@17:29:57 Page 2
LRRP3 ;SLC/RWF/BA - INTERIM REPORT FOR SELECTED TESTS ;2/19/91 11:38
+1 ;;5.2;LAB SERVICE;**283**;Sep 27, 1994
+2 ;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
