LRLSTWRL ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST PART 2 ;2/6/91 07:41 ;
;;5.2;LAB SERVICE;**153,201**;Sep 27, 1994
EN ;from LRLSTWRK
CONTROL ;
S LROK=1,LREND=0
W:$E(IOST,1,2)="C-" @IOF
D INIT
D LOOP1
D END
Q
INIT ;
S CNT=0
S LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
Q
LOOP1 ;
F LRPGC=1:1:LRNTP S LRPTO=LRPGC-1*LRNTPP D L1
Q
L1 ;
Q:$G(LREND)
U IO
I $G(CNT)=1 D LRSTOP Q:$G(LREND)=1 W @IOF,!
W:LRAD'<1 @LR("TIME")
D LOOP2
Q
LOOP2 ;
F LRAA=1:1:LR(1) D Q:$G(LREND)=1
. W !,?20,"SHORT ",$P(^LRO(68,LRAA(LRAA),0),U,1)," ACCESSION"
I $D(LRSTAR),$D(LAST),LRSTAR>1,LAST>1 D
. W !,"FROM DATE: "
. S Y=LRSTAR\1
. D DD^LRX
. W Y,!,"TO DATE: "
. S Y=LAST\1 D DD^LRX W Y,!
D HEAD1
D LOOP3
Q
HEAD1 ;
D ^LRWLHEAD
W !
D L27
Q
LOOP3 ;
S LRAN=0
F S LRAN=$O(^TMP($J,LRPGC,LRAN)) Q:LRAN<1!($G(LREND)=1) D L24
Q
L24 ;
S LRACC=""
F S LRACC=$O(^TMP($J,LRPGC,LRAN,LRACC)) Q:LRACC="" D
. S LRDFN=0 Q:$G(LREND)=1 D
.. F S LRDFN=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN)) Q:LRDFN<1 D
... Q:$G(LREND)=1 D L26
Q
L26 ;
Q:$G(LREND)=1
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
S LRTEST=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,0)),X=^(LRTEST)
S LRLLOC=$P(X,U,1)
S LRURG=$P(X,U,2)
S LRCEN=$P(X,U,5)
S T(2)=$P(X,U,6)
S T(5)=$P(X,U,8)
S LRUID=$P(X,U,9)
S LRSPEC=$S($D(^LAB(61,+$P(X,U,4),0)):$E($P(^(0),U,1),1,5),1:"")
I +T(2) S Y=+T(2) D DD^LRX S LRCDT=Y_$E(T(2),$L(T(2)))
I '+T(2) S LRCDT=T(2)
;Q:$G(LREND)=1
F I=1:1:LR(4) W !
Q:$G(LREND)=1
W $P(LRACC," ",1)," ",$P(LRACC," ",3),?11," ",$E(LRLLOC,1,4),?18," ",$E(SSN,$L(SSN)-3,$L(SSN)),?23," ",$E(PNM,1,15)
I 'LR(3) W ! W:LRCEN ?11,"ORD:",LRCEN W ?20," ",LRCDT
E W ?40 W:LRCEN "ORD:",LRCEN W " ",LRCDT
W !,?11,"UID: ",LRUID
D LOOP4
Q
LOOP4 ;
F LRTEST=LRPTO+1:1:LRPTO+LRNTPP D
. ;I '$D(LRTEST(LRTEST)) S LREND=1 Q
. W ?($S(LR(4)>1:7,1:5)*(LRTEST-LRPTO)+35+LR(3))
. W $S('$D(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,LRTEST)):"|",1:"") I $D(^(LRTEST)) W $P(^(LRTEST),U,3)
W ?($S(LR(4)>1:7,1:5)*(LRNTPP+1)+34+LR(3))
W " ",LRSPEC
I $Y>(IOSL-7) D LRSTOP Q:$G(LREND)=1 W @IOF W:LRAD'<1 @LR("TIME") D L27
I LRDPF=2,'T(5) W " NC"
Q
L27 ;
Q:$G(LREND)
F I=1:1:10 D L30
W !,"ACC #"
Q
LRSTOP ;
S CNT=1
Q:$E(IOST,1,2)="P-"
K DIR
S DIR(0)="E"
D ^DIR
I $D(DUOUT)!($D(DIRUT)) S LREND=1 Q
Q
L15 D ^%ZISC U IO(0) W:$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)) !,"Accession: ",^(.2)," added too many tests to the display."
W !,"Need more columns on the display than are available, Either use a wider",!,"device or try fewer accessions (fewer tests may be encountered, resulting in",!,"a narrower display)."
Q
L30 W !,$P("Key:^done = mult test comp.^ pen = mult test incomp.^spen = stat mult incomp.^number = result^.... = incomplete^S... = STAT incomp.^ | = not ordered",U,I)
F J=1:1:LRNTPP I $D(LRTEST(LRPTO+J)) S C1=$E(LRTEST(LRPTO+J),I) W ?($S(LR(4)>1:7,1:5)*J+25+I+LR(3)),$S(C1'="":C1,1:".")
Q
END ;from LRLSTWRK
W ! W:$E(IOST,1,2)="P-" @IOF
K LR,LRCDT,LRURG,LREXPD,LRTS,LRSTAR,LRY,LRSS,LRAD,LRAN,LRAA,LRTEST,LRNTP,LRNTPP,LRPGM,LRSDT,LRSN,LRSPEC,T,ZTSK,LRACC,LRCEN,LRENT,LRFAN,LRIDT,LRLLOC,LRPGC,LRPTO,LRWRD,LREX,^TMP("LR",$J)
K %,%H,B,C1,LAST,LREDT,LRLINE,LRWDTL,POP,T1,LRORD,LRTSTS,LRUID
K AGE,A,DFN,DIC,DOB,I,J,K,LRLAN,LRDFN,LRDPF,PNM,S2,S3,S4,SEX,SSN,T5,X,Y,Z
K LRXX,LROK,T4,OK
D ^%ZISC Q
;NTPP=number tests/page, LRPTO=page test offset, LRPGC=page cnt, LRNTP=number of test pages
;LR(1)=# of acc areas, 2=see unverified, 3=wide, 4=spacing
LRAA ;from LRLSTWRK
K LRSTAR,LRAA,W2 F J=0:0 D ^DIC Q:Y<1 D CHKDAT Q:Y<1 S DIC("A")="ANOTHER ACCESSION AREA: " I '$D(W2(+Y)) S LR(1)=LR(1)+1,LRAA(LR(1))=+Y,W2(+Y)="",LRSS(LR(1))=$P(LR,U,2) D:$P(LR,U,3)="Y"&'$D(LRSTAR) STAR^LRWU3
K W2,DIC,J,T2 S LREND=(X[U)!(LR(1)=0) Q
CHKDAT ;from LRLIST
S LR=^LRO(68,+Y,0),T=$P(LR,U,3) I T="Y",$E(LRAD,4,7)'="0000" W !,"Accession area selected has a YEARLY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
I T="D",$E(LRAD,4,5)="00"!($E(LRAD,6,7)="00") W !,"Accession area selected has a DAILY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
I T="M",$E(LRAD,4,5)="00"!($E(LRAD,6,7)'="00") W !,"Accession area selected has a MONTHLY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLSTWRL 4319 printed Sep 23, 2025@19:52:31 Page 2
LRLSTWRL ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST PART 2 ;2/6/91 07:41 ;
+1 ;;5.2;LAB SERVICE;**153,201**;Sep 27, 1994
EN ;from LRLSTWRK
CONTROL ;
+1 SET LROK=1
SET LREND=0
+2 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+3 DO INIT
+4 DO LOOP1
+5 DO END
+6 QUIT
INIT ;
+1 SET CNT=0
+2 SET LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
+3 QUIT
LOOP1 ;
+1 FOR LRPGC=1:1:LRNTP
SET LRPTO=LRPGC-1*LRNTPP
DO L1
+2 QUIT
L1 ;
+1 if $GET(LREND)
QUIT
+2 USE IO
+3 IF $GET(CNT)=1
DO LRSTOP
if $GET(LREND)=1
QUIT
WRITE @IOF,!
+4 if LRAD'<1
WRITE @LR("TIME")
+5 DO LOOP2
+6 QUIT
LOOP2 ;
+1 FOR LRAA=1:1:LR(1)
Begin DoDot:1
+2 WRITE !,?20,"SHORT ",$PIECE(^LRO(68,LRAA(LRAA),0),U,1)," ACCESSION"
End DoDot:1
if $GET(LREND)=1
QUIT
+3 IF $DATA(LRSTAR)
IF $DATA(LAST)
IF LRSTAR>1
IF LAST>1
Begin DoDot:1
+4 WRITE !,"FROM DATE: "
+5 SET Y=LRSTAR\1
+6 DO DD^LRX
+7 WRITE Y,!,"TO DATE: "
+8 SET Y=LAST\1
DO DD^LRX
WRITE Y,!
End DoDot:1
+9 DO HEAD1
+10 DO LOOP3
+11 QUIT
HEAD1 ;
+1 DO ^LRWLHEAD
+2 WRITE !
+3 DO L27
+4 QUIT
LOOP3 ;
+1 SET LRAN=0
+2 FOR
SET LRAN=$ORDER(^TMP($JOB,LRPGC,LRAN))
if LRAN<1!($GET(LREND)=1)
QUIT
DO L24
+3 QUIT
L24 ;
+1 SET LRACC=""
+2 FOR
SET LRACC=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC))
if LRACC=""
QUIT
Begin DoDot:1
+3 SET LRDFN=0
if $GET(LREND)=1
QUIT
Begin DoDot:2
+4 FOR
SET LRDFN=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN))
if LRDFN<1
QUIT
Begin DoDot:3
+5 if $GET(LREND)=1
QUIT
DO L26
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
L26 ;
+1 if $GET(LREND)=1
QUIT
+2 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+3 SET LRTEST=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN,0))
SET X=^(LRTEST)
+4 SET LRLLOC=$PIECE(X,U,1)
+5 SET LRURG=$PIECE(X,U,2)
+6 SET LRCEN=$PIECE(X,U,5)
+7 SET T(2)=$PIECE(X,U,6)
+8 SET T(5)=$PIECE(X,U,8)
+9 SET LRUID=$PIECE(X,U,9)
+10 SET LRSPEC=$SELECT($DATA(^LAB(61,+$PIECE(X,U,4),0)):$EXTRACT($PIECE(^(0),U,1),1,5),1:"")
+11 IF +T(2)
SET Y=+T(2)
DO DD^LRX
SET LRCDT=Y_$EXTRACT(T(2),$LENGTH(T(2)))
+12 IF '+T(2)
SET LRCDT=T(2)
+13 ;Q:$G(LREND)=1
+14 FOR I=1:1:LR(4)
WRITE !
+15 if $GET(LREND)=1
QUIT
+16 WRITE $PIECE(LRACC," ",1)," ",$PIECE(LRACC," ",3),?11," ",$EXTRACT(LRLLOC,1,4),?18," ",$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN)),?23," ",$EXTRACT(PNM,1,15)
+17 IF 'LR(3)
WRITE !
if LRCEN
WRITE ?11,"ORD:",LRCEN
WRITE ?20," ",LRCDT
+18 IF '$TEST
WRITE ?40
if LRCEN
WRITE "ORD:",LRCEN
WRITE " ",LRCDT
+19 WRITE !,?11,"UID: ",LRUID
+20 DO LOOP4
+21 QUIT
LOOP4 ;
+1 FOR LRTEST=LRPTO+1:1:LRPTO+LRNTPP
Begin DoDot:1
+2 ;I '$D(LRTEST(LRTEST)) S LREND=1 Q
+3 WRITE ?($SELECT(LR(4)>1:7,1:5)*(LRTEST-LRPTO)+35+LR(3))
+4 WRITE $SELECT('$DATA(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN,LRTEST)):"|",1:"")
IF $DATA(^(LRTEST))
WRITE $PIECE(^(LRTEST),U,3)
End DoDot:1
+5 WRITE ?($SELECT(LR(4)>1:7,1:5)*(LRNTPP+1)+34+LR(3))
+6 WRITE " ",LRSPEC
+7 IF $Y>(IOSL-7)
DO LRSTOP
if $GET(LREND)=1
QUIT
WRITE @IOF
if LRAD'<1
WRITE @LR("TIME")
DO L27
+8 IF LRDPF=2
IF 'T(5)
WRITE " NC"
+9 QUIT
L27 ;
+1 if $GET(LREND)
QUIT
+2 FOR I=1:1:10
DO L30
+3 WRITE !,"ACC #"
+4 QUIT
LRSTOP ;
+1 SET CNT=1
+2 if $EXTRACT(IOST,1,2)="P-"
QUIT
+3 KILL DIR
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 IF $DATA(DUOUT)!($DATA(DIRUT))
SET LREND=1
QUIT
+7 QUIT
L15 DO ^%ZISC
USE IO(0)
if $DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2))
WRITE !,"Accession: ",^(.2)," added too many tests to the display."
+1 WRITE !,"Need more columns on the display than are available, Either use a wider",!,"device or try fewer accessions (fewer tests may be encountered, resulting in",!,"a narrower display)."
+2 QUIT
L30 WRITE !,$PIECE("Key:^done = mult test comp.^ pen = mult test incomp.^spen = stat mult incomp.^number = result^.... = incomplete^S... = STAT incomp.^ | = not ordered",U,I)
+1 FOR J=1:1:LRNTPP
IF $DATA(LRTEST(LRPTO+J))
SET C1=$EXTRACT(LRTEST(LRPTO+J),I)
WRITE ?($SELECT(LR(4)>1:7,1:5)*J+25+I+LR(3)),$SELECT(C1'="":C1,1:".")
+2 QUIT
END ;from LRLSTWRK
+1 WRITE !
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 KILL LR,LRCDT,LRURG,LREXPD,LRTS,LRSTAR,LRY,LRSS,LRAD,LRAN,LRAA,LRTEST,LRNTP,LRNTPP,LRPGM,LRSDT,LRSN,LRSPEC,T,ZTSK,LRACC,LRCEN,LRENT,LRFAN,LRIDT,LRLLOC,LRPGC,LRPTO,LRWRD,LREX,^TMP("LR",$JOB)
+3 KILL %,%H,B,C1,LAST,LREDT,LRLINE,LRWDTL,POP,T1,LRORD,LRTSTS,LRUID
+4 KILL AGE,A,DFN,DIC,DOB,I,J,K,LRLAN,LRDFN,LRDPF,PNM,S2,S3,S4,SEX,SSN,T5,X,Y,Z
+5 KILL LRXX,LROK,T4,OK
+6 DO ^%ZISC
QUIT
+7 ;NTPP=number tests/page, LRPTO=page test offset, LRPGC=page cnt, LRNTP=number of test pages
+8 ;LR(1)=# of acc areas, 2=see unverified, 3=wide, 4=spacing
LRAA ;from LRLSTWRK
+1 KILL LRSTAR,LRAA,W2
FOR J=0:0
DO ^DIC
if Y<1
QUIT
DO CHKDAT
if Y<1
QUIT
SET DIC("A")="ANOTHER ACCESSION AREA: "
IF '$DATA(W2(+Y))
SET LR(1)=LR(1)+1
SET LRAA(LR(1))=+Y
SET W2(+Y)=""
SET LRSS(LR(1))=$PIECE(LR,U,2)
if $PIECE(LR,U,3)="Y"&'$DATA(LRSTAR)
DO STAR^LRWU3
+2 KILL W2,DIC,J,T2
SET LREND=(X[U)!(LR(1)=0)
QUIT
CHKDAT ;from LRLIST
+1 SET LR=^LRO(68,+Y,0)
SET T=$PIECE(LR,U,3)
IF T="Y"
IF $EXTRACT(LRAD,4,7)'="0000"
WRITE !,"Accession area selected has a YEARLY Accession date, you didn't choose that."
SET (LR(1),Y)=-1
QUIT
+2 IF T="D"
IF $EXTRACT(LRAD,4,5)="00"!($EXTRACT(LRAD,6,7)="00")
WRITE !,"Accession area selected has a DAILY Accession date, you didn't choose that."
SET (LR(1),Y)=-1
QUIT
+3 IF T="M"
IF $EXTRACT(LRAD,4,5)="00"!($EXTRACT(LRAD,6,7)'="00")
WRITE !,"Accession area selected has a MONTHLY Accession date, you didn't choose that."
SET (LR(1),Y)=-1
QUIT
+4 QUIT
