source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRLISTE.m@ 636

LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;2/19/91  10:39
 ;;5.2;LAB SERVICE;**201,318**;Sep 27, 1994
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
 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