Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLISTE

LRLISTE.m

Go to the documentation of this file.
  1. LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;2/19/91 10:39
  1. ;;5.2;LAB SERVICE;**201,318**;Sep 27, 1994
  1. EN ;
  1. W !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",! K ^TMP($J) D DATE^LRWU G END:Y<1
  1. S LRAD=Y,LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
  1. S DIC="^LRO(68,",DIC(0)="AEQZ",LRNL=0,$P(LRDASH,"-",IOM)="",$P(LRDASH(2),"=",IOM)=""
  1. 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)
  1. K DIC G EN:LRNL<1
  1. C R !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME G END:LRX["^"!(LRX=""),C:"12"'[LRX!(LRX>2)
  1. D RANGE
  1. 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=""
  1. S %ZIS="MQ" D ^%ZIS G END:POP
  1. I $D(IO("Q")) S ZTRTN="DQ^LRLISTE",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
  1. C2 ;
  1. U IO S $P(LRDASH(2),"=",IOM)="" D HDR G L10:LRX=1,L20:LRX=2,END
  1. 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)=""
  1. 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)=""
  1. 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
  1. W !!,"END OF REPORT",! G END
  1. L20 F LRAA=1:1:LRNL D L22
  1. S LRPNM=""
  1. 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))
  1. G END
  1. L22 S LRAN=LRFAN-1 F S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN) D L23
  1. Q
  1. L23 I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
  1. 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
  1. L26 S LRAA=0 F S LRAA=$O(^TMP($J,LRPNM,LRAA)) Q:LRAA<1 D L28 Q:$D(DTOUT)!($D(DUOUT))
  1. Q
  1. L28 S LRAN=0 F S LRAN=$O(^TMP($J,LRPNM,LRAA,LRAN)) Q:LRAN<1 D PR Q:$D(DTOUT)!($D(DUOUT))
  1. Q
  1. 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
  1. PR1 Q:$G(LREND) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D:$G(LRX)=1 DEM^LRX
  1. I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
  1. D LINECHK Q:$G(LREND)=1
  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
  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
  1. I LRLONG,$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) D
  1. . 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
  1. D LINECHK Q:$G(LREND)=1
  1. W !,?40,$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"") S:IOSL<66 S=S+1
  1. IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
  1. S LRCP=$P(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
  1. I LRCP="" S LRCP="UNKNOWN"
  1. 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
  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
  1. Q
  1. 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
  1. K DTOUT,DUOUT,DIC,LRCP Q
  1. HDR I '$D(LRRPG) S LRRPG=1 G HD1
  1. HD1 W @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
  1. W " >> NOT FOR WARD USE <<" W:$L(LRRDT)=4 ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1) W !
  1. W !,"ACCESSION AREA(S) :" F ZZ=1:1:LRNL W LRAA(ZZ,1)," "
  1. W !,LRDASH(2)
  1. S LRRPG=LRRPG+1
  1. S:IOSL<66 S=2
  1. Q
  1. LINECHK ;
  1. I IOST?1"P".E D PAGECHK Q
  1. I $D(DX(0)) X DX(0)
  1. I $D(DUOUT) S LREND=1
  1. ;I S>IOSL-2 S S=0
  1. Q
  1. PAGECHK ;
  1. I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
  1. Q
  1. 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
  1. D LRAN^LRWU3 Q
  1. ;
  1. DQ U IO S:$D(ZTQUEUED) ZTREQ="@" G C2