source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRLLP5.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1LRLLP5 ;SLC/RWA/MILW/JMC- EXPANDED TRAY LIST PRINT ;2/5/91 14:39 ;
2 ;;5.2;LAB SERVICE;**116,153**;Sep 27, 1994
3 S:'LRTYPE LRTRAY=LRST S (LREXIT,LREND,LRPROF)=0,X=$O(^LRO(68.2,LRINST,1,LRTRAY)) I X S Y=$O(^(X,1,0)) I Y S LRPROF=+$P(^(Y,0),U,4)
4 S LRFSTP=1
5 D LOOP,END Q
6 Q
7LOOP F S LRTRAY=$O(^LRO(68.2,LRINST,1,LRTRAY)) Q:LRTRAY<1!(LRTRAY>LRLLT)!(LREND) S LRDC=1 D CUP Q:LREND!($G(LREXIT)) S LRCUP=0
8 Q
9CUP F II=0:0 S LRCUP=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)) Q:LRCUP=""!($G(LREXIT)) D LP2 S LREND=$S('LRTYPE&(LRCUP>LRLLT):1,'LRTYPE&(LRCUP=LRLLT):1,1:0) Q:LREND
10 Q
11LP2 S LRLL=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:""),LRTEST="" I LRPROF'=+$P(LRLL,U,4) S LRPROF=+$P(LRLL,U,4) K:LRDC'=LRPROF PNM S LRDC=LRPROF
12 Q:LRLL="" D HED:$Y+8>IOSL!(LRDC) Q:$G(LREXIT)
13 I LRTYPE W ! W:'LRALTH "TRAY:",$J(LRTRAY,3)," CUP:",$J(LRCUP,3) D LRLINE Q
14 I 'LRTYPE W ! W:'LRALTH "SEQ: ",$J(LRCUP,4) D LRLINE Q
15 W ! W:'LRALTH "TRAY:",$J(LRTRAY,3)," CUP:",$J(LRCUP,3) D LRLINE Q
16LRLINE S LRAA=+LRLL,LRAD=+$P(LRLL,U,2),LRAN=+$P(LRLL,U,3) D MOVE^LRLLP4:$D(^TMP($J,LRPROF))=0
17 S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:"")
18 I LRDFN="" K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) D DASH^LRX Q ; IF NOTHING THERE, GET RID OF IT
19 K ^TMP("LR",$J,"T"),LRTSTS S LRTEST="",LRURG=99 G BLANK:LRLL=""
20 S J=0 F S J=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,J)) Q:J<1 S X=$P(^(J,0),U,2),^TMP("LR",$J,"T",J)="",LRTEST=LRTEST_J_U S:X<LRURG LRURG=+X
21 I LRXPD K ^TMP("LR",$J,"T"),LRTSTS,LRORD D ^LREXPD
22 K LRTEST,LRORD F I=0:0 S I=$O(^TMP("LR",$J,"T",I)) Q:I'>0 S LRORD($S($D(^TMP($J,LRPROF,I)):^(I),1:I+999))=I
23LP4 S LRACC=^LRO(68,LRAA,1,LRAD,1,LRAN,.2) W:$X=0 LRACC
24 I $L(LRDFN) S LRLLOC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7),LRDOC=$P(^(0),U,8),LRCDT=$P(^(3),U,1),LRIDT=$S($D(^(3)):9999999-^(3),1:0)
25 S LRSPEC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)):+^(0),1:0),LRSISPEC=+$P(^(0),U,2),LRSPEC=$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U,1),1:"")
26 S LRSISPEC=$S($D(^LAB(62,LRSISPEC,0)):$P(^(0),U),1:"")
27 S X=LRDOC,LRLLOC=LRLLOC_" "_$S($D(LRURG(LRURG)):LRURG(LRURG),1:"") D DOC^LRX
28 S DFN=+$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2),LRV=0,LRV=$S($D(^LR(LRDFN,"CH",LRIDT,0)):$P(^(0),U,3),1:0) D PT^LRX
29 W ?20 W:LRDPF=2 $E(PNM,1,30),?50,SSN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y D LEDI
30LP3 ;
31 I 'LRSHORT F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+5)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W !,?18,$E(LRLINE,1,31) W:LRLLOC]"" ?56,LRLLOC S LRLLOC="" W !,?18,$P(^LAB(60,I,0),"^",1),?50,LRSPEC D LRSPEC
32 Q:$G(LREXIT)
33 I LRSHORT W !?18,$E(LRLINE,1,31),?56,LRSPEC D LRSPEC W !?18 F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+5)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W:$X>19 ", " W $P(^LAB(60,I,0),"^",1) I $X>50 W !?18
34 Q:$G(LREXIT)
35 I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI" W:$D(^LR(LRDFN,"MI",LRIDT,99)) !?20,^(99)
36 D DASH^LRX Q
37LP5 S L=$P(^TMP("LR",$J,"T",I),U,5),L=$P(L,";",2) I LRIDT,$D(^LR(LRDFN,"CH",LRIDT,L)) W ?37,$J(^(L),8)
38 W:LRV ?45,"Ver" Q
39 Q
40BLANK D DASH^LRX Q
41HED ;
42 D:$E(IOST,1,2)="C-" TERM
43 Q:$G(LREXIT)
44 W:LRDC!(IOSL\2<$Y) @IOF
45 ;W:LRDC!($Y>(IOSL-$S($E(IOST,1,2)="C-":4,1:8))) @IOF
46 W !!,$S(LRTYPE>0:"LOAD",1:"WORK"),"-LIST FOR ",$P(^LRO(68.2,LRINST,0),U,1),$S($D(^LRO(68.2,LRINST,10,LRPROF,0)):" (Profile: "_$P(^(0),U,1)_")",1:""),?112,LRNOW
47 W !,?18,"Name",?50,"ID#",?64,"Acc #",?86,"Requested By",?110,"Coll. Date/Time"
48 D DASH^LRX I '$D(PNM) S LRDC=0 Q
49 W !,"Cont'd"
50 S LRDC=0
51 Q
52SH Q:$G(LREXIT)
53 W ?20 W:LRDPF=2 $E(PNM,1,30),?50,SSN W:LRDPF'=2 $E(PNM_" "_SSN(2),1,60) W ?64,LRACC W:LRV ?76,"Ver" W ?86,$E(LRDOC,1,20) S Y=LRCDT D ADD^LRX W ?110,Y,!
54 W:LRSHORT !,?18
55 Q
56TERM I $G(LRFSTP) K LRFSTP Q
57 S DIR(0)="E" D ^DIR S:$D(DIRUT) LREXIT=1 K DIR,DIRUT,Y,X
58 Q
59END K LRFSTP,II,LREND W !
60 I $E(IOST,1,2)="C-",'$G(LREXIT) D TERM
61 W:$E(IOST,1,2)'="C-" @IOF
62 D ^%ZISC Q
63LRSPEC ;
64 I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI",$D(LRSISPEC),$L(LRSISPEC) S TAB=$S(LRSHORT:56,1:50) W !,?TAB,LRSISPEC K TAB
65 Q
66LEDI ; print UID and LEDI information
67 N LRUIDX S LRUIDX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)) W !,?64,"UID: ",$P(LRUIDX,"^")
68 S Y=$P(LRUIDX,"^",2) I Y S C=$P(^DD(68.02,16.1,0),"^",2) D Y^DIQ W ?86,"Ordering Site: "_$E(Y,1,20),!
69 S X=$P(LRUIDX,"^",5) I X'="" W ?86,"Ordering Site UID: "_X,!
70 S Y=$P(LRUIDX,"^",3) I Y,Y'=$P(LRUIDX,"^",2) S C=$P(^DD(68.02,16.2,0),"^",2) D Y^DIQ W ?86,"Collecting Site: "_$E(Y,1,20),!
71 S X=$P(LRUIDX,"^",4) I X'="",X'=$P(LRUIDX,"^") W ?86,"Host UID: "_X
72 Q
Note: See TracBrowser for help on using the repository browser.