LRLSTWRK ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91 10:44 ;
;;5.2;LAB SERVICE;**153,381,536**;Sep 27, 1994;Build 18
EN ;
K ^TMP($J),LRTEST,LR,LRTSTS,LRAA
D ADATE^LRWU3
G END^LRLSTWRL:LREND
S LRAD=Y,DIC="^LRO(68,",DIC(0)="AEMOQ",LR(1)=0,LRTEST(0)=0
D LRAA^LRLSTWRL G END:LREND,LRLSTWRK:LR(1)<1
I '$D(LRSTAR) S LREND=0 D LRAN^LRWU3 G END:LREND
L2 ;
W !,"Expand panels" S %=2 D YN^DICN
S LREX=(%=1)
G END:%=-1
I %=0 W !,"If yes, each panel encountered will be expanded." G L2
L2B ;
W !,"Do you wish to see unverified data"
S %=2 D YN^DICN
S LR(2)=(%=1)
G END:%=-1
I %=0 W !,"If yes, unverified data may also be displayed." G L2B
L2A ;
S LREND=0,LRCEN("W")=0
R !,"Spacing: 1// ",LR(4):DTIME
Q:'$T!(LR(4)["^") W:LR(4)["?" !,"Single, Double, Triple spacing, etc."
G:X["?" L2A S LR(4)=+LR(4) S:LR(4)<1 LR(4)=1
S %ZIS="QM" D ^%ZIS G END:POP
I $D(IO("Q")) D G END
. S ZTRTN="DQ^LRLSTWRK",ZTSAVE("L*")=""
. D ^%ZTLOAD K ZTSK,ZTRTN,ZTIO,ZTSAVE,IO("Q")
ENT ;
U IO D URG^LRX K ^TMP("LR",$J)
S LRNTPP=((IOM-4)-45)/$S(LR(4)>1:7,1:5)\1,LRNTP=0
I '$D(LRSTAR) F LRAA=1:1:LR(1) D L11 Q:LREND
I $D(LRSTAR) F LRAA=1:1:LR(1) D L3 Q:LREND
I $O(^TMP($J,0))<1 W !!,"NO DATA TO REPORT" G END
S:LRTEST(0)<LRNTPP LRNTPP=LRTEST(0) G EN^LRLSTWRL
Q
L11 W "." S LRAN=LRFAN-1 F K=0:0 S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN=""!(LRAN>LRLAN)!(LRAN'?.N) D L12 Q:LREND
Q
L12 Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))#2
S X=^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),LRCEN=$S($D(^(.1)):^(.1),1:0),LRACC=$S($D(^(.2)):^(.2),1:"?"),LRIDT=$S($D(^(3)):^(3),1:"")
S LRUID=$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),"^")
S T(2)="",T(5)="",T(3)="",LRDFN=+X,LRSDT=$P(X,U,4)\1,LRSN=+$P(X,U,5),LRLLOC=$P(X,U,7)
S:LRCEN&'LRCEN("W") LRCEN("W")=1
I LRIDT'="" D
. I +LRIDT S T(2)=+LRIDT_$S($P(LRIDT,U,2):"r",1:"d")
. E S T(2)="No Collect Date/Time"
. S T(3)=$P(LRIDT,U,4),T(5)=$P(LRIDT,U,3),LRIDT=$P(LRIDT,U,5)
S II=0 F S II=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,II)) Q:II<1!LREND S X=^(II,0) D L13
S LR(3)=$S(LR(4)>1:7,1:5)*LRTEST(0)+67+$S('LRCEN("W"):0,1:8)<(IOM-4) S:LR(3) LR(3)=22+$S('LRCEN("W"):0,1:8)
Q
L13 S T(1)=$P(X,U,6),LRURG=+$P(X,U,2),LRURG=$S($D(LRURG(LRURG)):LRURG(LRURG),1:""),T(3)=$P(X,U,5),LRTS=+X
I $G(LRURG)>49,'$P($G(LRPARAM),U,3) Q
;LR*5.2*536 - additional logic for Microbiology
;A Microbiology test may have a complete date/time in file 68 but the
;[area] RPT DATE APPROVED field might be null - which means results are
;not displaying in CPRS, and the accession is pending
I T(3),$P(^LRO(68,LRAA(LRAA),0),U,2)="MI" D MICRO
S T(4)=$S(T(3):"done",$L(T(1)):"#"_$J(T(1),3),LRURG["STAT":"Spen",1:" pen"),LRSPEC=$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,5,1,0)):+^(0),1:""),S4=$S($D(^LAB(60,LRTS,0)):$P(^(0),U,5),1:""),T4=T(4)
D STORE I LREX S LRTEST=LRTS,LRTSTLM=100 D ^LREXPD S JJ=0 F S JJ=$O(LRORD(JJ)) Q:JJ<1 S LRTS=LRORD(JJ),S4=$P(^LAB(60,LRTS,0),U,5) D STORE
K JJ,LRORD,^TMP("LR",$J,"T")
Q
;
MICRO ;further evaluation for Microbiology test
N LRDFNX,LRIDTX,LREXCODE,LRMIAREA
S LRDFNX=$P(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),U)
S LRIDTX=$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3)),U,5)
S LREXCODE=$P($G(^LAB(60,II,0)),"^",14)
Q:'LREXCODE
S LREXCODE=$G(^LAB(62.07,LREXCODE,.1))
;Logic below is the same as the logic in result verification
;routine LRMIEDZ2 which determines which Microbiology area is
;defined for a Microbiology test
S LRMIAREA=$S(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
;If the [area] RPT DATE APPROVED field is null, display this test as "pending"
I $D(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA)),$P(^(LRMIAREA),U)="" S T(3)=""
Q
;
STORE S:'$D(LRTEST("B",LRTS)) LRTEST(0)=LRTEST(0)+1,LRTEST(LRTEST(0))=$S($D(^LAB(60,LRTS,0)):$P(^(0),U,1),1:"deleted test"),LRTEST("B",LRTS)=LRTEST(0),LRNTP=LRTEST(0)-1\LRNTPP+1
S LRSS=$P(S4,";",1),S2=$P(S4,";",2),S3=$P(S4,";",3),T(4)=T4
I $L(S4) D
. S T(4)=$S(LRURG["STAT":"S...",1:"....")
. I LRIDT,$D(^LR(LRDFN,LRSS,LRIDT,S2)),$P(^(0),U,3)!LR(2),$L($P(^(S2),U,S3)) S T(4)=$S($P(^(S2),U,S3)'="pending":$P(^(S2),U,S3),1:"pen")
S ^TMP($J,(LRTEST("B",LRTS)-1\LRNTPP+1),LRAN,LRACC,LRDFN,LRTEST("B",LRTS))=LRLLOC_U_LRURG_U_T(4)_U_LRSPEC_U_LRCEN_U_T(2)_U_LRACC_U_T(5)_U_LRUID
Q
END G END^LRLSTWRL
Q
YN R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G YN
L3 S LRAD=$E(LRSTAR,1,3)_"0000"-.00001 F S LRAD=$O(^LRO(68,LRAA(LRAA),1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL) D AC Q:LREND
AC S T1=LRSTAR-.00001 F S T1=$O(^LRO(68,+LRAA(LRAA),1,+LRAD,1,"E",T1)) Q:T1<1!(LAST>1&(T1\1>LAST)) D AC1
Q
AC1 S LRAN=0 F S LRAN=$O(^LRO(68,+LRAA(LRAA),1,LRAD,1,"E",T1,LRAN)) Q:LRAN<1 I $D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,0)) D L12 Q:LREND
Q
DQ S:$D(ZTQUEUED) ZTREQ="@" U IO K ^TMP($J) G ENT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLSTWRK 4831 printed Sep 23, 2025@19:52:30 Page 2
LRLSTWRK ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91 10:44 ;
+1 ;;5.2;LAB SERVICE;**153,381,536**;Sep 27, 1994;Build 18
EN ;
+1 KILL ^TMP($JOB),LRTEST,LR,LRTSTS,LRAA
+2 DO ADATE^LRWU3
+3 if LREND
GOTO END^LRLSTWRL
+4 SET LRAD=Y
SET DIC="^LRO(68,"
SET DIC(0)="AEMOQ"
SET LR(1)=0
SET LRTEST(0)=0
+5 DO LRAA^LRLSTWRL
if LREND
GOTO END
if LR(1)<1
GOTO LRLSTWRK
+6 IF '$DATA(LRSTAR)
SET LREND=0
DO LRAN^LRWU3
if LREND
GOTO END
L2 ;
+1 WRITE !,"Expand panels"
SET %=2
DO YN^DICN
+2 SET LREX=(%=1)
+3 if %=-1
GOTO END
+4 IF %=0
WRITE !,"If yes, each panel encountered will be expanded."
GOTO L2
L2B ;
+1 WRITE !,"Do you wish to see unverified data"
+2 SET %=2
DO YN^DICN
+3 SET LR(2)=(%=1)
+4 if %=-1
GOTO END
+5 IF %=0
WRITE !,"If yes, unverified data may also be displayed."
GOTO L2B
L2A ;
+1 SET LREND=0
SET LRCEN("W")=0
+2 READ !,"Spacing: 1// ",LR(4):DTIME
+3 if '$TEST!(LR(4)["^")
QUIT
if LR(4)["?"
WRITE !,"Single, Double, Triple spacing, etc."
+4 if X["?"
GOTO L2A
SET LR(4)=+LR(4)
if LR(4)<1
SET LR(4)=1
+5 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="DQ^LRLSTWRK"
SET ZTSAVE("L*")=""
+8 DO ^%ZTLOAD
KILL ZTSK,ZTRTN,ZTIO,ZTSAVE,IO("Q")
End DoDot:1
GOTO END
ENT ;
+1 USE IO
DO URG^LRX
KILL ^TMP("LR",$JOB)
+2 SET LRNTPP=((IOM-4)-45)/$SELECT(LR(4)>1:7,1:5)\1
SET LRNTP=0
+3 IF '$DATA(LRSTAR)
FOR LRAA=1:1:LR(1)
DO L11
if LREND
QUIT
+4 IF $DATA(LRSTAR)
FOR LRAA=1:1:LR(1)
DO L3
if LREND
QUIT
+5 IF $ORDER(^TMP($JOB,0))<1
WRITE !!,"NO DATA TO REPORT"
GOTO END
+6 if LRTEST(0)<LRNTPP
SET LRNTPP=LRTEST(0)
GOTO EN^LRLSTWRL
+7 QUIT
L11 WRITE "."
SET LRAN=LRFAN-1
FOR K=0:0
SET LRAN=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN))
if LRAN=""!(LRAN>LRLAN)!(LRAN'?.N)
QUIT
DO L12
if LREND
QUIT
+1 QUIT
L12 if '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))#2
QUIT
+1 SET X=^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)
SET LRCEN=$SELECT($DATA(^(.1)):^(.1),1:0)
SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"?")
SET LRIDT=$SELECT($DATA(^(3)):^(3),1:"")
+2 SET LRUID=$PIECE($GET(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),"^")
+3 SET T(2)=""
SET T(5)=""
SET T(3)=""
SET LRDFN=+X
SET LRSDT=$PIECE(X,U,4)\1
SET LRSN=+$PIECE(X,U,5)
SET LRLLOC=$PIECE(X,U,7)
+4 if LRCEN&'LRCEN("W")
SET LRCEN("W")=1
+5 IF LRIDT'=""
Begin DoDot:1
+6 IF +LRIDT
SET T(2)=+LRIDT_$SELECT($PIECE(LRIDT,U,2):"r",1:"d")
+7 IF '$TEST
SET T(2)="No Collect Date/Time"
+8 SET T(3)=$PIECE(LRIDT,U,4)
SET T(5)=$PIECE(LRIDT,U,3)
SET LRIDT=$PIECE(LRIDT,U,5)
End DoDot:1
+9 SET II=0
FOR
SET II=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,II))
if II<1!LREND
QUIT
SET X=^(II,0)
DO L13
+10 SET LR(3)=$SELECT(LR(4)>1:7,1:5)*LRTEST(0)+67+$SELECT('LRCEN("W"):0,1:8)<(IOM-4)
if LR(3)
SET LR(3)=22+$SELECT('LRCEN("W"):0,1:8)
+11 QUIT
L13 SET T(1)=$PIECE(X,U,6)
SET LRURG=+$PIECE(X,U,2)
SET LRURG=$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
SET T(3)=$PIECE(X,U,5)
SET LRTS=+X
+1 IF $GET(LRURG)>49
IF '$PIECE($GET(LRPARAM),U,3)
QUIT
+2 ;LR*5.2*536 - additional logic for Microbiology
+3 ;A Microbiology test may have a complete date/time in file 68 but the
+4 ;[area] RPT DATE APPROVED field might be null - which means results are
+5 ;not displaying in CPRS, and the accession is pending
+6 IF T(3)
IF $PIECE(^LRO(68,LRAA(LRAA),0),U,2)="MI"
DO MICRO
+7 SET T(4)=$SELECT(T(3):"done",$LENGTH(T(1)):"#"_$JUSTIFY(T(1),3),LRURG["STAT":"Spen",1:" pen")
SET LRSPEC=$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
SET S4=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U,5),1:"")
SET T4=T(4)
+8 DO STORE
IF LREX
SET LRTEST=LRTS
SET LRTSTLM=100
DO ^LREXPD
SET JJ=0
FOR
SET JJ=$ORDER(LRORD(JJ))
if JJ<1
QUIT
SET LRTS=LRORD(JJ)
SET S4=$PIECE(^LAB(60,LRTS,0),U,5)
DO STORE
+9 KILL JJ,LRORD,^TMP("LR",$JOB,"T")
+10 QUIT
+11 ;
MICRO ;further evaluation for Microbiology test
+1 NEW LRDFNX,LRIDTX,LREXCODE,LRMIAREA
+2 SET LRDFNX=$PIECE(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),U)
+3 SET LRIDTX=$PIECE($GET(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3)),U,5)
+4 SET LREXCODE=$PIECE($GET(^LAB(60,II,0)),"^",14)
+5 if 'LREXCODE
QUIT
+6 SET LREXCODE=$GET(^LAB(62.07,LREXCODE,.1))
+7 ;Logic below is the same as the logic in result verification
+8 ;routine LRMIEDZ2 which determines which Microbiology area is
+9 ;defined for a Microbiology test
+10 SET LRMIAREA=$SELECT(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
+11 ;If the [area] RPT DATE APPROVED field is null, display this test as "pending"
+12 IF $DATA(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA))
IF $PIECE(^(LRMIAREA),U)=""
SET T(3)=""
+13 QUIT
+14 ;
STORE if '$DATA(LRTEST("B",LRTS))
SET LRTEST(0)=LRTEST(0)+1
SET LRTEST(LRTEST(0))=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U,1),1:"deleted test")
SET LRTEST("B",LRTS)=LRTEST(0)
SET LRNTP=LRTEST(0)-1\LRNTPP+1
+1 SET LRSS=$PIECE(S4,";",1)
SET S2=$PIECE(S4,";",2)
SET S3=$PIECE(S4,";",3)
SET T(4)=T4
+2 IF $LENGTH(S4)
Begin DoDot:1
+3 SET T(4)=$SELECT(LRURG["STAT":"S...",1:"....")
+4 IF LRIDT
IF $DATA(^LR(LRDFN,LRSS,LRIDT,S2))
IF $PIECE(^(0),U,3)!LR(2)
IF $LENGTH($PIECE(^(S2),U,S3))
SET T(4)=$SELECT($PIECE(^(S2),U,S3)'="pending":$PIECE(^(S2),U,S3),1:"pen")
End DoDot:1
+5 SET ^TMP($JOB,(LRTEST("B",LRTS)-1\LRNTPP+1),LRAN,LRACC,LRDFN,LRTEST("B",LRTS))=LRLLOC_U_LRURG_U_T(4)_U_LRSPEC_U_LRCEN_U_T(2)_U_LRACC_U_T(5)_U_LRUID
+6 QUIT
END GOTO END^LRLSTWRL
+1 QUIT
YN READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO YN
L3 SET LRAD=$EXTRACT(LRSTAR,1,3)_"0000"-.00001
FOR
SET LRAD=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD))
if LRAD<1!(LRAD>LRWDTL)
QUIT
DO AC
if LREND
QUIT
AC SET T1=LRSTAR-.00001
FOR
SET T1=$ORDER(^LRO(68,+LRAA(LRAA),1,+LRAD,1,"E",T1))
if T1<1!(LAST>1&(T1\1>LAST))
QUIT
DO AC1
+1 QUIT
AC1 SET LRAN=0
FOR
SET LRAN=$ORDER(^LRO(68,+LRAA(LRAA),1,LRAD,1,"E",T1,LRAN))
if LRAN<1
QUIT
IF $DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,0))
DO L12
if LREND
QUIT
+1 QUIT
DQ if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
KILL ^TMP($JOB)
GOTO ENT
+1 QUIT
