source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRPHLIS1.m@ 1123

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1LRPHLIS1 ;SLC/CJS - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
2 ;;5.2;LAB SERVICE;**1,161**;Sep 27, 1994
3L1 ;
4 D PSET^LRLABLD ; Setup barcode variables
5 S LRLLOC=LRSTA,LRODT=DT
6 F S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC="" Q:(LRLLOC]LRFIN&(LRFIN'="")) D L2
7 K LRBAR0,LRBAR1
8 D KVA^VADPT
9 Q
10 ;
11L2 D HEAD:LRLL=1 D WARDHD:LRLL=2
12 S LRRB=""
13 F S LRRB=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB)) Q:LRRB="" D L3
14 Q
15 ;
16L3 S LRDFN=0
17 F S LRDFN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN)),LRPORD=0 Q:LRDFN<1 D L4
18 Q
19 ;
20L4 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRINFW=$S($D(^(.091)):$P(^(.091),U),1:"")
21 D
22 . N LRRB,LRLLOC,I ; Protect these variables, used in loop below.
23 . D PT^LRX
24 I $D(LRMULTI),$D(LRDIV) S LRDIVLOC=$S($D(^LR(LRDFN,.2)):^(.2),1:"") I LRDIVLOC,$P($G(^SC(LRDIVLOC,0)),U,4)'=LRDIV Q ;multidivison
25 S LRSN=0
26 F S LRSN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN)) Q:LRSN<1 S LRTJ=^(LRSN) D L5:LRLL=1,B5:LRLL=2
27 Q
28 ;
29L5 S LRTVOL=0,LRTOP=$P(^LAB(62,+LRTJ,0),U,3),LRURG=$S($D(^LAB(62.05,+$P(LRTJ,U,2),0)):$P(^(0),U),1:"ROUTINE"),LRODT=$P(LRTJ,U,3)
30 S LRAA=0
31 F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D L6
32 K LRBAR
33 Q
34 ;
35L6 S LRORD=$S($D(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:""),LRAD=$P(^LRO(68,LRAA,0),U,3),LRAD=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
36 I LRORD'=LRPORD S LRPORD=LRORD W !!?5,$S(LRRB=0:"",1:LRRB),?15,$E(PNM,1,28) W:$L(LRINFW) " INF WARN: ",LRINFW W ?45,SSN,?60,"Order #: ",LRORD
37 S LRWLEC=0 S LRAN=0 F S LRAN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) Q:LRAN<1 S LRWLEC=LRWLEC+1 W:LRWLEC>1 !! S LRACC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"") S LRTVOL=0 D REM,L7
38 Q
39L7 S T=0 F S T=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T)) Q:T<1 S LRTV=^(T) D S7 W !,?21,$E($P(^LAB(60,+LRTV,0),U),1,20) W:LRVOL>0 ?42,$J(LRVOL,6,1),"ML"
40 W ?52,LRTOP,?65,LRACC W:LRTVOL>0 !,?65,$J(LRTVOL,6,1),"ML T" Q
41S7 S LRVOL=0,LRSSP=0
42 F S LRSSP=$O(^LAB(60,+LRTV,3,LRSSP)) Q:LRSSP<1 I +LRTJ=+^(LRSSP,0) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL Q
43 Q
44 ;
45B5 S LRODT=$P(LRTJ,U,3)
46 Q:$D(^LRO(69,LRODT,1,LRSN,0))[0
47 S LRAA=0
48 F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D
49 . D LBLTYP^LRLABLD ; Get lab routine to use
50 . D LRBAR^LRLABLD
51 . D B6
52 K LRBAR
53 Q
54 ;
55B6 Q:$P(^LRO(68,LRAA,0),U,12) S LRAD=$P(^(0),U,3),LRAD=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
56 S LRAN=0
57 F S LRAN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) Q:LRAN<1 D B7
58 Q
59 ;
60B7 S:$L($G(LRRB)) LRRBX=LRRB
61 S LRACC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"") Q:LRACC']"" S LRCE=^(.1)
62 D GO^LRLABLD
63 S:$D(LRRBX) LRRB=LRRBX K LRRBX
64 Q
65 ;
66LRTOP S:$D(^LRO(68,LRAA,1,LRLBLD,1,LRAN,5,1,0)) LRTOP=+^(0),LRTOP=$S($D(^LAB(61,LRTOP,0)):$P(^(0),U),1:"") Q
67 Q
68 ;
69HEAD S N=$P(^LAB(69.9,1,5),"^",15) W @IOF,!!,?34,"COLLECTION LIST ",LRDT0,!,?34,N,$S(N=1:"ST",N=2:"ND",N=3:"RD",1:"TH")," PRINTING"
70 W !,"Ward",!,?5,"Bed",?15,"Name",?45,"SSN",?65,"Accession",!,LRLLOC
71 Q
72 ;
73REM S LREM=0,T=0 F S T=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T)) Q:T<1 S LREM=LREM+2
74 I $Y>(IOSL-LREM-4) D HEAD W !!?5,$S(LRRB=0:"",1:LRRB),?15,$E(PNM,1,28) W:$L(LRINFW) " PT INFO : ",LRINFW W ?45,SSN,?60,"Order #: ",LRORD,!
75 Q
76 ;
77WARDHD ;
78 N LRAA,LRACC,LRAD,LRAN,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRPREF,LRRB,LRTOP,LRTS,LRUID,LRURG0,LRURGA,LRXL
79 N I,N,PNM,SSN
80 Q:'$D(LRLLOC)#2
81 S PNM=LRLLOC,LRDAT="XX/XX/XX",SSN="XXX-XX-XXXX",LRACC=LRLLOC
82 S (LRAA,LRAD)=0,LRAN="0000",LRCE="000"
83 S LRRB=1,LRPREF="XXXXX",LRTOP=" ",LRTS(1)="DON'T USE",LRTS(2)="NEW LOCATION"
84 S LRURG0=9
85 D LBLTYP^LRLABLD ; Get lab routine to use
86 D LRBAR^LRLABLD
87 D UID^LRLABLD,BARID^LRLABLD
88 S LRURGA=$$URGA^LRLABLD(LRURG0)
89 S LRINFW=" ",I=1,N=1,LRXL=0
90 D @LRLABEL
91 Q
Note: See TracBrowser for help on using the repository browser.