- 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 Mar 13, 2025@21:21:20 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
