- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPHLIS1 3970 printed Jan 18, 2025@03:20:05 Page 2
- LRPHLIS1 ;SLC/CJS - PRINT COLLECTION LIST (CONT.) ; 3/28/89 19:39
- +1 ;;5.2;LAB SERVICE;**1,161**;Sep 27, 1994
- L1 ;
- +1 ; Setup barcode variables
- DO PSET^LRLABLD
- +2 SET LRLLOC=LRSTA
- SET LRODT=DT
- +3 FOR
- SET LRLLOC=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC))
- if LRLLOC=""
- QUIT
- if (LRLLOC]LRFIN&(LRFIN'=""))
- QUIT
- DO L2
- +4 KILL LRBAR0,LRBAR1
- +5 DO KVA^VADPT
- +6 QUIT
- +7 ;
- L2 if LRLL=1
- DO HEAD
- if LRLL=2
- DO WARDHD
- +1 SET LRRB=""
- +2 FOR
- SET LRRB=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB))
- if LRRB=""
- QUIT
- DO L3
- +3 QUIT
- +4 ;
- L3 SET LRDFN=0
- +1 FOR
- SET LRDFN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN))
- SET LRPORD=0
- if LRDFN<1
- QUIT
- DO L4
- +2 QUIT
- +3 ;
- L4 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- SET LRINFW=$SELECT($DATA(^(.091)):$PIECE(^(.091),U),1:"")
- +1 Begin DoDot:1
- +2 ; Protect these variables, used in loop below.
- NEW LRRB,LRLLOC,I
- +3 DO PT^LRX
- End DoDot:1
- +4 ;multidivison
- IF $DATA(LRMULTI)
- IF $DATA(LRDIV)
- SET LRDIVLOC=$SELECT($DATA(^LR(LRDFN,.2)):^(.2),1:"")
- IF LRDIVLOC
- IF $PIECE($GET(^SC(LRDIVLOC,0)),U,4)'=LRDIV
- QUIT
- +5 SET LRSN=0
- +6 FOR
- SET LRSN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN))
- if LRSN<1
- QUIT
- SET LRTJ=^(LRSN)
- if LRLL=1
- DO L5
- if LRLL=2
- DO B5
- +7 QUIT
- +8 ;
- L5 SET LRTVOL=0
- SET LRTOP=$PIECE(^LAB(62,+LRTJ,0),U,3)
- SET LRURG=$SELECT($DATA(^LAB(62.05,+$PIECE(LRTJ,U,2),0)):$PIECE(^(0),U),1:"ROUTINE")
- SET LRODT=$PIECE(LRTJ,U,3)
- +1 SET LRAA=0
- +2 FOR
- SET LRAA=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA))
- if LRAA<1
- QUIT
- DO L6
- +3 KILL LRBAR
- +4 QUIT
- +5 ;
- L6 SET LRORD=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):^(.1),1:"")
- SET LRAD=$PIECE(^LRO(68,LRAA,0),U,3)
- SET LRAD=$SELECT(LRAD="Y":$EXTRACT(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$EXTRACT(DT,1,5)_"00","Q"[LRAD:$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
- +1 IF LRORD'=LRPORD
- SET LRPORD=LRORD
- WRITE !!?5,$SELECT(LRRB=0:"",1:LRRB),?15,$EXTRACT(PNM,1,28)
- if $LENGTH(LRINFW)
- WRITE " INF WARN: ",LRINFW
- WRITE ?45,SSN,?60,"Order #: ",LRORD
- +2 SET LRWLEC=0
- SET LRAN=0
- FOR
- SET LRAN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
- if LRAN<1
- QUIT
- SET LRWLEC=LRWLEC+1
- if LRWLEC>1
- WRITE !!
- SET LRACC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"")
- SET LRTVOL=0
- DO REM
- DO L7
- +3 QUIT
- L7 SET T=0
- FOR
- SET T=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T))
- if T<1
- QUIT
- SET LRTV=^(T)
- DO S7
- WRITE !,?21,$EXTRACT($PIECE(^LAB(60,+LRTV,0),U),1,20)
- if LRVOL>0
- WRITE ?42,$JUSTIFY(LRVOL,6,1),"ML"
- +1 WRITE ?52,LRTOP,?65,LRACC
- if LRTVOL>0
- WRITE !,?65,$JUSTIFY(LRTVOL,6,1),"ML T"
- QUIT
- S7 SET LRVOL=0
- SET LRSSP=0
- +1 FOR
- SET LRSSP=$ORDER(^LAB(60,+LRTV,3,LRSSP))
- if LRSSP<1
- QUIT
- IF +LRTJ=+^(LRSSP,0)
- SET LRVOL=$PIECE(^(0),U,4)
- SET LRTVOL=LRTVOL+LRVOL
- QUIT
- +2 QUIT
- +3 ;
- B5 SET LRODT=$PIECE(LRTJ,U,3)
- +1 if $DATA(^LRO(69,LRODT,1,LRSN,0))[0
- QUIT
- +2 SET LRAA=0
- +3 FOR
- SET LRAA=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA))
- if LRAA<1
- QUIT
- Begin DoDot:1
- +4 ; Get lab routine to use
- DO LBLTYP^LRLABLD
- +5 DO LRBAR^LRLABLD
- +6 DO B6
- End DoDot:1
- +7 KILL LRBAR
- +8 QUIT
- +9 ;
- B6 if $PIECE(^LRO(68,LRAA,0),U,12)
- QUIT
- SET LRAD=$PIECE(^(0),U,3)
- SET LRAD=$SELECT(LRAD="Y":$EXTRACT(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$EXTRACT(DT,1,5)_"00","Q"[LRAD:$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
- +1 SET LRAN=0
- +2 FOR
- SET LRAN=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
- if LRAN<1
- QUIT
- DO B7
- +3 QUIT
- +4 ;
- B7 if $LENGTH($GET(LRRB))
- SET LRRBX=LRRB
- +1 SET LRACC=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)):^(.2),1:"")
- if LRACC']""
- QUIT
- SET LRCE=^(.1)
- +2 DO GO^LRLABLD
- +3 if $DATA(LRRBX)
- SET LRRB=LRRBX
- KILL LRRBX
- +4 QUIT
- +5 ;
- LRTOP if $DATA(^LRO(68,LRAA,1,LRLBLD,1,LRAN,5,1,0))
- SET LRTOP=+^(0)
- SET LRTOP=$SELECT($DATA(^LAB(61,LRTOP,0)):$PIECE(^(0),U),1:"")
- QUIT
- +1 QUIT
- +2 ;
- HEAD SET N=$PIECE(^LAB(69.9,1,5),"^",15)
- WRITE @IOF,!!,?34,"COLLECTION LIST ",LRDT0,!,?34,N,$SELECT(N=1:"ST",N=2:"ND",N=3:"RD",1:"TH")," PRINTING"
- +1 WRITE !,"Ward",!,?5,"Bed",?15,"Name",?45,"SSN",?65,"Accession",!,LRLLOC
- +2 QUIT
- +3 ;
- REM SET LREM=0
- SET T=0
- FOR
- SET T=$ORDER(^LRO(69.1,"LRPH",1,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,T))
- if T<1
- QUIT
- SET LREM=LREM+2
- +1 IF $Y>(IOSL-LREM-4)
- DO HEAD
- WRITE !!?5,$SELECT(LRRB=0:"",1:LRRB),?15,$EXTRACT(PNM,1,28)
- if $LENGTH(LRINFW)
- WRITE " PT INFO : ",LRINFW
- WRITE ?45,SSN,?60,"Order #: ",LRORD,!
- +2 QUIT
- +3 ;
- WARDHD ;
- +1 NEW LRAA,LRACC,LRAD,LRAN,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRPREF,LRRB,LRTOP,LRTS,LRUID,LRURG0,LRURGA,LRXL
- +2 NEW I,N,PNM,SSN
- +3 if '$DATA(LRLLOC)#2
- QUIT
- +4 SET PNM=LRLLOC
- SET LRDAT="XX/XX/XX"
- SET SSN="XXX-XX-XXXX"
- SET LRACC=LRLLOC
- +5 SET (LRAA,LRAD)=0
- SET LRAN="0000"
- SET LRCE="000"
- +6 SET LRRB=1
- SET LRPREF="XXXXX"
- SET LRTOP=" "
- SET LRTS(1)="DON'T USE"
- SET LRTS(2)="NEW LOCATION"
- +7 SET LRURG0=9
- +8 ; Get lab routine to use
- DO LBLTYP^LRLABLD
- +9 DO LRBAR^LRLABLD
- +10 DO UID^LRLABLD
- DO BARID^LRLABLD
- +11 SET LRURGA=$$URGA^LRLABLD(LRURG0)
- +12 SET LRINFW=" "
- SET I=1
- SET N=1
- SET LRXL=0
- +13 DO @LRLABEL
- +14 QUIT