LRWRKS.m

LRWRKS ;VA/SLC/RWF - WORK SHEET ACCESSION LIST ;JUL 06, 2010 3:14 PM;

 ;;5.2;LAB SERVICE;**153,358,1027**;NOV 01, 1997

 ;;5.2;LAB SERVICE;**153,358**;Sep 27, 1994

 K DIC S DIC="^LRO(68,",DIC(0)="AEMOQ",LREND=0 D ^DIC S LRAA=+Y,LRNAME=$P(Y,U,2) G END:LRAA<1

 K LRSTAR,DIC D STAR^LRWU3:$P(^LRO(68,LRAA,0),U,3)="Y",PHD:'$D(LRSTAR) G END:LREND

W G END:'$D(^LRO(68,LRAA,1,LRAD,1,0))&'$D(LRSTAR)

 S LRUNC=0,LRTSE=-1

 K DIC W !,"Do you want a specific test?" S %=2 D YN^DICN IF %=1 S DIC="^LAB(60,",DIC(0)="AEMOQ" D ^DIC S LRTSE=+Y

 W !,"Do you want only incomplete entries?" S %=1 D YN^DICN S:%=2 LRUNC=1

 W !,"Do you want a long list?" S %=2 D YN^DICN S LRSHORT=(%=2)

 S %ZIS="Q" D ^%ZIS G END:POP

 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRWRKS" S ZTSAVE("LR*")="",ZTSAVE("LAST")="" D ^%ZTLOAD G END

 D ENT G END

ENT U IO D URG^LRX S Y=DT D DD^LRX S LRDT0=Y,LRDC=1,LRLINE="---------------------------------------"

 I '$D(LRSTAR) S LRAN=LRFAN-1 F LRIX=0:0 S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)),LREND=0 Q:LRAN>LRLAN!(LRAN<1)  D ACC

 I $D(LRSTAR) F A=0:0 S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL)  D AC

 Q

ACC D TD IF 'LREND,K1 D:LRUNC!'LRVER ENT^LRWRKS2

 Q

TD S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) LREND=1 Q:LREND  S LRSN=+$P(^(0),U,5),LRDAT=+$P(^(0),U,4)

 S LRVER=1,K1=0,I=0 F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  S LRVER=(LRVER&$P(^(I,0),U,5)) I 'K1,LRTSE>0,+^(0)=LRTSE S K1=I

 S K1=$S(LRTSE<0:1,1:K1) Q

 Q

PHD Q:LREND  S LREND=0,U="^" D ADATE^LRWU Q:LREND  D LRAN^LRWU3 Q

 Q

AC S LRTK=LRSTAR-.00001 F B=0:0 S LRTK=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK)) Q:LRTK<1!(LAST>1&(LRTK\1>LAST))  D AC1

 Q

AC1 S LRAN=0 F  S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN)) Q:LRAN<1  I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D ACC

 Q

% R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %

END W !! W:$E(IOST)="P" @IOF D ^%ZISC K ZTRTN,ZTIO,ZTDESC,ZTSAVE,%H,%ZIS,DFN,J,LRDFN,LRDOC,LREDT,LRSDT,LRCDT,LRUID

 K %,A,B,I,K,K1,L,LRACC,LRSPEC,LRURG,SEX,SSN,X,Y,DIC,LRUNC,LRDAT,LRAA,LRAD,LRAN,LRDPF,LRSN,LRSTAR,LRSHORT,LAST,PNM,ZTSK,LRDC,LRIDT,LRLLOC,LRODNUM,LRTK,LRV,LRWDTL,POP,T

 K LRTSTS,LRLAN,LREND,LRLINE,LRFAN,LRFI,LRIX,LRNAME,LRTSE,LRVER,VA("BID"),VA("PID")

 K HRCN  ;IHS/ANMC/CLS 08/18/96

 Q

EN ;

DQ U IO S U="^" D ENT S:$D(ZTQUEUED) ZTREQ="@" G END

ALLUNC W !,"LIST ALL UNVERIFIED TEST's for one day",! D ADATE^LRWU3 G END:LREND S %ZIS="Q" D ^%ZIS G END:POP

 I $D(IO("Q")) K IO("Q") S ZTRTN="ALL^LRWRKS",ZTSAVE("LRAD")="" D ^%ZTLOAD G END

ALL S U="^",LRUNC=0,LRTSE=-1,LRFAN=1,LRLAN=999999,LRSHORT=1

 F LRAA=0:0 S LRAA=$O(^LRO(68,LRAA)) Q:LRAA'>0  S LRAD(1)=LRAD,LRDC=1 D AL2

 S:$D(ZTQUEUED) ZTREQ="@" G END

AL2 K LRSTAR S LAST=LRAD+.99 S LRNAME=$P(^LRO(68,LRAA,0),U,1) I $P(^(0),U,3)="Y" S LRSTAR=LRAD,LRWDTL=$E(LRAD,1,3)_"0000",LRAD=LRWDTL-10000

 D ENT S LRAD=LRAD(1) Q

LRWRKS    ;VA/SLC/RWF - WORK SHEET ACCESSION LIST ;JUL 06, 2010 3:14 PM;

 +1       ;;5.2;LAB SERVICE;**153,358,1027**;NOV 01, 1997

 +2       ;;5.2;LAB SERVICE;**153,358**;Sep 27, 1994

 +3        KILL DIC

           SET DIC="^LRO(68,"

           SET DIC(0)="AEMOQ"

           SET LREND=0

           DO ^DIC

           SET LRAA=+Y

           SET LRNAME=$PIECE(Y,U,2)

           IF LRAA<1

               GOTO END

 +4        KILL LRSTAR,DIC

           IF $PIECE(^LRO(68,LRAA,0),U,3)="Y"

               DO STAR^LRWU3

           IF '$DATA(LRSTAR)

               DO PHD

           IF LREND

               GOTO END

W          IF '$DATA(^LRO(68,LRAA,1,LRAD,1,0))&'$DATA(LRSTAR)

               GOTO END

 +1        SET LRUNC=0

           SET LRTSE=-1

 +2        KILL DIC

           WRITE !,"Do you want a specific test?"

           SET %=2

           DO YN^DICN

           IF %=1

               SET DIC="^LAB(60,"

               SET DIC(0)="AEMOQ"

               DO ^DIC

               SET LRTSE=+Y

 +3        WRITE !,"Do you want only incomplete entries?"

           SET %=1

           DO YN^DICN

           IF %=2

               SET LRUNC=1

 +4        WRITE !,"Do you want a long list?"

           SET %=2

           DO YN^DICN

           SET LRSHORT=(%=2)

 +5        SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               GOTO END

 +6        IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="DQ^LRWRKS"

               SET ZTSAVE("LR*")=""

               SET ZTSAVE("LAST")=""

               DO ^%ZTLOAD

               GOTO END

 +7        DO ENT

           GOTO END

ENT        USE IO

           DO URG^LRX

           SET Y=DT

           DO DD^LRX

           SET LRDT0=Y

           SET LRDC=1

           SET LRLINE="---------------------------------------"

 +1        IF '$DATA(LRSTAR)

               SET LRAN=LRFAN-1

               FOR LRIX=0:0

                   SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))

                   SET LREND=0

                   IF LRAN>LRLAN!(LRAN<1)

                       QUIT 

                   DO ACC

 +2        IF $DATA(LRSTAR)

               FOR A=0:0

                   SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))

                   IF LRAD<1!(LRAD>LRWDTL)

                       QUIT 

                   DO AC

 +3        QUIT 

ACC        DO TD

           IF 'LREND

               IF K1

                   IF LRUNC!'LRVER

                       DO ENT^LRWRKS2

 +1        QUIT 

TD         IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

               SET LREND=1

           IF LREND

               QUIT 

           SET LRSN=+$PIECE(^(0),U,5)

           SET LRDAT=+$PIECE(^(0),U,4)

 +1        SET LRVER=1

           SET K1=0

           SET I=0

           FOR 

               SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))

               IF I<.5

                   QUIT 

               SET LRVER=(LRVER&$PIECE(^(I,0),U,5))

               IF 'K1

                   IF LRTSE>0

                       IF +^(0)=LRTSE

                           SET K1=I

 +2        SET K1=$SELECT(LRTSE<0:1,1:K1)

           QUIT 

 +3        QUIT 

PHD        IF LREND

               QUIT 

           SET LREND=0

           SET U="^"

           DO ADATE^LRWU

           IF LREND

               QUIT 

           DO LRAN^LRWU3

           QUIT 

 +1        QUIT 

AC         SET LRTK=LRSTAR-.00001

           FOR B=0:0

               SET LRTK=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK))

               IF LRTK<1!(LAST>1&(LRTK\1>LAST))

                   QUIT 

               DO AC1

 +1        QUIT 

AC1        SET LRAN=0

           FOR 

               SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN))

               IF LRAN<1

                   QUIT 

               IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

                   DO ACC

 +1        QUIT 

%          READ %:DTIME

           IF %=""!(%["N")!(%["Y")

               QUIT 

           WRITE !,"Answer 'Y' or 'N': "

           GOTO %

END        WRITE !!

           IF $EXTRACT(IOST)="P"

               WRITE @IOF

           DO ^%ZISC

           KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,%H,%ZIS,DFN,J,LRDFN,LRDOC,LREDT,LRSDT,LRCDT,LRUID

 +1        KILL %,A,B,I,K,K1,L,LRACC,LRSPEC,LRURG,SEX,SSN,X,Y,DIC,LRUNC,LRDAT,LRAA,LRAD,LRAN,LRDPF,LRSN,LRSTAR,LRSHORT,LAST,PNM,ZTSK,LRDC,LRIDT,LRLLOC,LRODNUM,LRTK,LRV,LRWDTL,POP,T

 +2        KILL LRTSTS,LRLAN,LREND,LRLINE,LRFAN,LRFI,LRIX,LRNAME,LRTSE,LRVER,VA("BID"),VA("PID")

 +3       ;IHS/ANMC/CLS 08/18/96

           KILL HRCN

 +4        QUIT 

EN        ;

DQ         USE IO

           SET U="^"

           DO ENT

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           GOTO END

ALLUNC     WRITE !,"LIST ALL UNVERIFIED TEST's for one day",!

           DO ADATE^LRWU3

           IF LREND

               GOTO END

           SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               GOTO END

 +1        IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="ALL^LRWRKS"

               SET ZTSAVE("LRAD")=""

               DO ^%ZTLOAD

               GOTO END

ALL        SET U="^"

           SET LRUNC=0

           SET LRTSE=-1

           SET LRFAN=1

           SET LRLAN=999999

           SET LRSHORT=1

 +1        FOR LRAA=0:0

               SET LRAA=$ORDER(^LRO(68,LRAA))

               IF LRAA'>0

                   QUIT 

               SET LRAD(1)=LRAD

               SET LRDC=1

               DO AL2

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           GOTO END

AL2        KILL LRSTAR

           SET LAST=LRAD+.99

           SET LRNAME=$PIECE(^LRO(68,LRAA,0),U,1)

           IF $PIECE(^(0),U,3)="Y"

               SET LRSTAR=LRAD

               SET LRWDTL=$EXTRACT(LRAD,1,3)_"0000"

               SET LRAD=LRWDTL-10000

 +1        DO ENT

           SET LRAD=LRAD(1)

           QUIT