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

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