LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 46
;;5.2;LAB SERVICE;**201,318**;NOV 01, 1997
EN ;
W !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",! K ^TMP($J) D DATE^LRWU G END:Y<1
S LRAD=Y,LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
S DIC="^LRO(68,",DIC(0)="AEQZ",LRNL=0,$P(LRDASH,"-",IOM)="",$P(LRDASH(2),"=",IOM)=""
F J=0:0 D ^DIC Q:Y<1 D CHKDAT^LRLSTWRL Q:Y<1 S DIC("A")="ANOTHER ONE: ",LRNL=LRNL+1,LRAA(LRNL)=+Y,LRAA(LRNL,1)=$P(Y,U,2),LRSS(LRNL)=$P(Y(0),U,2)
K DIC G EN:LRNL<1
C R !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME G END:LRX["^"!(LRX=""),C:"12"'[LRX!(LRX>2)
D RANGE
ALL W !!?5,"Do you wish to see all tests including Common Accessions " S %=1 D YN^DICN G:%=0 ALL G:%=-1 END S:%=1 LRALL=""
S %ZIS="MQ" D ^%ZIS G END:POP
I $D(IO("Q")) S ZTRTN="DQ^LRLISTE",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
C2 ;
U IO S $P(LRDASH(2),"=",IOM)="" D HDR G L10:LRX=1,L20:LRX=2,END
L10 I $D(LRALL) F LRAA=1:1:LRNL S L=LRFAN-1 F S L=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,L)) Q:(L>LRLAN)!(L<LRFAN) S ^TMP($J,L,LRAA)=""
I '$D(LRALL) F LRAA=1:1:LRNL S L=LRFAN-1 F S L=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,L)) Q:(L>LRLAN)!(L<LRFAN) I $O(^(L,4,0)) S ^TMP($J,L,LRAA)=""
S LRAN=0 F S LRAN=$O(^TMP($J,LRAN)) Q:LRAN<1 S LRAA=0 F S LRAA=$O(^TMP($J,LRAN,LRAA)) Q:LRAA<1 D PR G:$D(DTOUT)!($D(DUOUT)) END
W !!,"END OF REPORT",! G END
L20 F LRAA=1:1:LRNL D L22
S LRPNM=""
F S LRPNM=$O(^TMP($J,LRPNM)) Q:LRPNM="" S PNM=$P(LRPNM,U),SSN=$P(LRPNM,U,2) D L26 Q:$D(DTOUT)!($D(DUOUT))
G END
L22 S LRAN=LRFAN-1 F S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN) D L23
Q
L23 I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)) Q:'$D(^(3)) S LRDFN=+^(0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX S:$L(PNM) ^TMP($J,PNM_U_SSN,LRAA,LRAN)=DOB Q
L26 S LRAA=0 F S LRAA=$O(^TMP($J,LRPNM,LRAA)) Q:LRAA<1 D L28 Q:$D(DTOUT)!($D(DUOUT))
Q
L28 S LRAN=0 F S LRAN=$O(^TMP($J,LRPNM,LRAA,LRAN)) Q:LRAN<1 D PR Q:$D(DTOUT)!($D(DUOUT))
Q
PR Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3)) S LRIDT=9999999-^(3),LRDFN=+^(0),LRINT=$P(^(0),U,5),LRODT=$P(^(0),U,4) G PR1:LRAD<1
PR1 Q:$G(LREND) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D:$G(LRX)=1 DEM^LRX
I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
D LINECHK Q:$G(LREND)=1
; W !,LRDASH,!!,PNM,?40,SSN," ",LRAA(LRAA,1)," ACC: ",$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc") S:IOSL<66 S=S+3 D LINECHK Q:$G(LREND)=1
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
S HRCN="" S:+$G(DFN)>0 HRCN=$P($G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0)),"^",2) W !,LRDASH,!!,PNM,?40,HRCN," ",LRAA(LRAA,1)," ACC: ",$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc") S:IOSL<66 S=S+3 D LINECHK Q:$G(LREND)=1
; ----- END IHS/OIT/MKK - LR*5.2*1028
I LRINT S LRINT=$S($D(^LRO(69,LRODT,1,LRINT,0)):$P(^(0),U,2),1:"") I LRINT S LRINT=$P(^VA(200,LRINT,0),U,1) W !,"Person placing order: ",LRINT D LINECHK Q:$G(LREND)=1 S:IOSL<66 S=S+1
I LRLONG,$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) D
. K DR,DA S DA(3)=LRAA(LRAA),DA(2)=LRAD,DA(1)=LRAN,DIC="^LRO(68,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",4,",(DR,DA)=0 F S DA=$O(@(DIC_"DA)")) Q:'DA!($D(DTOUT))!($D(DUOUT)) D EN^LRDIQ D LINECHK Q:$G(LREND)=1
D LINECHK Q:$G(LREND)=1
W !,?40,$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"") S:IOSL<66 S=S+1
IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
S LRCP=$P(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
I LRCP="" S LRCP="UNKNOWN"
S LRSP=$P($G(^LAB(61,LRCP,0)),U) D LINECHK Q:$G(LREND)=1 W:$L(LRSP) ?65,LRSP S:IOSL<66 S=S+1
D LINECHK Q:$G(LREND)=1 W ! S DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""",",DR="0"_$S(LRLONG:":99999999",1:""),DA=LRIDT S:IOSL<66 S=S+1 D EN^LRDIQ
Q
END D ^%ZISC K ^TMP($J),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H,C1,D0,DA,DICS,DL,DSC,DX,L,LAST,LRAA,LRAD,LRALL,LRDASH,LRDX,LREDT,LREND,LRFAN,LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q"),LRSP
K DTOUT,DUOUT,DIC,LRCP Q
HDR I '$D(LRRPG) S LRRPG=1 G HD1
HD1 W @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
W " >> NOT FOR WARD USE <<" W:$L(LRRDT)=4 ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1) W !
W !,"ACCESSION AREA(S) :" F ZZ=1:1:LRNL W LRAA(ZZ,1)," "
W !,LRDASH(2)
S LRRPG=LRRPG+1
S:IOSL<66 S=2
Q
LINECHK ;
I IOST?1"P".E D PAGECHK Q
I $D(DX(0)) X DX(0)
I $D(DUOUT) S LREND=1
;I S>IOSL-2 S S=0
Q
PAGECHK ;
I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
Q
RANGE R !,"(L)ONG OR (S)HORT LISTING: S//",X:DTIME S LRLONG=(X["L") I X["?" W !?5,"Long listing shows verified results where short list does not",! G RANGE
D LRAN^LRWU3 Q
;
DQ U IO S:$D(ZTQUEUED) ZTREQ="@" G C2
LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 46
+2 ;;5.2;LAB SERVICE;**201,318**;NOV 01, 1997
EN ;
+1 WRITE !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",!
KILL ^TMP($JOB)
DO DATE^LRWU
IF Y<1
GOTO END
+2 SET LRAD=Y
SET LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
+3 SET DIC="^LRO(68,"
SET DIC(0)="AEQZ"
SET LRNL=0
SET $PIECE(LRDASH,"-",IOM)=""
SET $PIECE(LRDASH(2),"=",IOM)=""
+4 FOR J=0:0
DO ^DIC
IF Y<1
QUIT
DO CHKDAT^LRLSTWRL
IF Y<1
QUIT
SET DIC("A")="ANOTHER ONE: "
SET LRNL=LRNL+1
SET LRAA(LRNL)=+Y
SET LRAA(LRNL,1)=$PIECE(Y,U,2)
SET LRSS(LRNL)=$PIECE(Y(0),U,2)
+5 KILL DIC
IF LRNL<1
GOTO EN
C READ !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME
IF LRX["^"!(LRX="")
GOTO END
IF "12"'[LRX!(LRX>2)
GOTO C
+1 DO RANGE
ALL WRITE !!?5,"Do you wish to see all tests including Common Accessions "
SET %=1
DO YN^DICN
IF %=0
GOTO ALL
IF %=-1
GOTO END
IF %=1
SET LRALL=""
+1 SET %ZIS="MQ"
DO ^%ZIS
IF POP
GOTO END
+2 IF $DATA(IO("Q"))
SET ZTRTN="DQ^LRLISTE"
SET ZTIO=ION
SET ZTDESC="Summary List (Supervisors')"
SET ZTSAVE("LR*")=""
DO ^%ZTLOAD
GOTO END
C2 ;
+1 USE IO
SET $PIECE(LRDASH(2),"=",IOM)=""
DO HDR
IF LRX=1
GOTO L10
IF LRX=2
GOTO L20
GOTO END
L10 IF $DATA(LRALL)
FOR LRAA=1:1:LRNL
SET L=LRFAN-1
FOR
SET L=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,L))
IF (L>LRLAN)!(L<LRFAN)
QUIT
SET ^TMP($JOB,L,LRAA)=""
+1 IF '$DATA(LRALL)
FOR LRAA=1:1:LRNL
SET L=LRFAN-1
FOR
SET L=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,L))
IF (L>LRLAN)!(L<LRFAN)
QUIT
IF $ORDER(^(L,4,0))
SET ^TMP($JOB,L,LRAA)=""
+2 SET LRAN=0
FOR
SET LRAN=$ORDER(^TMP($JOB,LRAN))
IF LRAN<1
QUIT
SET LRAA=0
FOR
SET LRAA=$ORDER(^TMP($JOB,LRAN,LRAA))
IF LRAA<1
QUIT
DO PR
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
+3 WRITE !!,"END OF REPORT",!
GOTO END
L20 FOR LRAA=1:1:LRNL
DO L22
+1 SET LRPNM=""
+2 FOR
SET LRPNM=$ORDER(^TMP($JOB,LRPNM))
IF LRPNM=""
QUIT
SET PNM=$PIECE(LRPNM,U)
SET SSN=$PIECE(LRPNM,U,2)
DO L26
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 GOTO END
L22 SET LRAN=LRFAN-1
FOR
SET LRAN=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN))
IF LRAN<1!(LRAN>LRLAN)
QUIT
DO L23
+1 QUIT
L23 IF '$DATA(LRALL)
IF '$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0))
QUIT
+1 IF '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))
QUIT
IF '$DATA(^(3))
QUIT
SET LRDFN=+^(0)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO DEM^LRX
IF $LENGTH(PNM)
SET ^TMP($JOB,PNM_U_SSN,LRAA,LRAN)=DOB
QUIT
L26 SET LRAA=0
FOR
SET LRAA=$ORDER(^TMP($JOB,LRPNM,LRAA))
IF LRAA<1
QUIT
DO L28
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+1 QUIT
L28 SET LRAN=0
FOR
SET LRAN=$ORDER(^TMP($JOB,LRPNM,LRAA,LRAN))
IF LRAN<1
QUIT
DO PR
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+1 QUIT
PR IF '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3))
QUIT
SET LRIDT=9999999-^(3)
SET LRDFN=+^(0)
SET LRINT=$PIECE(^(0),U,5)
SET LRODT=$PIECE(^(0),U,4)
IF LRAD<1
GOTO PR1
PR1 IF $GET(LREND)
QUIT
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
IF $GET(LRX)=1
DO DEM^LRX
+1 ;ONLY FOR USE ON A PRINTER
IF IOST?1"P".E&($Y>(IOSL-16))
DO HDR
+2 DO LINECHK
IF $GET(LREND)=1
QUIT
+3 ; W !,LRDASH,!!,PNM,?40,SSN," ",LRAA(LRAA,1)," ACC: ",$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc") S:IOSL<66 S=S+3 D LINECHK Q:$G(LREND)=1
+4 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
+5 SET HRCN=""
IF +$GET(DFN)>0
SET HRCN=$PIECE($GET(^AUPNPAT(DFN,41,+$GET(DUZ(2)),0)),"^",2)
WRITE !,LRDASH,!!,PNM,?40,HRCN," ",LRAA(LRAA,1)," ACC: ",$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")
IF IOSL<66
SET S=S+3
DO LINECHK
IF $GET(LREND)=1
QUIT
+6 ; ----- END IHS/OIT/MKK - LR*5.2*1028
+7 IF LRINT
SET LRINT=$SELECT($DATA(^LRO(69,LRODT,1,LRINT,0)):$PIECE(^(0),U,2),1:"")
IF LRINT
SET LRINT=$PIECE(^VA(200,LRINT,0),U,1)
WRITE !,"Person placing order: ",LRINT
DO LINECHK
IF $GET(LREND)=1
QUIT
IF IOSL<66
SET S=S+1
+8 IF LRLONG
IF $ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0))
Begin DoDot:1
+9 KILL DR,DA
SET DA(3)=LRAA(LRAA)
SET DA(2)=LRAD
SET DA(1)=LRAN
SET DIC="^LRO(68,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",4,"
SET (DR,DA)=0
FOR
SET DA=$ORDER(@(DIC_"DA)"))
IF 'DA!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
DO EN^LRDIQ
DO LINECHK
IF $GET(LREND)=1
QUIT
End DoDot:1
+10 DO LINECHK
IF $GET(LREND)=1
QUIT
+11 WRITE !,?40,$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"")
IF IOSL<66
SET S=S+1
+12 IF '$DATA(^LR(LRDFN,LRSS(LRAA),LRIDT,0))
WRITE !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",!
QUIT
+13 SET LRCP=$PIECE(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
+14 IF LRCP=""
SET LRCP="UNKNOWN"
+15 SET LRSP=$PIECE($GET(^LAB(61,LRCP,0)),U)
DO LINECHK
IF $GET(LREND)=1
QUIT
IF $LENGTH(LRSP)
WRITE ?65,LRSP
IF IOSL<66
SET S=S+1
+16 DO LINECHK
IF $GET(LREND)=1
QUIT
WRITE !
SET DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""","
SET DR="0"_$SELECT(LRLONG:":99999999",1:"")
SET DA=LRIDT
IF IOSL<66
SET S=S+1
DO EN^LRDIQ
+17 QUIT
END DO ^%ZISC
KILL ^TMP($JOB),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H,C1,D0,DA,DICS,DL,DSC,DX,L,LAST,LRAA,LRAD,LRALL,LRDASH,LRDX,LREDT,LREND,LRFAN,LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q"),LRSP
+1 KILL DTOUT,DUOUT,DIC,LRCP
QUIT
HDR IF '$DATA(LRRPG)
SET LRRPG=1
GOTO HD1
HD1 WRITE @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
+1 WRITE " >> NOT FOR WARD USE <<"
IF $LENGTH(LRRDT)=4
WRITE ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1)
WRITE !
+2 WRITE !,"ACCESSION AREA(S) :"
FOR ZZ=1:1:LRNL
WRITE LRAA(ZZ,1)," "
+3 WRITE !,LRDASH(2)
+4 SET LRRPG=LRRPG+1
+5 IF IOSL<66
SET S=2
+6 QUIT
LINECHK ;
+1 IF IOST?1"P".E
DO PAGECHK
QUIT
+2 IF $DATA(DX(0))
XECUTE DX(0)
+3 IF $DATA(DUOUT)
SET LREND=1
+4 ;I S>IOSL-2 S S=0
+5 QUIT
PAGECHK ;
+1 ;ONLY FOR USE ON A PRINTER
IF IOST?1"P".E&($Y>(IOSL-16))
DO HDR
+2 QUIT
RANGE READ !,"(L)ONG OR (S)HORT LISTING: S//",X:DTIME
SET LRLONG=(X["L")
IF X["?"
WRITE !?5,"Long listing shows verified results where short list does not",!
GOTO RANGE
+1 DO LRAN^LRWU3
QUIT
+2 ;
DQ USE IO
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO C2
