LRLIST ;DALOI/STAFF - LAB RESULTS LIST ;05/06/13
;;5.2;LAB SERVICE;**44,86,153,201,427**;Sep 27, 1994;Build 33
;
;
W !,"Summary List (Supervisors') >>> NOT FOR WARD USE <<<",!
;
EN K ^TMP("LR",$J),LRAA
D DATE^LRWU G END:Y<1 S LRAD=Y,DIC="^LRO(68,",DIC(0)="AEQ",LRNL=0
S LRRDT=$$FMTE^XLFDT(Y,1)
F 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(^LRO(68,LRAA(LRNL),0),U,2)
K DIC G EN:$G(LRNL)<1
S LRDATE=-1
I $P(^LRO(68,LRAA(1),0),U,2)="MI" S %DT("A")="Report date approved to display: " D DATE^LRWU G END:$G(LREND) S LRDATE=Y
;
C K DIRUT,DIR S DIR("A")="List By",DIR(0)="S^1:ACCESSION NUMBER;2:PATIENT"
D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
S LRX=Y
D RANGE G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) C
;
INST K DIR S DIR(0)="PO^4:AQENM",DIR("A")="Optional - Select Collecting Institution "
F D ^DIR Q:Y=""!($E(Y=U))!(Y<1) S:Y LRINST=+Y,LRINST(LRINST)="",DIR("A")="Select Another Collecting Institution "
K DIR,DIRUT G:$E(Y)=U END
;
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^LRLIST",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
;
C2 ;
S $P(LREQ,"=",IOM)="",S=1 K DX S DX(0)="Q"
I $E(IOST,1,2)="C-" S DX(0)="S S=$Y I S>(IOSL-8) N X,Y K DIR S DIR(0)=""E"" D ^DIR K DIR S S=$S($D(DIRUT):0,1:1) Q:$D(DIRUT) W @IOF D HDR^LRLIST S S=$S($D(DIRUT):0,1:1)"
I IOST?1"P".E S DX(0)="S S=$Y I S>(IOSL-8) W @IOF D HDR^LRLIST S S=$Y"
U IO D HDR G L10:LRX=1,L20:LRX=2,END
;
L10 ;
I $D(LRALL) F LRAA=1:1:LRNL F LRL=LRFAN-1:0 S LRL=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL)) Q:(LRL>LRLAN)!(LRL<LRFAN)!(S=0) S ^TMP("LR",$J,LRL,LRAA)=""
I '$D(LRALL) F LRAA=1:1:LRNL S LRL=LRFAN-1 F S LRL=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL)) Q:(LRL>LRLAN)!(LRL<LRFAN) I $O(^(LRL,4,0)) S ^TMP("LR",$J,LRL,LRAA)=""
F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,LRAN)) Q:LRAN<1!($D(DIRUT))!($D(DUOUT))!($D(DUOUT)) F LRAA=0:0 S LRAA=$O(^TMP("LR",$J,LRAN,LRAA)) Q:LRAA<1 D PR Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
W !! G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
W "END OF REPORT",! G END
;
;
L20 ;
F LRAA=1:1:LRNL D L22 Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
S LRPNM=""
F S LRPNM=$O(^TMP("LR",$J,LRPNM)) Q:LRPNM=""!($D(DTOUT))!($D(DUOUT))!($D(DIRUT)) S PNM=$P(LRPNM,U),SSN=$P(LRPNM,U,2) D L26
W !! G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END
W !,"END OF REPORT",! G END
;
;
L22 ;
F LRAN=LRFAN-1:0 S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN)!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0) D L23
Q
;
;
L23 ;
I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
I $G(LRINST),'$D(LRINST(+$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3))) 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("LR",$J,PNM_U_SSN,LRAA,LRAN)=DOB Q
;
;
L26 ;
F LRAA=0:0 S LRAA=$O(^TMP("LR",$J,LRPNM,LRAA)) Q:LRAA<1!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0) D L28
Q
;
;
L28 ;
F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,LRPNM,LRAA,LRAN)) Q:LRAN<1!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(S=0) D PR
Q
;
;
PR ;
I '$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)) W !!?10," Accession ",LRAN," deleted ",!!,$C(7) Q
I $G(LRINST),'$D(LRINST(+$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3))) Q
Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3))
S LRIDT=9999999-^(3),LRDFN=+^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),LRINT=$P(^(0),U,5),LRODT=$P(^(0),U,4) G PR1:LRDATE<1
S LRSET=0
F I=1,5,8,11,16 I $D(^LR(LRDFN,"MI",LRIDT,I)),((+^(I))\1)=LRDATE S LRSET=1 Q
Q:'LRSET
;
PR1 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX
;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y K DIR S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0) W @IOF D HDR S S=$Y
;I IOST?1"P".E&($Y>(IOSL-6)) W @IOF D HDR ;ONLY FOR USE ON A PRINTER
X DX(0) Q:S=0
;
D DASH^LRX
W !!,PNM,?40,SSN,!,LRAA(LRAA,1)," ACC: ",$S($D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")
W ?45,$S($D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORDER #: "_^(.1),1:"")
I LRINT D
. N LRX
. S LRX=$P($G(^LRO(69,LRODT,1,LRINT,0)),U,2)
. I LRX S LRX=$$NAME^XUSER(LRX,"F") W !,"Person placing order: ",LRX
;
I $D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4)) D
. N LRX
. S LRIN=+$O(^(4,"B",0))
. I LRIN,$D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4,LRIN)) D
. . S LRIN=$P($G(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4,LRIN,0)),U,4)
. . I LRIN<1 Q
. . S LRX=$$NAME^XUSER(LRIN,"F")
. . I LRX'="" W " Person performing test: ",$E(LRX,1,(IOM-($X+1)))
X DX(0) Q:S=0
;
I '$D(LRSS(+$G(LRAA))) W !," ACCESSION #: ",LRAN," HAS AN ERROR NOTIFY SYSTEM MANAGER >>> ",!! Q
IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
;
W ! S DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""",",DR="0"_$S(LRLONG:":99999999",1:""),DA=LRIDT
X DX(0) Q:S=0 D EN^LRDIQ Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
I $G(LRLONG)=2 F DR="ORU","ORUT" Q:S=0 X DX(0) Q:S=0 D EN^LRDIQ Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
Q
;
;
TOF Q:S=0 X DX(0)
;S S=$Y I $E(IOST,1,2)="P-",$Y>(IOSL-6) W @IOF D HDR S S=$Y Q
;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0) W @IOF D HDR S S=$Y
Q
;
;
END ;
W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
K DIC,D1,DIR,A,AGE,DFN,DOB,DR,LRAN,LRINST,S,SEX,T,ZZ,ZZY
K LRNG1,LRNG11,LRNG12,LRNG2,LRNG3,LRNG4,LRNG5
K DTOUT,DUOUT,DIRUT,LR,LRDFN,LRDPF,LRIDT,LRODT,LRPRAC,LRRB,LRTREA,LRWRD,PNM
K SSN,VA,LREQ
K ^TMP("LR",$J),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H
K C1,D0,DA,DICS,DL,DSC,DX,LRL,LAST,LRAA,LRAD,LRALL,LRDX,LREDT,LREND,LRFAN
K LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q")
D KVAR^VADPT
Q
;
;
HDR ;
I $G(LRDBUG),$S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,S=0:1,1:0) W !,"88888"
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(S=0)
I '$G(LRRPG) S LRRPG=1 W:$E(IOST,1,2)="C-" @IOF
;
HD1 ;
W "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($S(LRDATE>0:LRDATE,1:$$DT^XLFDT),"D")
W !,"ACCESSION AREA(S): " F ZZ=1:1:LRNL W LRAA(ZZ,1)," "
I $O(LRINST(0)) W !,"Collecting Site(s) " S ZZ=0 F S ZZ=$O(LRINST(ZZ)) Q:ZZ="" W $P(^DIC(4,ZZ,0),U)," / "
W !,LREQ S S=$Y
S LRRPG=LRRPG+1
Q
;
;
RANGE ;
K DIR,DIRUT S DIR("B")="S",DIR(0)="S^L:LONG;S:SHORT;E:EXTENDED",LRLONG=0
S DIR("?")="Long listing shows verified results where short list does not."
S DIR("?",1)="Extended provides demographics results and normal ranges."
D ^DIR K DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
S LRLONG=$S(Y["L":1,Y["E":2,1:0)
D LRAN^LRWU3 Q
;
;
TST S LRAA(1)=42,LRAA(1,1)="CHEMISTRY",LRNL=1,LRALL="",LRSS(1)="CH"
;LRAD=DATE TO SCAN,LRRDT=DATE PRINT FORMAT,LRFAN=STARTING NUMBER
;LRX=REPORT SORT,LRLAN=LAST ACCESSION #
DQ U IO S:$D(ZTQUEUED) ZTREQ="@"
S:'$D(LRLONG) LRLONG=1
I '$G(LRAD) S X="T-1",%DT="X" D ^%DT S LRAD=Y
I '$L($G(LRRDT)) S LRRDT=$$FMTE^XLFDT(LRAD,1)
S:'$G(LRX) LRX=2 S:'$D(LRFAN) LRFAN=1
S:'$G(LRLAN) LRLAN=30
S:'$G(LRDATE) LRDATE=-1
G C2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLIST 7364 printed Apr 09, 2024@21:11:42 Page 2
LRLIST ;DALOI/STAFF - LAB RESULTS LIST ;05/06/13
+1 ;;5.2;LAB SERVICE;**44,86,153,201,427**;Sep 27, 1994;Build 33
+2 ;
+3 ;
+4 WRITE !,"Summary List (Supervisors') >>> NOT FOR WARD USE <<<",!
+5 ;
EN KILL ^TMP("LR",$JOB),LRAA
+1 DO DATE^LRWU
if Y<1
GOTO END
SET LRAD=Y
SET DIC="^LRO(68,"
SET DIC(0)="AEQ"
SET LRNL=0
+2 SET LRRDT=$$FMTE^XLFDT(Y,1)
+3 FOR
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(^LRO(68,LRAA(LRNL),0),U,2)
+4 KILL DIC
if $GET(LRNL)<1
GOTO EN
+5 SET LRDATE=-1
+6 IF $PIECE(^LRO(68,LRAA(1),0),U,2)="MI"
SET %DT("A")="Report date approved to display: "
DO DATE^LRWU
if $GET(LREND)
GOTO END
SET LRDATE=Y
+7 ;
C KILL DIRUT,DIR
SET DIR("A")="List By"
SET DIR(0)="S^1:ACCESSION NUMBER;2:PATIENT"
+1 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
GOTO END
+2 SET LRX=Y
+3 DO RANGE
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
GOTO C
+4 ;
INST KILL DIR
SET DIR(0)="PO^4:AQENM"
SET DIR("A")="Optional - Select Collecting Institution "
+1 FOR
DO ^DIR
if Y=""!($EXTRACT(Y=U))!(Y<1)
QUIT
if Y
SET LRINST=+Y
SET LRINST(LRINST)=""
SET DIR("A")="Select Another Collecting Institution "
+2 KILL DIR,DIRUT
if $EXTRACT(Y)=U
GOTO END
+3 ;
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^LRLIST"
SET ZTIO=ION
SET ZTDESC="Summary List (Supervisors')"
SET ZTSAVE("LR*")=""
DO ^%ZTLOAD
GOTO END
+3 ;
C2 ;
+1 SET $PIECE(LREQ,"=",IOM)=""
SET S=1
KILL DX
SET DX(0)="Q"
+2 IF $EXTRACT(IOST,1,2)="C-"
SET DX(0)="S S=$Y I S>(IOSL-8) N X,Y K DIR S DIR(0)=""E"" D ^DIR K DIR S S=$S($D(DIRUT):0,1:1) Q:$D(DIRUT) W @IOF D HDR^LRLIST S S=$S($D(DIRUT):0,1:1)"
+3 IF IOST?1"P".E
SET DX(0)="S S=$Y I S>(IOSL-8) W @IOF D HDR^LRLIST S S=$Y"
+4 USE IO
DO HDR
if LRX=1
GOTO L10
if LRX=2
GOTO L20
GOTO END
+5 ;
L10 ;
+1 IF $DATA(LRALL)
FOR LRAA=1:1:LRNL
FOR LRL=LRFAN-1:0
SET LRL=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL))
if (LRL>LRLAN)!(LRL<LRFAN)!(S=0)
QUIT
SET ^TMP("LR",$JOB,LRL,LRAA)=""
+2 IF '$DATA(LRALL)
FOR LRAA=1:1:LRNL
SET LRL=LRFAN-1
FOR
SET LRL=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRL))
if (LRL>LRLAN)!(LRL<LRFAN)
QUIT
IF $ORDER(^(LRL,4,0))
SET ^TMP("LR",$JOB,LRL,LRAA)=""
+3 FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LR",$JOB,LRAN))
if LRAN<1!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DUOUT))
QUIT
FOR LRAA=0:0
SET LRAA=$ORDER(^TMP("LR",$JOB,LRAN,LRAA))
if LRAA<1
QUIT
DO PR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+4 WRITE !!
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
GOTO END
+5 WRITE "END OF REPORT",!
GOTO END
+6 ;
+7 ;
L20 ;
+1 FOR LRAA=1:1:LRNL
DO L22
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
+2 SET LRPNM=""
+3 FOR
SET LRPNM=$ORDER(^TMP("LR",$JOB,LRPNM))
if LRPNM=""!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
SET PNM=$PIECE(LRPNM,U)
SET SSN=$PIECE(LRPNM,U,2)
DO L26
+4 WRITE !!
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
GOTO END
+5 WRITE !,"END OF REPORT",!
GOTO END
+6 ;
+7 ;
L22 ;
+1 FOR LRAN=LRFAN-1:0
SET LRAN=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN))
if LRAN<1!(LRAN>LRLAN)!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
DO L23
+2 QUIT
+3 ;
+4 ;
L23 ;
+1 IF '$DATA(LRALL)
IF '$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0))
QUIT
+2 IF $GET(LRINST)
IF '$DATA(LRINST(+$PIECE($GET(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3)))
QUIT
+3 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("LR",$JOB,PNM_U_SSN,LRAA,LRAN)=DOB
QUIT
+4 ;
+5 ;
L26 ;
+1 FOR LRAA=0:0
SET LRAA=$ORDER(^TMP("LR",$JOB,LRPNM,LRAA))
if LRAA<1!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
DO L28
+2 QUIT
+3 ;
+4 ;
L28 ;
+1 FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LR",$JOB,LRPNM,LRAA,LRAN))
if LRAN<1!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
DO PR
+2 QUIT
+3 ;
+4 ;
PR ;
+1 IF '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))
WRITE !!?10," Accession ",LRAN," deleted ",!!,$CHAR(7)
QUIT
+2 IF $GET(LRINST)
IF '$DATA(LRINST(+$PIECE($GET(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),U,3)))
QUIT
+3 if '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3))
QUIT
+4 SET LRIDT=9999999-^(3)
SET LRDFN=+^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)
SET LRINT=$PIECE(^(0),U,5)
SET LRODT=$PIECE(^(0),U,4)
if LRDATE<1
GOTO PR1
+5 SET LRSET=0
+6 FOR I=1,5,8,11,16
IF $DATA(^LR(LRDFN,"MI",LRIDT,I))
IF ((+^(I))\1)=LRDATE
SET LRSET=1
QUIT
+7 if 'LRSET
QUIT
+8 ;
PR1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO DEM^LRX
+1 ;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y K DIR S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0) W @IOF D HDR S S=$Y
+2 ;I IOST?1"P".E&($Y>(IOSL-6)) W @IOF D HDR ;ONLY FOR USE ON A PRINTER
+3 XECUTE DX(0)
if S=0
QUIT
+4 ;
+5 DO DASH^LRX
+6 WRITE !!,PNM,?40,SSN,!,LRAA(LRAA,1)," ACC: ",$SELECT($DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")
+7 WRITE ?45,$SELECT($DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORDER #: "_^(.1),1:"")
+8 IF LRINT
Begin DoDot:1
+9 NEW LRX
+10 SET LRX=$PIECE($GET(^LRO(69,LRODT,1,LRINT,0)),U,2)
+11 IF LRX
SET LRX=$$NAME^XUSER(LRX,"F")
WRITE !,"Person placing order: ",LRX
End DoDot:1
+12 ;
+13 IF $DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4))
Begin DoDot:1
+14 NEW LRX
+15 SET LRIN=+$ORDER(^(4,"B",0))
+16 IF LRIN
IF $DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4,LRIN))
Begin DoDot:2
+17 SET LRIN=$PIECE($GET(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,4,LRIN,0)),U,4)
+18 IF LRIN<1
QUIT
+19 SET LRX=$$NAME^XUSER(LRIN,"F")
+20 IF LRX'=""
WRITE " Person performing test: ",$EXTRACT(LRX,1,(IOM-($X+1)))
End DoDot:2
End DoDot:1
+21 XECUTE DX(0)
if S=0
QUIT
+22 ;
+23 IF '$DATA(LRSS(+$GET(LRAA)))
WRITE !," ACCESSION #: ",LRAN," HAS AN ERROR NOTIFY SYSTEM MANAGER >>> ",!!
QUIT
+24 IF '$DATA(^LR(LRDFN,LRSS(LRAA),LRIDT,0))
WRITE !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",!
QUIT
+25 ;
+26 WRITE !
SET DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""","
SET DR="0"_$SELECT(LRLONG:":99999999",1:"")
SET DA=LRIDT
+27 XECUTE DX(0)
if S=0
QUIT
DO EN^LRDIQ
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
+28 IF $GET(LRLONG)=2
FOR DR="ORU","ORUT"
if S=0
QUIT
XECUTE DX(0)
if S=0
QUIT
DO EN^LRDIQ
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
+29 QUIT
+30 ;
+31 ;
TOF if S=0
QUIT
XECUTE DX(0)
+1 ;S S=$Y I $E(IOST,1,2)="P-",$Y>(IOSL-6) W @IOF D HDR S S=$Y Q
+2 ;I $E(IOST,1,2)="C-",$Y>(IOSL-8) N X,Y S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))!(S=0) W @IOF D HDR S S=$Y
+3 QUIT
+4 ;
+5 ;
END ;
+1 WRITE !
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+2 KILL DIC,D1,DIR,A,AGE,DFN,DOB,DR,LRAN,LRINST,S,SEX,T,ZZ,ZZY
+3 KILL LRNG1,LRNG11,LRNG12,LRNG2,LRNG3,LRNG4,LRNG5
+4 KILL DTOUT,DUOUT,DIRUT,LR,LRDFN,LRDPF,LRIDT,LRODT,LRPRAC,LRRB,LRTREA,LRWRD,PNM
+5 KILL SSN,VA,LREQ
+6 KILL ^TMP("LR",$JOB),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H
+7 KILL C1,D0,DA,DICS,DL,DSC,DX,LRL,LAST,LRAA,LRAD,LRALL,LRDX,LREDT,LREND,LRFAN
+8 KILL LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q")
+9 DO KVAR^VADPT
+10 QUIT
+11 ;
+12 ;
HDR ;
+1 IF $GET(LRDBUG)
IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,S=0:1,1:0)
WRITE !,"88888"
+2 if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(S=0)
QUIT
+3 IF '$GET(LRRPG)
SET LRRPG=1
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+4 ;
HD1 ;
+1 WRITE "SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
+2 WRITE " >> NOT FOR WARD USE <<"
if $LENGTH(LRRDT)=4
WRITE ?40,"Report for date: ",$$FMTE^XLFDT($SELECT(LRDATE>0:LRDATE,1:$$DT^XLFDT),"D")
+3 WRITE !,"ACCESSION AREA(S): "
FOR ZZ=1:1:LRNL
WRITE LRAA(ZZ,1)," "
+4 IF $ORDER(LRINST(0))
WRITE !,"Collecting Site(s) "
SET ZZ=0
FOR
SET ZZ=$ORDER(LRINST(ZZ))
if ZZ=""
QUIT
WRITE $PIECE(^DIC(4,ZZ,0),U)," / "
+5 WRITE !,LREQ
SET S=$Y
+6 SET LRRPG=LRRPG+1
+7 QUIT
+8 ;
+9 ;
RANGE ;
+1 KILL DIR,DIRUT
SET DIR("B")="S"
SET DIR(0)="S^L:LONG;S:SHORT;E:EXTENDED"
SET LRLONG=0
+2 SET DIR("?")="Long listing shows verified results where short list does not."
+3 SET DIR("?",1)="Extended provides demographics results and normal ranges."
+4 DO ^DIR
KILL DIR
+5 if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+6 SET LRLONG=$SELECT(Y["L":1,Y["E":2,1:0)
+7 DO LRAN^LRWU3
QUIT
+8 ;
+9 ;
TST SET LRAA(1)=42
SET LRAA(1,1)="CHEMISTRY"
SET LRNL=1
SET LRALL=""
SET LRSS(1)="CH"
+1 ;LRAD=DATE TO SCAN,LRRDT=DATE PRINT FORMAT,LRFAN=STARTING NUMBER
+2 ;LRX=REPORT SORT,LRLAN=LAST ACCESSION #
DQ USE IO
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 if '$DATA(LRLONG)
SET LRLONG=1
+2 IF '$GET(LRAD)
SET X="T-1"
SET %DT="X"
DO ^%DT
SET LRAD=Y
+3 IF '$LENGTH($GET(LRRDT))
SET LRRDT=$$FMTE^XLFDT(LRAD,1)
+4 if '$GET(LRX)
SET LRX=2
if '$DATA(LRFAN)
SET LRFAN=1
+5 if '$GET(LRLAN)
SET LRLAN=30
+6 if '$GET(LRDATE)
SET LRDATE=-1
+7 GOTO C2
