source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLABELF.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: 3.6 KB
Line 
1LRLABELF ;SLC/CJS/DALISC/DRH - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
2 ;;5.2;LAB SERVICE;**121,161**;Sep 27, 1994
3 ; Called by LRLABLDS,LRLABLD0
4INIT ;
5 U IO
6 S (PAGE,LREND,CNT)=0,LRPRTDT=$$NOW^XLFDT
7 I LRPICK=1,$E(IOST,1,2)="C-" W @IOF
8EN ;
9 S LRODT=""
10 F S LRODT=$O(^TMP($J,"LR",LRODT)) Q:LRODT=""!($G(LREND)) D
11 . S LRCT=""
12 . F S LRCT=$O(^TMP($J,"LR",LRODT,LRCT)) Q:LRCT=""!($G(LREND)) D
13 . . S LRCLOC=""
14 . . F S LRCLOC=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC)) Q:LRCLOC=""!($G(LREND)) D
15 . . . I LRPICK=1 D HEAD
16 . . . S LRPNM=""
17 . . . F S LRPNM=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC,LRPNM)) Q:LRPNM=""!($G(LREND)) D PAT
18 . I LRPICK=1 D
19 . . S PAGE=0
20 . . I $E(IOST,1,2)="C-" W !!
21 . . E W @IOF
22 Q
23 ;
24HEAD ;
25 Q:$G(LREND)
26 I PAGE D
27 . I $E(IOST,1,2)="C-" D EOP
28 . W @IOF
29 S PAGE=PAGE+1,LRHEAD=$$FMTE^XLFDT(LRODT)_" "_"Future Collection List"
30 W !,$$CJ^XLFSTR(LRHEAD,IOM)
31 S LRPAGE="Page: "_PAGE
32 W !,"Print Date@Time : ",$$FMTE^XLFDT(LRPRTDT),?60,LRPAGE
33 W !!,$$CJ^XLFSTR(LRCLOC,IOM,"-")
34 W !,$$CJ^XLFSTR("WARD LOC/REQ LOC ",IOM," ")
35 Q
36HDR ;
37 D HEAD
38PHDR W:$G(CHDR) !?20,"< CONTINUATION >"
39 S LRNEW=PNM
40 W !,PNM I $L($G(LRRB))>1 W ?32,LRRB
41 W ?42,SSN,?57,"Order #: ",LRCE
42 W:$L($G(^LR(+LRNODE0,.091))) !?4,"Pat Info: ",^(.091)
43 S LRPCT=$$FMTE^XLFDT(LRCT,1) S:$P(LRPCT,"@",2) LRPCT=$P(LRPCT,"@",2)_" "_$P(LRPCT,"@")
44 W !?5,LRPCT,?25,"[ "_LRTYPE_" ]"
45 N LRURG S NODE=LRNODE0,(S2,LRTVOL)=0
46 D T^LRLABLD0
47 S LRTOP=$P($G(^LAB(62,+$P(LRNODE0,U,3),0)),U,3) I $L(LRTOP) S S2=$P(^(0),U,5)
48 W !?28,$S(S2="":" ",LRTVOL>S2:"Large ",1:"Small "),LRTOP," ",$S($G(LRTVOL):LRTVOL,1:1)," mL ",!
49 Q
50 ;
51CHDR ;
52 W !?10,"<CONTINUE NEXT PAGE # "_PAGE+1_" >"
53 S CHDR=1 D PHDR S CHDR=0
54 Q
55 ;
56PAT ;
57 S LRSNN=""
58 F S LRSNN=$O(^TMP($J,"LR",LRODT,LRCT,LRCLOC,LRPNM,LRSNN)) Q:LRSNN=""!($G(LREND)) D
59 . W:LRPICK=1 !
60 . K LRNEW
61 . D PRINT
62 Q
63PRINT ;
64 S LRSN=+$P(LRSNN,"*",2)
65 Q:'$D(^LRO(69,LRODT,1,LRSN,0))#2 S LRNODE0=^(0),LRCE=$G(^(.1)) Q:'LRCE
66 I LRPICK=2 D SETUP^LRLABLD0 Q ; Print labels
67 S LRDFN=+LRNODE0 K LRDPF
68 D PT^LRX Q:$G(LREND)!(+LRDPF'=2)
69 Q:$G(LREND)
70 S LRTYPE="",LRPORD=1,LRTOP=$P($G(^LAB(62,+$P(LRNODE0,U,3),0)),U)
71 S LRORD=$G(^LRO(69,LRODT,1,LRSN,.1))
72 I $L($P(LRNODE0,U,4)) S LRTYPE=$G(LRCOLTY($P(LRNODE0,U,4))) ; Collection type
73 I LRTYPE="" S LRTYPE="Unknown"
74 I $Y>(IOSL-4) D HDR
75 S LRSP=0 I '$D(LRNEW) D PHDR S LRNEW=LRPNM
76 I LRNEW'=LRPNM D PHDR
77 F TAB=5:35 S LRSP=$O(^LRO(69,LRODT,1,LRSN,2,LRSP)) Q:LRSP<1 D
78 . N LRURGA
79 . Q:'$D(^LRO(69,LRODT,1,LRSN,2,LRSP,0))
80 . S LRTEST=^LRO(69,LRODT,1,LRSN,2,LRSP,0),LRURGN=$P(LRTEST,U,2) S:'LRURGN LRURGN=9
81 . I $P(LRTEST,"^",11) Q ; Test cancelled
82 . S LRURGA=$$URGA^LRLABLD(+LRURGN)
83 . S LRTEST=$P($G(^LAB(60,+$P(LRTEST,U),0)),U)
84 . I TAB>45 S TAB=5 W ! I $Y>(IOSL-4) D HDR
85 . W ?TAB,$S(LRURGN<3:"** ",1:"")," (",$P(LRURGA,"^"),") ",LRTEST
86 Q
87DEV ;
88 K %ZIS S %ZIS="" D ^%ZIS Q:POP
89 U IO D INIT W !! W:$E(IOST,1,2)'="C-" @IOF
90 D ^%ZISC
91 Q
92 ;
93EOP ; End-of-page
94 N DIR,DIRUT,DTOUT,DUOUT,X,Y
95 S DIR(0)="E"
96 D ^DIR
97 I $D(DIRUT) S LREND=1
98 Q
99 ;
100END ;
101 ; Called by LRLABLD0, LRLABLDS
102 I $G(LRPICK)=1 W:$E(IOST,1,2)'="C-" @IOF
103 I $D(ZTQUEUED) S ZTREQ="@"
104 E D ^%ZISC
105 D KVA^VADPT
106 K ^TMP($J)
107 K A,DIR,DUOUT,DTOUT,DIRUT
108 K LRBARID,LRCOLTY,LREND,LRHEAD,LRNODE0,LRORD,LRPCT,LRUID
109 K LRPERH,LRPERT,LRSP,LRTEST,LRTYPE,LRURGN,TAB
110 K LRWRD,LRLOCF1,LRLOCF,LRCHLOC,LRDPF,J,S,C,%ZIS,%DT,DIC,DFN,I,L9,LRACC,LRCE,LRCLTY,LRDAT
111 K LRPRAC,CNT,LRCLOC,LRCT,LRNEWL,LRORDN,LRPICK,LRPNM,LRSING,LRSNN,LRTREA
112 K PAGE,D0,D1,LRPRTDT
113 K LRDFN,LRINFW,LRLABEL,LRLLOC,LRODT,LRCT0,LRPREF,LRRB,LRSN,LRSSP
114 K LRTJ,LRTJDATA,LRTOP,LRTS,LRTV,LRTVOL,LRURG,LRURGA,LRURG0,LN,LRSTOP,LRTIC
115 K LRDTC,LRTXT,LRVOL,LRXL,N,NODE,S1,S2,T,Y,Y1,Y2
116 K ZTSAVE,ZTIO,ZTRTN,ZTDESC
117 K AGE,DOB,PNM,SEX,SSN,POP,E,VA,LRY1,VAERR,X
118 Q
Note: See TracBrowser for help on using the repository browser.