LRLSTWRK.m

LRLSTWRK ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91  10:44 ;

 ;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997

 ;

 ;;VA LR Patch(s): 153,381

 ;

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

 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

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

LRLSTWRK  ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91  10:44 ;

 +1       ;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997

 +2       ;

 +3       ;;VA LR Patch(s): 153,381

 +4       ;

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        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)

 +3        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

 +4        KILL JJ,LRORD,^TMP("LR",$JOB,"T")

           QUIT 

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