1 | LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;2/19/91 10:39
|
---|
2 | ;;5.2;LAB SERVICE;**201,318**;Sep 27, 1994
|
---|
3 | EN ;
|
---|
4 | W !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",! K ^TMP($J) D DATE^LRWU G END:Y<1
|
---|
5 | S LRAD=Y,LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
|
---|
6 | S DIC="^LRO(68,",DIC(0)="AEQZ",LRNL=0,$P(LRDASH,"-",IOM)="",$P(LRDASH(2),"=",IOM)=""
|
---|
7 | 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)
|
---|
8 | K DIC G EN:LRNL<1
|
---|
9 | C R !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME G END:LRX["^"!(LRX=""),C:"12"'[LRX!(LRX>2)
|
---|
10 | D RANGE
|
---|
11 | 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=""
|
---|
12 | S %ZIS="MQ" D ^%ZIS G END:POP
|
---|
13 | I $D(IO("Q")) S ZTRTN="DQ^LRLISTE",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
|
---|
14 | C2 ;
|
---|
15 | U IO S $P(LRDASH(2),"=",IOM)="" D HDR G L10:LRX=1,L20:LRX=2,END
|
---|
16 | 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)=""
|
---|
17 | 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)=""
|
---|
18 | 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
|
---|
19 | W !!,"END OF REPORT",! G END
|
---|
20 | L20 F LRAA=1:1:LRNL D L22
|
---|
21 | S LRPNM=""
|
---|
22 | 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))
|
---|
23 | G END
|
---|
24 | L22 S LRAN=LRFAN-1 F S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN) D L23
|
---|
25 | Q
|
---|
26 | L23 I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
|
---|
27 | 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
|
---|
28 | L26 S LRAA=0 F S LRAA=$O(^TMP($J,LRPNM,LRAA)) Q:LRAA<1 D L28 Q:$D(DTOUT)!($D(DUOUT))
|
---|
29 | Q
|
---|
30 | L28 S LRAN=0 F S LRAN=$O(^TMP($J,LRPNM,LRAA,LRAN)) Q:LRAN<1 D PR Q:$D(DTOUT)!($D(DUOUT))
|
---|
31 | Q
|
---|
32 | 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
|
---|
33 | PR1 Q:$G(LREND) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D:$G(LRX)=1 DEM^LRX
|
---|
34 | I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
|
---|
35 | D LINECHK Q:$G(LREND)=1
|
---|
36 | 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
|
---|
37 | 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
|
---|
38 | I LRLONG,$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) D
|
---|
39 | . 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
|
---|
40 | D LINECHK Q:$G(LREND)=1
|
---|
41 | W !,?40,$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"") S:IOSL<66 S=S+1
|
---|
42 | IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
|
---|
43 | S LRCP=$P(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
|
---|
44 | I LRCP="" S LRCP="UNKNOWN"
|
---|
45 | 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
|
---|
46 | 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
|
---|
47 | Q
|
---|
48 | 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
|
---|
49 | K DTOUT,DUOUT,DIC,LRCP Q
|
---|
50 | HDR I '$D(LRRPG) S LRRPG=1 G HD1
|
---|
51 | HD1 W @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
|
---|
52 | W " >> NOT FOR WARD USE <<" W:$L(LRRDT)=4 ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1) W !
|
---|
53 | W !,"ACCESSION AREA(S) :" F ZZ=1:1:LRNL W LRAA(ZZ,1)," "
|
---|
54 | W !,LRDASH(2)
|
---|
55 | S LRRPG=LRRPG+1
|
---|
56 | S:IOSL<66 S=2
|
---|
57 | Q
|
---|
58 | LINECHK ;
|
---|
59 | I IOST?1"P".E D PAGECHK Q
|
---|
60 | I $D(DX(0)) X DX(0)
|
---|
61 | I $D(DUOUT) S LREND=1
|
---|
62 | ;I S>IOSL-2 S S=0
|
---|
63 | Q
|
---|
64 | PAGECHK ;
|
---|
65 | I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
|
---|
66 | Q
|
---|
67 | 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
|
---|
68 | D LRAN^LRWU3 Q
|
---|
69 | ;
|
---|
70 | DQ U IO S:$D(ZTQUEUED) ZTREQ="@" G C2
|
---|