LRUWG ; IHS/DIR/FJE - SINGLE TEST WORKLIST 2/22/94 09:45 ;
;;5.2;LR;**1013**;JUL 15, 2002
;
;;5.2;LAB SERVICE;;Sep 27, 1994
D END W !!?20,"Single test worklist"
T S DIC=60,DIC(0)="AEMOQZ" D ^DIC K DIC G:Y<1 END S W(1)=$P(Y,U,2),F=+Y
S X=$O(^LAB(60,F,8,0)) I 'X W $C(7),!,"No INSTITUTION designated in LAB TEST FILE (#60, field 6)",! G T
S X(1)=+^LAB(60,F,8,X,0),X(1)=$P(^DIC(4,X(1),0),U)
I $O(^LAB(60,F,8,X)) D ASK G:'$D(X) T
S X=^LAB(60,F,8,X,0),(W,LRAA)=$P(X,"^",2) I 'LRAA W $C(7),!,"No Accession AREA for this test",! G T
D S %DT="AE",%DT("A")="ENTER TEST DATE: " D ^%DT G:Y<1 END D LRAD
S X=$S(X="Y"&(LRAD["0000"):1,X="D"&(+$E(LRAD,6,7)):1,"MQ"[X&(+$E(LRAD,4,5)):1,1:0) I 'X W $C(7)," Date not specific enough" G D
I '$D(^LRO(68,W,1,LRAD,0)) W $C(7),!!,"NO ",W(1)," ACCESSIONS IN FILE FOR ",LRH(0),! G D
ST R !!,"Start from accn #: ",N(1):DTIME G:N(1)=""!(N(1)[U) END G:N(1)'?1N.N ST
R !!,"Go to accn #: LAST// ",N(2):DTIME G:N(2)[U!('$T) END S:N(2)="" N(2)=99999 I N(2)'?1N.N W $C(7),!!,"NUMBERS ONLY" G ST
;S ZTRTN="QUE^LRUW" D BEG^LRUTL G:POP!($D(ZTSK)) END
S ZTRTN="QUE^LRUWG" D BEG^LRUTL G:POP!($D(ZTSK)) END ;IHS/ANMC/CLS 08/18/96
QUE S:$D(ZTQUEUED) ZTREQ="@"
D L^LRU K ^TMP($J) S N=N(1)-1,(LR("Q"),LRQ)=0,LRQ(1)=DUZ(2)
ACN F A=0:0 S N=$O(^LRO(68,W,1,LRAD,1,N)) Q:'N!(N>N(2)) I $D(^(N,0)) S X=^(0),LRLLOC=$P(X,"^",7),LRDFN=+X D:LRDFN TT
D WRT W:IOST'?1"C".E @IOF K ^TMP($J) D END^LRUTL,END Q
L W !,$J(Z,3),") ",$J($S(T(5)>.999:T(5),1:T(5)*1000),5),?14,$P(N,"^",6) W:$L($P(N,"^",6))>21 !
;S X=$P(N,"^",5) W ?37,N(7),?49,$S(X:$P($G(^VA(200,X,0)),"^",2),1:X),?54,$P(N,"^",2),?60,$E($P(N,"^"),1,19),!?15 F X=1:1:IOM-15 W "-"
S X=$P(N,"^",5) W ?29,N(7),?41,$S(X:$P($G(^VA(200,X,0)),"^",2),1:X),?45,$P(N,"^",2),?52,$E($P(N,"^"),1,20),?73,$P(N,"^",3),!?13 F X=1:1:IOM-13 W "-" ;IHS/ANMC/CLS 08/18/96
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,^TMP($J,W,0)," Worklist",?40,"(* = STAT)"
;W !,"COUNT",?6,"ACC#",?17,"RESULT",?37,"Completed",?49,"Tech",?54,"ID",?60,"PATIENT",!,LR("%"),! Q
W !,"COUNT",?6,"ACC#",?14,"RESULT",?29,"Completed",?40,"Tech",?45,"ID",?52,"PATIENT",?72,"LOCATION",!,LR("%"),! Q ;IHS/ANMC/CLS 08/18/96
NEW D H Q:LR("Q") W !?15,T(2),T(3),":",!,LRH(0) Q
TT F T=0:0 S T=$O(^LRO(68,W,1,LRAD,1,N,4,T)) Q:'T!(T=F)
;S X=^LR(LRDFN,0),Y=$P(X,"^",3),LRDPF=$P(X,U,2),(X,LRPF)=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU
S X=^LR(LRDFN,0),(DFN,Y)=$P(X,"^",3),LRDPF=$P(X,U,2),(X,LRPF)=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU ;IHS/ANMC/CLS 08/18/96
Q:T<1 S T(4)=^LRO(68,W,1,LRAD,1,N,4,T,0),V=$P(T(4),"^",4),T(6)=$P(T(4),"^",5),T(1)=$P(T(4),"^",2),T(4)=$P(T(4),"^",6) S:T(1)=1 T(1)="*" D STF
Q
STF ;
I '$D(^TMP($J,W,1,T,0)) S X=^LAB(60,T,0),P=$S($D(^LAB(60,T,.1)):" ("_$P(^(.1),"^")_")",1:""),^TMP($J,W,1,T,0)=$P(X,"^")_"^"_P,^TMP($J,W,1,"B",$P(X,"^"),T)=""
I '$D(^TMP($J,W,0)) S X=$S($D(^LRO(68,W,0)):$P(^(0),"^"),1:"??"),^TMP($J,W,0)=X
;I LRPF="^LAB(62.3," S C(6)=N,N=N/1000,^TMP($J,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6),N=C(6) Q
I LRPF="^LAB(62.3," S C(6)=N,N=N/1000,^TMP($J,W,1,T,N)=LRP_"^"_HRCN_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6),N=C(6) Q ;IHS/ANMC/CLS 08/18/96
;S ^TMP($J,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6) Q
S ^TMP($J,W,1,T,N)=LRP_"^"_HRCN_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6) Q ;IHS/ANMC/CLS 08/18/96
WRT F W=0:0 S W=$O(^TMP($J,W)),LRQ=0 Q:'W D H Q:LR("Q") S LR("F")=1 D ZZ
Q
ZZ S A(8)=0 F X=0:0 S A(8)=$O(^TMP($J,W,1,"B",A(8))) Q:A(8)=""!(LR("Q")) S T=$O(^(A(8),0)) D:$Y>(IOSL-6) H Q:LR("Q") S T(3)=^TMP($J,W,1,T,0),T(2)=$P(T(3),"^"),T(3)=$P(T(3),"^",2) W !?15,T(2),T(3),":",!,LRH(0) S T(5)=0 D SCN
Q
SCN F Z=1:1 S T(5)=$O(^TMP($J,W,1,T,T(5))) Q:T(5)=""!(LR("Q")) S N=^TMP($J,W,1,T,T(5)),Y=$P(N,"^",7) D T^LRU S N(7)=Y D:$Y>(IOSL-6) NEW Q:LR("Q") D L
Q
ASK S DIC="^LAB(60,F,8,",DIC(0)="AEMOQZ",DIC("B")=X(1) D ^DIC K DIC I Y<1 K X Q
S X=+Y Q
LRAD S X=$P(^LRO(68,LRAA,0),"^",3),(Y,LRAD)=$S(X="Y":$E(Y,1,3)_"0000","M"[X:$E(Y,1,5)_"00","Q"[X:$E(Y,1,3)_"0000"+(($E(Y,4,5)-1)\3*300+100),1:Y) D D^LRU S LRH(0)=Y Q
;
END D V^LRU Q
LRUWG ; IHS/DIR/FJE - SINGLE TEST WORKLIST 2/22/94 09:45 ;
+1 ;;5.2;LR;**1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 DO END
WRITE !!?20,"Single test worklist"
T SET DIC=60
SET DIC(0)="AEMOQZ"
DO ^DIC
KILL DIC
IF Y<1
GOTO END
SET W(1)=$PIECE(Y,U,2)
SET F=+Y
+1 SET X=$ORDER(^LAB(60,F,8,0))
IF 'X
WRITE $CHAR(7),!,"No INSTITUTION designated in LAB TEST FILE (#60, field 6)",!
GOTO T
+2 SET X(1)=+^LAB(60,F,8,X,0)
SET X(1)=$PIECE(^DIC(4,X(1),0),U)
+3 IF $ORDER(^LAB(60,F,8,X))
DO ASK
IF '$DATA(X)
GOTO T
+4 SET X=^LAB(60,F,8,X,0)
SET (W,LRAA)=$PIECE(X,"^",2)
IF 'LRAA
WRITE $CHAR(7),!,"No Accession AREA for this test",!
GOTO T
D SET %DT="AE"
SET %DT("A")="ENTER TEST DATE: "
DO ^%DT
IF Y<1
GOTO END
DO LRAD
+1 SET X=$SELECT(X="Y"&(LRAD["0000"):1,X="D"&(+$EXTRACT(LRAD,6,7)):1,"MQ"[X&(+$EXTRACT(LRAD,4,5)):1,1:0)
IF 'X
WRITE $CHAR(7)," Date not specific enough"
GOTO D
+2 IF '$DATA(^LRO(68,W,1,LRAD,0))
WRITE $CHAR(7),!!,"NO ",W(1)," ACCESSIONS IN FILE FOR ",LRH(0),!
GOTO D
ST READ !!,"Start from accn #: ",N(1):DTIME
IF N(1)=""!(N(1)[U)
GOTO END
IF N(1)'?1N.N
GOTO ST
+1 READ !!,"Go to accn #: LAST// ",N(2):DTIME
IF N(2)[U!('$TEST)
GOTO END
IF N(2)=""
SET N(2)=99999
IF N(2)'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY"
GOTO ST
+2 ;S ZTRTN="QUE^LRUW" D BEG^LRUTL G:POP!($D(ZTSK)) END
+3 ;IHS/ANMC/CLS 08/18/96
SET ZTRTN="QUE^LRUWG"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 DO L^LRU
KILL ^TMP($JOB)
SET N=N(1)-1
SET (LR("Q"),LRQ)=0
SET LRQ(1)=DUZ(2)
ACN FOR A=0:0
SET N=$ORDER(^LRO(68,W,1,LRAD,1,N))
IF 'N!(N>N(2))
QUIT
IF $DATA(^(N,0))
SET X=^(0)
SET LRLLOC=$PIECE(X,"^",7)
SET LRDFN=+X
IF LRDFN
DO TT
+1 DO WRT
IF IOST'?1"C".E
WRITE @IOF
KILL ^TMP($JOB)
DO END^LRUTL
DO END
QUIT
L WRITE !,$JUSTIFY(Z,3),") ",$JUSTIFY($SELECT(T(5)>.999:T(5),1:T(5)*1000),5),?14,$PIECE(N,"^",6)
IF $LENGTH($PIECE(N,"^",6))>21
WRITE !
+1 ;S X=$P(N,"^",5) W ?37,N(7),?49,$S(X:$P($G(^VA(200,X,0)),"^",2),1:X),?54,$P(N,"^",2),?60,$E($P(N,"^"),1,19),!?15 F X=1:1:IOM-15 W "-"
+2 ;IHS/ANMC/CLS 08/18/96
SET X=$PIECE(N,"^",5)
WRITE ?29,N(7),?41,$SELECT(X:$PIECE($GET(^VA(200,X,0)),"^",2),1:X),?45,$PIECE(N,"^",2),?52,$EXTRACT($PIECE(N,"^"),1,20),?73,$PIECE(N,"^",3),!?13
FOR X=1:1:IOM-13
WRITE "-"
+3 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,^TMP($JOB,W,0)," Worklist",?40,"(* = STAT)"
+2 ;W !,"COUNT",?6,"ACC#",?17,"RESULT",?37,"Completed",?49,"Tech",?54,"ID",?60,"PATIENT",!,LR("%"),! Q
+3 ;IHS/ANMC/CLS 08/18/96
WRITE !,"COUNT",?6,"ACC#",?14,"RESULT",?29,"Completed",?40,"Tech",?45,"ID",?52,"PATIENT",?72,"LOCATION",!,LR("%"),!
QUIT
NEW DO H
IF LR("Q")
QUIT
WRITE !?15,T(2),T(3),":",!,LRH(0)
QUIT
TT FOR T=0:0
SET T=$ORDER(^LRO(68,W,1,LRAD,1,N,4,T))
IF 'T!(T=F)
QUIT
+1 ;S X=^LR(LRDFN,0),Y=$P(X,"^",3),LRDPF=$P(X,U,2),(X,LRPF)=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU
+2 ;IHS/ANMC/CLS 08/18/96
SET X=^LR(LRDFN,0)
SET (DFN,Y)=$PIECE(X,"^",3)
SET LRDPF=$PIECE(X,U,2)
SET (X,LRPF)=^DIC($PIECE(X,"^",2),0,"GL")
SET X=@(X_Y_",0)")
SET LRP=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
DO SSN^LRU
+3 IF T<1
QUIT
SET T(4)=^LRO(68,W,1,LRAD,1,N,4,T,0)
SET V=$PIECE(T(4),"^",4)
SET T(6)=$PIECE(T(4),"^",5)
SET T(1)=$PIECE(T(4),"^",2)
SET T(4)=$PIECE(T(4),"^",6)
IF T(1)=1
SET T(1)="*"
DO STF
+4 QUIT
STF ;
+1 IF '$DATA(^TMP($JOB,W,1,T,0))
SET X=^LAB(60,T,0)
SET P=$SELECT($DATA(^LAB(60,T,.1)):" ("_$PIECE(^(.1),"^")_")",1:"")
SET ^TMP($JOB,W,1,T,0)=$PIECE(X,"^")_"^"_P
SET ^TMP($JOB,W,1,"B",$PIECE(X,"^"),T)=""
+2 IF '$DATA(^TMP($JOB,W,0))
SET X=$SELECT($DATA(^LRO(68,W,0)):$PIECE(^(0),"^"),1:"??")
SET ^TMP($JOB,W,0)=X
+3 ;I LRPF="^LAB(62.3," S C(6)=N,N=N/1000,^TMP($J,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6),N=C(6) Q
+4 ;IHS/ANMC/CLS 08/18/96
IF LRPF="^LAB(62.3,"
SET C(6)=N
SET N=N/1000
SET ^TMP($JOB,W,1,T,N)=LRP_"^"_HRCN_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6)
SET N=C(6)
QUIT
+5 ;S ^TMP($J,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6) Q
+6 ;IHS/ANMC/CLS 08/18/96
SET ^TMP($JOB,W,1,T,N)=LRP_"^"_HRCN_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6)
QUIT
WRT FOR W=0:0
SET W=$ORDER(^TMP($JOB,W))
SET LRQ=0
IF 'W
QUIT
DO H
IF LR("Q")
QUIT
SET LR("F")=1
DO ZZ
+1 QUIT
ZZ SET A(8)=0
FOR X=0:0
SET A(8)=$ORDER(^TMP($JOB,W,1,"B",A(8)))
IF A(8)=""!(LR("Q"))
QUIT
SET T=$ORDER(^(A(8),0))
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
SET T(3)=^TMP($JOB,W,1,T,0)
SET T(2)=$PIECE(T(3),"^")
SET T(3)=$PIECE(T(3),"^",2)
WRITE !?15,T(2),T(3),":",!,LRH(0)
SET T(5)=0
DO SCN
+1 QUIT
SCN FOR Z=1:1
SET T(5)=$ORDER(^TMP($JOB,W,1,T,T(5)))
IF T(5)=""!(LR("Q"))
QUIT
SET N=^TMP($JOB,W,1,T,T(5))
SET Y=$PIECE(N,"^",7)
DO T^LRU
SET N(7)=Y
IF $Y>(IOSL-6)
DO NEW
IF LR("Q")
QUIT
DO L
+1 QUIT
ASK SET DIC="^LAB(60,F,8,"
SET DIC(0)="AEMOQZ"
SET DIC("B")=X(1)
DO ^DIC
KILL DIC
IF Y<1
KILL X
QUIT
+1 SET X=+Y
QUIT
LRAD SET X=$PIECE(^LRO(68,LRAA,0),"^",3)
SET (Y,LRAD)=$SELECT(X="Y":$EXTRACT(Y,1,3)_"0000","M"[X:$EXTRACT(Y,1,5)_"00","Q"[X:$EXTRACT(Y,1,3)_"0000"+(($EXTRACT(Y,4,5)-1)\3*300+100),1:Y)
DO D^LRU
SET LRH(0)=Y
QUIT
+1 ;
END DO V^LRU
QUIT
