source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRSOR.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1LRSOR ;SLC/RWF/CJS - SOME SPECIAL OUTPUT ROUTINES ;2/6/91 15:19 ;
2 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
3 D ^LRDPA G DONE:LRDFN<1 G LRA
4LRC ;NON SMAC CHEMISTRIES
5 I LRDFN<1 W !,"NO DATA",! Q
6 R !,"DO YOU WANT (R)IA TESTS, (N)ON SMAC TESTS, (H)EMA other than CBC: ",X:DTIME
7 Q:"RNH"'[$E(X,1) G HEM:$E(X,1)="H",LRR:$E(X,1)="R"
8LRCC D LPA G DONE:POP S DIC=DIC_Q_"CH"","
9 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 !!
10 G DONE
11LROK 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
12LPA ;
13 I $D(LRPRETTY) S DIC="^LR("_LRDFN_",",Q="""",LREND=0,LRIDTE=LRSDT,LRIDTS=LREDT Q
14 S POP=1 W:LRDFN<1 !,"NO DATA",! Q:LRDFN<1
15LPT R !,"Starting Date: N//",X:DTIME Q:X["^" S:X="" X="N" S %DT="ETX" D ^%DT G LPT:Y<1
16 S Y=9999999-Y,Y=$O(^LR(LRDFN,"CH",Y-.00001)),X=9999999-Y,LRIDTE=Y-.00001
17 W !,"First data of any kind on ",$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)
18LPT1 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
19 S X="T-"_X,%DT="E" D ^%DT S LRIDTS=9999999-Y G LPT1:Y<1
20 K %ZIS D ^%ZIS Q:POP
21 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
22LPB 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 !
23 G DONE
24LPC S LRDR=$O(^LR(LRDFN,LRSS,LRIDT,LRDR1-1)) I LRDR>LRDR2!(LRDR<1) Q
25 S DA=LRIDT,Z=^LR(LRDFN,LRSS,LRIDT,0),Y=+Z,X=$P(Z,U,5) D DD^LRX
26 W !,"DATE&TIME: ",Y W:$L($P(Z,U,8)) ?35,"METHOD/SITE: ",$P(Z,U,8) W ?55,"ACC: ",$P(Z,U,6)
27 W !,"SPECIMEN: ",$S($D(^LAB(61,+X,0)):$P(^(0),U,1),1:"??"),!?2
28 S DR="0:9999999" K DX D EN^LRDIQ,WAIT Q
29WAIT I $E(IOST,1,2)="C-" W !,PNM," ",SSN," PRESS '^' TO STOP " R X:DTIME S:$L(X) LREND=".^"[X Q
30 Q:$Y+6<IOSL W !! W:$E(IOST)="P" @IOF
31HEAD W !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,SSN,?50,LRDT0,! Q
32LRR ;RADIO IMMUNO ASSAY / NUCLEAR ENDOCRINOLOGY
33 D LPA G DONE:POP S LRSS="CH",LRDR1=734,LRDR2=774 G LPB
34LRP ;SURGICAL PATHOLOGY
35 D LPA G DONE:POP S LRSS="SP" G LPB
36MIC ;MICROBIOLOGY
37 D LPA G DONE:POP S LRSS="MI" G LPB
38HIS ;HISTOLOGY & CYTOLOGY
39 D LPA G DONE:POP S LRSS="HI" G LPB
40SER ;SEROLOGY
41 D LPA G DONE:POP S LRSS="CH",LRDR1=541,LRDR2=680 G LPB
42LUR ;URINALYSIS
43 D LPA G DONE:POP S LRSS="CH",LRDR1=683,LRDR2=733 G LPB
44HEM ;HEMATOLOGY
45 D LPA G DONE:POP S LRSS="CH",LRDR1=384,LRDR2=540 G LPB
46DIFF ;DIFFERENTIAL
47 D LPA G DONE:POP S LRSS="CH",LRDR1=394,LRDR2=404 G LPB
48LRA ;LISTS ALL LAB RESULTS
49 D LPA G DONE:POP S LRSS="CH",LRDR1=1,LRDR2=1000000 G LPB
50DONE D ^%ZISC K LRDR,LRDR1,LRDR2,LRIDTE,LRIDTS Q
Note: See TracBrowser for help on using the repository browser.