LRWRKS ;SLC/RWF - WORK SHEET ACCESSION LIST ;2/19/91 11:48 ;
;;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")
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWRKS 2730 printed Nov 22, 2024@17:33:16 Page 2
LRWRKS ;SLC/RWF - WORK SHEET ACCESSION LIST ;2/19/91 11:48 ;
+1 ;;5.2;LAB SERVICE;**153,358**;Sep 27, 1994
+2 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
+3 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 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
