LRSOR ;SLC/RWF/CJS - SOME SPECIAL OUTPUT ROUTINES ;2/6/91 15:19 ;
;;5.2;LAB SERVICE;**121**;Sep 27, 1994
D ^LRDPA G DONE:LRDFN<1 G LRA
LRC ;NON SMAC CHEMISTRIES
I LRDFN<1 W !,"NO DATA",! Q
R !,"DO YOU WANT (R)IA TESTS, (N)ON SMAC TESTS, (H)EMA other than CBC: ",X:DTIME
Q:"RNH"'[$E(X,1) G HEM:$E(X,1)="H",LRR:$E(X,1)="R"
LRCC D LPA G DONE:POP S DIC=DIC_Q_"CH"","
S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 S LRMETH=$P(^(LRIDT,0),U,8) D LROK IF LROK,'(LRMETH="ASTRA"!(LRMETH="SMAC"))!$L($S($D(^(40)):^(40),1:"")) S DA=LRIDT,DR="0:99999999" D EN^LRDIQ D WAIT Q:LREND W !!
G DONE
LROK S LROK=0 Q:'$P(^LR(LRDFN,"CH",LRIDT,0),U,3) S LRZX=$O(^LR(LRDFN,"CH",LRIDT,21)) S:LRZX>0&(LRZX<384) LROK=1 Q
LPA ;
I $D(LRPRETTY) S DIC="^LR("_LRDFN_",",Q="""",LREND=0,LRIDTE=LRSDT,LRIDTS=LREDT Q
S POP=1 W:LRDFN<1 !,"NO DATA",! Q:LRDFN<1
LPT R !,"Starting Date: N//",X:DTIME Q:X["^" S:X="" X="N" S %DT="ETX" D ^%DT G LPT:Y<1
S Y=9999999-Y,Y=$O(^LR(LRDFN,"CH",Y-.00001)),X=9999999-Y,LRIDTE=Y-.00001
W !,"First data of any kind on ",$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
LPT1 R !,"Number of days to check for data: 20//",X:DTIME Q:X["^" S:X="" X=20 I +X'=X!(X>99999)!(X<1)!(X?.E1"."1N.N) W !,"Type a number between 1 and 99999." G LPT1
S X="T-"_X,%DT="E" D ^%DT S LRIDTS=9999999-Y G LPT1:Y<1
K %ZIS D ^%ZIS Q:POP
U IO S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DT^LRX,PT^LRX D HEAD S DIC="^LR("_LRDFN_",",Q="""",LREND=0 Q
LPB Q:LRDFN<1 S DIC=DIC_Q_LRSS_Q_"," S LRIDT=LRIDTE F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LRIDT<1 Q:LRIDT>LRIDTS IF $P(^LR(LRDFN,LRSS,LRIDT,0),U,3) D LPC Q:LREND W !
G DONE
LPC S LRDR=$O(^LR(LRDFN,LRSS,LRIDT,LRDR1-1)) I LRDR>LRDR2!(LRDR<1) Q
S DA=LRIDT,Z=^LR(LRDFN,LRSS,LRIDT,0),Y=+Z,X=$P(Z,U,5) D DD^LRX
W !,"DATE&TIME: ",Y W:$L($P(Z,U,8)) ?35,"METHOD/SITE: ",$P(Z,U,8) W ?55,"ACC: ",$P(Z,U,6)
W !,"SPECIMEN: ",$S($D(^LAB(61,+X,0)):$P(^(0),U,1),1:"??"),!?2
S DR="0:9999999" K DX D EN^LRDIQ,WAIT Q
WAIT I $E(IOST,1,2)="C-" W !,PNM," ",SSN," PRESS '^' TO STOP " R X:DTIME S:$L(X) LREND=".^"[X Q
Q:$Y+6<IOSL W !! W:$E(IOST)="P" @IOF
HEAD W !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,SSN,?50,LRDT0,! Q
LRR ;RADIO IMMUNO ASSAY / NUCLEAR ENDOCRINOLOGY
D LPA G DONE:POP S LRSS="CH",LRDR1=734,LRDR2=774 G LPB
LRP ;SURGICAL PATHOLOGY
D LPA G DONE:POP S LRSS="SP" G LPB
MIC ;MICROBIOLOGY
D LPA G DONE:POP S LRSS="MI" G LPB
HIS ;HISTOLOGY & CYTOLOGY
D LPA G DONE:POP S LRSS="HI" G LPB
SER ;SEROLOGY
D LPA G DONE:POP S LRSS="CH",LRDR1=541,LRDR2=680 G LPB
LUR ;URINALYSIS
D LPA G DONE:POP S LRSS="CH",LRDR1=683,LRDR2=733 G LPB
HEM ;HEMATOLOGY
D LPA G DONE:POP S LRSS="CH",LRDR1=384,LRDR2=540 G LPB
DIFF ;DIFFERENTIAL
D LPA G DONE:POP S LRSS="CH",LRDR1=394,LRDR2=404 G LPB
LRA ;LISTS ALL LAB RESULTS
D LPA G DONE:POP S LRSS="CH",LRDR1=1,LRDR2=1000000 G LPB
DONE D ^%ZISC K LRDR,LRDR1,LRDR2,LRIDTE,LRIDTS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSOR 2909 printed Dec 13, 2024@02:20:23 Page 2
LRSOR ;SLC/RWF/CJS - SOME SPECIAL OUTPUT ROUTINES ;2/6/91 15:19 ;
+1 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
+2 DO ^LRDPA
if LRDFN<1
GOTO DONE
GOTO LRA
LRC ;NON SMAC CHEMISTRIES
+1 IF LRDFN<1
WRITE !,"NO DATA",!
QUIT
+2 READ !,"DO YOU WANT (R)IA TESTS, (N)ON SMAC TESTS, (H)EMA other than CBC: ",X:DTIME
+3 if "RNH"'[$EXTRACT(X,1)
QUIT
if $EXTRACT(X,1)="H"
GOTO HEM
if $EXTRACT(X,1)="R"
GOTO LRR
LRCC DO LPA
if POP
GOTO DONE
SET DIC=DIC_Q_"CH"","
+1 SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1
QUIT
SET LRMETH=$PIECE(^(LRIDT,0),U,8)
DO LROK
IF LROK
IF '(LRMETH="ASTRA"!(LRMETH="SMAC"))!$LENGTH($SELECT($DATA(^(40)):^(40),1:""))
SET DA=LRIDT
SET DR="0:99999999"
DO EN^LRDIQ
DO WAIT
if LREND
QUIT
WRITE !!
+2 GOTO DONE
LROK SET LROK=0
if '$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)
QUIT
SET LRZX=$ORDER(^LR(LRDFN,"CH",LRIDT,21))
if LRZX>0&(LRZX<384)
SET LROK=1
QUIT
LPA ;
+1 IF $DATA(LRPRETTY)
SET DIC="^LR("_LRDFN_","
SET Q=""""
SET LREND=0
SET LRIDTE=LRSDT
SET LRIDTS=LREDT
QUIT
+2 SET POP=1
if LRDFN<1
WRITE !,"NO DATA",!
if LRDFN<1
QUIT
LPT READ !,"Starting Date: N//",X:DTIME
if X["^"
QUIT
if X=""
SET X="N"
SET %DT="ETX"
DO ^%DT
if Y<1
GOTO LPT
+1 SET Y=9999999-Y
SET Y=$ORDER(^LR(LRDFN,"CH",Y-.00001))
SET X=9999999-Y
SET LRIDTE=Y-.00001
+2 WRITE !,"First data of any kind on ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
LPT1 READ !,"Number of days to check for data: 20//",X:DTIME
if X["^"
QUIT
if X=""
SET X=20
IF +X'=X!(X>99999)!(X<1)!(X?.E1"."1N.N)
WRITE !,"Type a number between 1 and 99999."
GOTO LPT1
+1 SET X="T-"_X
SET %DT="E"
DO ^%DT
SET LRIDTS=9999999-Y
if Y<1
GOTO LPT1
+2 KILL %ZIS
DO ^%ZIS
if POP
QUIT
+3 USE IO
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO DT^LRX
DO PT^LRX
DO HEAD
SET DIC="^LR("_LRDFN_","
SET Q=""""
SET LREND=0
QUIT
LPB if LRDFN<1
QUIT
SET DIC=DIC_Q_LRSS_Q_","
SET LRIDT=LRIDTE
FOR
SET LRIDT=$ORDER(^LR(LRDFN,LRSS,LRIDT))
if LRIDT<1
QUIT
if LRIDT>LRIDTS
QUIT
IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)
DO LPC
if LREND
QUIT
WRITE !
+1 GOTO DONE
LPC SET LRDR=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRDR1-1))
IF LRDR>LRDR2!(LRDR<1)
QUIT
+1 SET DA=LRIDT
SET Z=^LR(LRDFN,LRSS,LRIDT,0)
SET Y=+Z
SET X=$PIECE(Z,U,5)
DO DD^LRX
+2 WRITE !,"DATE&TIME: ",Y
if $LENGTH($PIECE(Z,U,8))
WRITE ?35,"METHOD/SITE: ",$PIECE(Z,U,8)
WRITE ?55,"ACC: ",$PIECE(Z,U,6)
+3 WRITE !,"SPECIMEN: ",$SELECT($DATA(^LAB(61,+X,0)):$PIECE(^(0),U,1),1:"??"),!?2
+4 SET DR="0:9999999"
KILL DX
DO EN^LRDIQ
DO WAIT
QUIT
WAIT IF $EXTRACT(IOST,1,2)="C-"
WRITE !,PNM," ",SSN," PRESS '^' TO STOP "
READ X:DTIME
if $LENGTH(X)
SET LREND=".^"[X
QUIT
+1 if $Y+6<IOSL
QUIT
WRITE !!
if $EXTRACT(IOST)="P"
WRITE @IOF
HEAD WRITE !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,SSN,?50,LRDT0,!
QUIT
LRR ;RADIO IMMUNO ASSAY / NUCLEAR ENDOCRINOLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=734
SET LRDR2=774
GOTO LPB
LRP ;SURGICAL PATHOLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="SP"
GOTO LPB
MIC ;MICROBIOLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="MI"
GOTO LPB
HIS ;HISTOLOGY & CYTOLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="HI"
GOTO LPB
SER ;SEROLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=541
SET LRDR2=680
GOTO LPB
LUR ;URINALYSIS
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=683
SET LRDR2=733
GOTO LPB
HEM ;HEMATOLOGY
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=384
SET LRDR2=540
GOTO LPB
DIFF ;DIFFERENTIAL
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=394
SET LRDR2=404
GOTO LPB
LRA ;LISTS ALL LAB RESULTS
+1 DO LPA
if POP
GOTO DONE
SET LRSS="CH"
SET LRDR1=1
SET LRDR2=1000000
GOTO LPB
DONE DO ^%ZISC
KILL LRDR,LRDR1,LRDR2,LRIDTE,LRIDTS
QUIT
