- LRLLP2 ;IHS/OIT/MKK - TRAY LIST PRINT ; 03/16/2005
- ;;5.2;LR;**1004,1018,1019**;MAR 25, 2005
- ;;5.2;LAB SERVICE;**116,153**;Sep 27, 1994
- ; Original line 1: SLC/RWF - TRAY LIST PRINT ;2/5/91 14:37 ; [ 04/14/2003 9:15 AM ]
- S:'LRTYPE LRTRAY=LRST S (LREXIT,LREND,LRPROF)=0,X=$O(^LRO(68.2,LRINST,1,LRTRAY)) I X S Y=$O(^(X,1,0)) I Y S LRPROF=+$P(^(Y,0),U,4)
- S LRFSTP=1
- D LOOP,END Q
- Q
- LOOP F S LRTRAY=$O(^LRO(68.2,LRINST,1,LRTRAY)) Q:LRTRAY<1!(LRTRAY>LRLLT)!(LREND) S LRDC=1 D CUP Q:LREND!($G(LREXIT)) S LRCUP=0
- Q
- CUP F II=0:0 S LRCUP=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)) Q:LRCUP=""!($G(LREXIT)) D LP2 S LREND=$S('LRTYPE&(LRCUP>LRLLT):1,'LRTYPE&(LRCUP=LRLLT):1,1:0) Q:LREND
- Q
- LP2 S LRLL=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:""),LRTEST="" I LRPROF'=+$P(LRLL,U,4) S LRPROF=+$P(LRLL,U,4) K:LRDC'=LRPROF PNM S LRDC=LRPROF
- Q:LRLL="" D HED:$Y+8>IOSL!(LRDC) Q:$G(LREXIT)
- W ! W:'LRALTH "TRAY:",$J(LRTRAY,3)," CUP:",$J(LRCUP,3) D LRLINE Q
- LRLINE S LRAA=+LRLL,LRAD=+$P(LRLL,U,2),LRAN=+$P(LRLL,U,3) D MOVE^LRLLP4:$D(^TMP($J,LRPROF))=0
- S LRDFN=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:"")
- I LRDFN="" K ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP) D DASH^LRX Q ; IF NOTHING THERE, GET RID OF IT
- K ^TMP("LR",$J,"T"),LRTSTS S LRTEST="",LRURG=99 G BLANK:LRLL=""
- S J=0 F S J=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,J)) Q:J<1 S X=$P(^(J,0),U,2),^TMP("LR",$J,"T",J)="",LRTEST=LRTEST_J_U S:X<LRURG LRURG=+X
- I LRXPD K ^TMP("LR",$J,"T"),LRTSTS,LRORD D ^LREXPD
- K LRTEST,LRORD F I=0:0 S I=$O(^TMP("LR",$J,"T",I)) Q:I'>0 S LRORD($S($D(^TMP($J,LRPROF,I)):^(I),1:I+999))=I
- LP4 S LRACC=^LRO(68,LRAA,1,LRAD,1,LRAN,.2) W:$X=0 LRACC
- I $L(LRDFN) S LRLLOC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7),LRDOC=$P(^(0),U,8),LRODNUM=$S($D(^(.1)):^(.1),1:""),LRIDT=$S($D(^(3)):9999999-^(3),1:0),LRSPEC=$S($D(^(5,1,0)):+^(0),1:0),LRSISPEC=+$P(^(0),U,2)
- I $L(LRDFN) S LRSPEC=$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U),1:""),LRSISPEC=$S($D(^LAB(62,LRSISPEC,0)):$P(^(0),U),1:"")
- S X=LRDOC,LRLLOC=LRLLOC_" "_$S($D(LRURG(LRURG)):LRURG(LRURG),1:"") D DOC^LRX
- S DFN=+$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2),LRV=0,LRV=$S($D(^LR(LRDFN,"CH",LRIDT,0)):$P(^(0),U,3),1:0) D PT^LRX
- ;W ?18,$E(PNM,1,17) W:LRDPF=2 ?36,$E(SSN,$L(SSN)-3,$L(SSN)) W:LRDPF'=2 ?36,SSN(2),! W ?42,LRACC W:LRV ?52,"Ver" W ?63,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- W ?18,$E(PNM,1,17) W:LRDPF=2 ?36,HRCN W:LRDPF'=2 ?36,SSN(2),! W ?42,LRACC W:LRV ?52,"Ver" W ?63,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- S Y=9999999-LRIDT D ADD^LRX W !,?18,Y,?42,$E(LRDOC,1,18),?63," #:",LRODNUM D INF^LRX
- LP3 ;
- I 'LRSHORT F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+4)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W !,?18,$E(LRLINE,1,31) W:LRLLOC]"" ?56,LRLLOC S LRLLOC="" W !,?18,$P(^LAB(60,I,0),"^",1),?50,LRSPEC D LRSPEC
- Q:$G(LREXIT)
- I LRSHORT W !?18,$E(LRLINE,1,31),?56,LRSPEC D LRSPEC W !?18 F J=0:0 S J=$O(LRORD(J)) Q:J<1 D:($Y+4)>IOSL HED,SH Q:$G(LREXIT) S I=LRORD(J) W:$X>19 ", " W $P(^LAB(60,I,0),"^",1) I $X>50 W !?18
- Q:$G(LREXIT)
- I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI" W:$D(^LR(LRDFN,"MI",LRIDT,99)) !?20,^(99)
- W !,LRLINE,$E(LRLINE,1,39) Q
- LP5 S L=$P(^TMP("LR",$J,"T",I),U,5),L=$P(L,";",2) I LRIDT,$D(^LR(LRDFN,"CH",LRIDT,L)) W ?37,$J(^(L),8)
- W:LRV ?45,"Ver" Q
- Q
- BLANK W !,LRLINE,$E(LRLINE,1,39) Q
- HED ;
- D:$E(IOST,1,2)="C-" TERM
- Q:$G(LREXIT)
- W:LRDC!(IOSL\2<$Y) @IOF
- W !!,$S(LRTYPE>0:"LOAD",1:"WORK"),"-LIST FOR ",$P(^LRO(68.2,LRINST,0),U,1),$S($D(^LRO(68.2,LRINST,10,LRPROF,0)):" (Profile: "_$P(^(0),U,1)_")",1:""),?55,LRNOW
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- The LRLL variable can be null; correcting for that
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- ; S:'$D(LRAA) LRAA=LRLL D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
- S:'$D(LRAA) LRAA=+$G(LRLL) D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
- ;----- END IHS MODIFICATIONS
- ;----- END IHS MODIFICATIONS LR*5.2*1019
- W !,?18,"Name",?36,"ID#",?42,"Acc #",?63,"UID",!,?18,"Collection Date/Time",?42,"Provider",?63,"Order #",!,LRLINE,$E(LRLINE,1,39)
- I '$D(PNM) S LRDC=0 Q
- W !,"Cont'd"
- W:LRSHORT !,?18
- S LRDC=0 Q
- TERM I $G(LRFSTP) K LRFSTP Q
- S DIR(0)="E" D ^DIR S:$D(DIRUT) LREXIT=1 K DIR,DIRUT,Y,X
- Q
- SH Q:$G(LREXIT)
- W ?18,$E(PNM,1,17) W:LRDPF=2 ?36,$E(SSN,$L(SSN)-3,$L(SSN)) W:LRDPF'=2 ?36,SSN(2),! W ?42,LRACC W:LRV ?52,"Ver" W ?60," #:",LRODNUM S Y=9999999-LRIDT D ADD^LRX W !,?18,Y,?42,LRDOC D INF^LRX
- Q
- END K LRFSTP,LREND,LRDC W !
- I $E(IOST,1,2)="C-",'$G(LREXIT) D TERM
- W:$E(IOST,1,2)="P-" @IOF
- D ^%ZISC Q
- LRSPEC ;
- I $D(LRAA),$D(^LRO(68,+LRAA,0)),$P(^(0),U,2)="MI",$D(LRSISPEC),$L(LRSISPEC) S TAB=$S(LRSHORT:56,1:50) W !,?TAB,LRSISPEC K TAB
- Q
- LRLLP2 ;IHS/OIT/MKK - TRAY LIST PRINT ; 03/16/2005
- +1 ;;5.2;LR;**1004,1018,1019**;MAR 25, 2005
- +2 ;;5.2;LAB SERVICE;**116,153**;Sep 27, 1994
- +3 ; Original line 1: SLC/RWF - TRAY LIST PRINT ;2/5/91 14:37 ; [ 04/14/2003 9:15 AM ]
- +4 IF 'LRTYPE
- SET LRTRAY=LRST
- SET (LREXIT,LREND,LRPROF)=0
- SET X=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
- IF X
- SET Y=$ORDER(^(X,1,0))
- IF Y
- SET LRPROF=+$PIECE(^(Y,0),U,4)
- +5 SET LRFSTP=1
- +6 DO LOOP
- DO END
- QUIT
- +7 QUIT
- LOOP FOR
- SET LRTRAY=$ORDER(^LRO(68.2,LRINST,1,LRTRAY))
- IF LRTRAY<1!(LRTRAY>LRLLT)!(LREND)
- QUIT
- SET LRDC=1
- DO CUP
- IF LREND!($GET(LREXIT))
- QUIT
- SET LRCUP=0
- +1 QUIT
- CUP FOR II=0:0
- SET LRCUP=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP))
- IF LRCUP=""!($GET(LREXIT))
- QUIT
- DO LP2
- SET LREND=$SELECT('LRTYPE&(LRCUP>LRLLT):1,'LRTYPE&(LRCUP=LRLLT):1,1:0)
- IF LREND
- QUIT
- +1 QUIT
- LP2 SET LRLL=$SELECT($DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
- SET LRTEST=""
- IF LRPROF'=+$PIECE(LRLL,U,4)
- SET LRPROF=+$PIECE(LRLL,U,4)
- IF LRDC'=LRPROF
- KILL PNM
- SET LRDC=LRPROF
- +1 IF LRLL=""
- QUIT
- IF $Y+8>IOSL!(LRDC)
- DO HED
- IF $GET(LREXIT)
- QUIT
- +2 WRITE !
- IF 'LRALTH
- WRITE "TRAY:",$JUSTIFY(LRTRAY,3)," CUP:",$JUSTIFY(LRCUP,3)
- DO LRLINE
- QUIT
- LRLINE SET LRAA=+LRLL
- SET LRAD=+$PIECE(LRLL,U,2)
- SET LRAN=+$PIECE(LRLL,U,3)
- IF $DATA(^TMP($JOB,LRPROF))=0
- DO MOVE^LRLLP4
- +1 SET LRDFN=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):+^(0),1:"")
- +2 ; IF NOTHING THERE, GET RID OF IT
- IF LRDFN=""
- KILL ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP)
- DO DASH^LRX
- QUIT
- +3 KILL ^TMP("LR",$JOB,"T"),LRTSTS
- SET LRTEST=""
- SET LRURG=99
- IF LRLL=""
- GOTO BLANK
- +4 SET J=0
- FOR
- SET J=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,J))
- IF J<1
- QUIT
- SET X=$PIECE(^(J,0),U,2)
- SET ^TMP("LR",$JOB,"T",J)=""
- SET LRTEST=LRTEST_J_U
- IF X<LRURG
- SET LRURG=+X
- +5 IF LRXPD
- KILL ^TMP("LR",$JOB,"T"),LRTSTS,LRORD
- DO ^LREXPD
- +6 KILL LRTEST,LRORD
- FOR I=0:0
- SET I=$ORDER(^TMP("LR",$JOB,"T",I))
- IF I'>0
- QUIT
- SET LRORD($SELECT($DATA(^TMP($JOB,LRPROF,I)):^(I),1:I+999))=I
- LP4 SET LRACC=^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
- IF $X=0
- WRITE LRACC
- +1 IF $LENGTH(LRDFN)
- SET LRLLOC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)
- SET LRDOC=$PIECE(^(0),U,8)
- SET LRODNUM=$SELECT($DATA(^(.1)):^(.1),1:"")
- SET LRIDT=$SELECT($DATA(^(3)):9999999-^(3),1:0)
- SET LRSPEC=$SELECT($DATA(^(5,1,0)):+^(0),1:0)
- SET LRSISPEC=+$PIECE(^(0),U,2)
- +2 IF $LENGTH(LRDFN)
- SET LRSPEC=$SELECT($DATA(^LAB(61,LRSPEC,0)):$PIECE(^(0),U),1:"")
- SET LRSISPEC=$SELECT($DATA(^LAB(62,LRSISPEC,0)):$PIECE(^(0),U),1:"")
- +3 SET X=LRDOC
- SET LRLLOC=LRLLOC_" "_$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
- DO DOC^LRX
- +4 SET DFN=+$PIECE(^LR(LRDFN,0),U,3)
- SET LRDPF=+$PIECE(^(0),U,2)
- SET LRV=0
- SET LRV=$SELECT($DATA(^LR(LRDFN,"CH",LRIDT,0)):$PIECE(^(0),U,3),1:0)
- DO PT^LRX
- +5 ;W ?18,$E(PNM,1,17) W:LRDPF=2 ?36,$E(SSN,$L(SSN)-3,$L(SSN)) W:LRDPF'=2 ?36,SSN(2),! W ?42,LRACC W:LRV ?52,"Ver" W ?63,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
- +6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +7 ;IHS/ANMC/CLS 08/18/96
- WRITE ?18,$EXTRACT(PNM,1,17)
- IF LRDPF=2
- WRITE ?36,HRCN
- IF LRDPF'=2
- WRITE ?36,SSN(2),!
- WRITE ?42,LRACC
- IF LRV
- WRITE ?52,"Ver"
- WRITE ?63,$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
- +8 ;----- END IHS MODIFICATIONS
- +9 SET Y=9999999-LRIDT
- DO ADD^LRX
- WRITE !,?18,Y,?42,$EXTRACT(LRDOC,1,18),?63," #:",LRODNUM
- DO INF^LRX
- LP3 ;
- +1 IF 'LRSHORT
- FOR J=0:0
- SET J=$ORDER(LRORD(J))
- IF J<1
- QUIT
- IF ($Y+4)>IOSL
- DO HED
- DO SH
- IF $GET(LREXIT)
- QUIT
- SET I=LRORD(J)
- WRITE !,?18,$EXTRACT(LRLINE,1,31)
- IF LRLLOC]""
- WRITE ?56,LRLLOC
- SET LRLLOC=""
- WRITE !,?18,$PIECE(^LAB(60,I,0),"^",1),?50,LRSPEC
- DO LRSPEC
- +2 IF $GET(LREXIT)
- QUIT
- +3 IF LRSHORT
- WRITE !?18,$EXTRACT(LRLINE,1,31),?56,LRSPEC
- DO LRSPEC
- WRITE !?18
- FOR J=0:0
- SET J=$ORDER(LRORD(J))
- IF J<1
- QUIT
- IF ($Y+4)>IOSL
- DO HED
- DO SH
- IF $GET(LREXIT)
- QUIT
- SET I=LRORD(J)
- IF $X>19
- WRITE ", "
- WRITE $PIECE(^LAB(60,I,0),"^",1)
- IF $X>50
- WRITE !?18
- +4 IF $GET(LREXIT)
- QUIT
- +5 IF $DATA(LRAA)
- IF $DATA(^LRO(68,+LRAA,0))
- IF $PIECE(^(0),U,2)="MI"
- IF $DATA(^LR(LRDFN,"MI",LRIDT,99))
- WRITE !?20,^(99)
- +6 WRITE !,LRLINE,$EXTRACT(LRLINE,1,39)
- QUIT
- LP5 SET L=$PIECE(^TMP("LR",$JOB,"T",I),U,5)
- SET L=$PIECE(L,";",2)
- IF LRIDT
- IF $DATA(^LR(LRDFN,"CH",LRIDT,L))
- WRITE ?37,$JUSTIFY(^(L),8)
- +1 IF LRV
- WRITE ?45,"Ver"
- QUIT
- +2 QUIT
- BLANK WRITE !,LRLINE,$EXTRACT(LRLINE,1,39)
- QUIT
- HED ;
- +1 IF $EXTRACT(IOST,1,2)="C-"
- DO TERM
- +2 IF $GET(LREXIT)
- QUIT
- +3 IF LRDC!(IOSL\2<$Y)
- WRITE @IOF
- +4 WRITE !!,$SELECT(LRTYPE>0:"LOAD",1:"WORK"),"-LIST FOR ",$PIECE(^LRO(68.2,LRINST,0),U,1),$SELECT($DATA(^LRO(68.2,LRINST,10,LRPROF,0)):" (Profile: "_$PIECE(^(0),U,1)_")",1:""),?55,LRNOW
- +5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 -- The LRLL variable can be null; correcting for that
- +6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +7 ; S:'$D(LRAA) LRAA=LRLL D:LRDC LRENT2^LRWLHEAD W ! ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
- +8 ;IHS/ANMC/CLS 08/18/96 print worklist heading on first page only
- IF '$DATA(LRAA)
- SET LRAA=+$GET(LRLL)
- IF LRDC
- DO LRENT2^LRWLHEAD
- WRITE !
- +9 ;----- END IHS MODIFICATIONS
- +10 ;----- END IHS MODIFICATIONS LR*5.2*1019
- +11 WRITE !,?18,"Name",?36,"ID#",?42,"Acc #",?63,"UID",!,?18,"Collection Date/Time",?42,"Provider",?63,"Order #",!,LRLINE,$EXTRACT(LRLINE,1,39)
- +12 IF '$DATA(PNM)
- SET LRDC=0
- QUIT
- +13 WRITE !,"Cont'd"
- +14 IF LRSHORT
- WRITE !,?18
- +15 SET LRDC=0
- QUIT
- TERM IF $GET(LRFSTP)
- KILL LRFSTP
- QUIT
- +1 SET DIR(0)="E"
- DO ^DIR
- IF $DATA(DIRUT)
- SET LREXIT=1
- KILL DIR,DIRUT,Y,X
- +2 QUIT
- SH IF $GET(LREXIT)
- QUIT
- +1 WRITE ?18,$EXTRACT(PNM,1,17)
- IF LRDPF=2
- WRITE ?36,$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
- IF LRDPF'=2
- WRITE ?36,SSN(2),!
- WRITE ?42,LRACC
- IF LRV
- WRITE ?52,"Ver"
- WRITE ?60," #:",LRODNUM
- SET Y=9999999-LRIDT
- DO ADD^LRX
- WRITE !,?18,Y,?42,LRDOC
- DO INF^LRX
- +2 QUIT
- END KILL LRFSTP,LREND,LRDC
- WRITE !
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF '$GET(LREXIT)
- DO TERM
- +2 IF $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- +3 DO ^%ZISC
- QUIT
- LRSPEC ;
- +1 IF $DATA(LRAA)
- IF $DATA(^LRO(68,+LRAA,0))
- IF $PIECE(^(0),U,2)="MI"
- IF $DATA(LRSISPEC)
- IF $LENGTH(LRSISPEC)
- SET TAB=$SELECT(LRSHORT:56,1:50)
- WRITE !,?TAB,LRSISPEC
- KILL TAB
- +2 QUIT
