92 lines
3.8 KiB
Mathematica
92 lines
3.8 KiB
Mathematica
LRPHLIS1 ;SLC/CJS - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
|
|
;;5.2;LAB SERVICE;**1,161**;Sep 27, 1994
|
|
L1 ;
|
|
D PSET^LRLABLD ; Setup barcode variables
|
|
S LRLLOC=LRSTA,LRODT=DT
|
|
F S LRLLOC=$O(^LRO(69.1,"LRPH",1,LRLLOC)) Q:LRLLOC="" Q:(LRLLOC]LRFIN&(LRFIN'="")) D L2
|
|
K LRBAR0,LRBAR1
|
|
D KVA^VADPT
|
|
Q
|
|
;
|
|
L2 D HEAD:LRLL=1 D WARDHD:LRLL=2
|
|
S LRRB=""
|
|
F S LRRB=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB)) Q:LRRB="" D L3
|
|
Q
|
|
;
|
|
L3 S LRDFN=0
|
|
F S LRDFN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN)),LRPORD=0 Q:LRDFN<1 D L4
|
|
Q
|
|
;
|
|
L4 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRINFW=$S($D(^(.091)):$P(^(.091),U),1:"")
|
|
D
|
|
. N LRRB,LRLLOC,I ; Protect these variables, used in loop below.
|
|
. D PT^LRX
|
|
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
|
|
S LRSN=0
|
|
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
|
|
Q
|
|
;
|
|
L5 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)
|
|
S LRAA=0
|
|
F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D L6
|
|
K LRBAR
|
|
Q
|
|
;
|
|
L6 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)
|
|
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
|
|
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
|
|
Q
|
|
L7 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"
|
|
W ?52,LRTOP,?65,LRACC W:LRTVOL>0 !,?65,$J(LRTVOL,6,1),"ML T" Q
|
|
S7 S LRVOL=0,LRSSP=0
|
|
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
|
|
Q
|
|
;
|
|
B5 S LRODT=$P(LRTJ,U,3)
|
|
Q:$D(^LRO(69,LRODT,1,LRSN,0))[0
|
|
S LRAA=0
|
|
F S LRAA=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA)) Q:LRAA<1 D
|
|
. D LBLTYP^LRLABLD ; Get lab routine to use
|
|
. D LRBAR^LRLABLD
|
|
. D B6
|
|
K LRBAR
|
|
Q
|
|
;
|
|
B6 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)
|
|
S LRAN=0
|
|
F S LRAN=$O(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) Q:LRAN<1 D B7
|
|
Q
|
|
;
|
|
B7 S:$L($G(LRRB)) LRRBX=LRRB
|
|
S LRACC=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"") Q:LRACC']"" S LRCE=^(.1)
|
|
D GO^LRLABLD
|
|
S:$D(LRRBX) LRRB=LRRBX K LRRBX
|
|
Q
|
|
;
|
|
LRTOP 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
|
|
Q
|
|
;
|
|
HEAD 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"
|
|
W !,"Ward",!,?5,"Bed",?15,"Name",?45,"SSN",?65,"Accession",!,LRLLOC
|
|
Q
|
|
;
|
|
REM 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
|
|
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,!
|
|
Q
|
|
;
|
|
WARDHD ;
|
|
N LRAA,LRACC,LRAD,LRAN,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRPREF,LRRB,LRTOP,LRTS,LRUID,LRURG0,LRURGA,LRXL
|
|
N I,N,PNM,SSN
|
|
Q:'$D(LRLLOC)#2
|
|
S PNM=LRLLOC,LRDAT="XX/XX/XX",SSN="XXX-XX-XXXX",LRACC=LRLLOC
|
|
S (LRAA,LRAD)=0,LRAN="0000",LRCE="000"
|
|
S LRRB=1,LRPREF="XXXXX",LRTOP=" ",LRTS(1)="DON'T USE",LRTS(2)="NEW LOCATION"
|
|
S LRURG0=9
|
|
D LBLTYP^LRLABLD ; Get lab routine to use
|
|
D LRBAR^LRLABLD
|
|
D UID^LRLABLD,BARID^LRLABLD
|
|
S LRURGA=$$URGA^LRLABLD(LRURG0)
|
|
S LRINFW=" ",I=1,N=1,LRXL=0
|
|
D @LRLABEL
|
|
Q
|