- LRUW ;AVAMC/REG - ACCESSION AREA WORKLIST ;2/22/94 07:21 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END S DIC("A")="WORKLIST GENERATOR for: "
- S DIC=68,DIC(0)="AEMQ" D ^DIC K DIC G:X=""!(X[U) END S (LRAA,W)=+Y,W(1)=$P(Y,U,2)
- D S %DT="AE",%DT("A")="ENTER WORKLIST 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
- DEV S ZTRTN="QUE^LRUW" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S N=N(1)-1 D L^LRU,S^LRU
- 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 T
- 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 "-"
- 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
- NEW D H Q:LR("Q") W !?15,T(2),T(3),":",!,LRH(0) Q
- T S X=^LR(LRDFN,0),Y=$P(X,"^",3),LRDPF=$P(^(0),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 T=0 F Y=0:0 S T=$O(^LRO(68,W,1,LRAD,1,N,4,T)) Q:'T S T(4)=^(T,0),X=$P($G(^LAB(60,T,0)),"^",4) I X'="WK" S V=$P(T(4),"^",4),T(6)=$P($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
- S ^TMP($J,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6) Q
- WRT F W=0:0 S LRQ=0,W=$O(^TMP($J,W)) Q:'W!(LR("Q")) 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUW 2988 printed Dec 13, 2024@02:22:24 Page 2
- LRUW ;AVAMC/REG - ACCESSION AREA WORKLIST ;2/22/94 07:21 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 DO END
- SET DIC("A")="WORKLIST GENERATOR for: "
- +3 SET DIC=68
- SET DIC(0)="AEMQ"
- DO ^DIC
- KILL DIC
- if X=""!(X[U)
- GOTO END
- SET (LRAA,W)=+Y
- SET W(1)=$PIECE(Y,U,2)
- D SET %DT="AE"
- SET %DT("A")="ENTER WORKLIST 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
- DEV SET ZTRTN="QUE^LRUW"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET N=N(1)-1
- DO L^LRU
- DO S^LRU
- 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 T
- +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 SET X=$PIECE(N,"^",5)
- WRITE ?37,N(7),?49,$SELECT(X:$PIECE($GET(^VA(200,X,0)),"^",2),1:X),?54,$PIECE(N,"^",2),?60,$EXTRACT($PIECE(N,"^"),1,19),!?15
- FOR X=1:1:IOM-15
- WRITE "-"
- +2 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 WRITE !,"COUNT",?6,"ACC#",?17,"RESULT",?37,"Completed",?49,"Tech",?54,"ID",?60,"PATIENT",!,LR("%"),!
- QUIT
- NEW DO H
- if LR("Q")
- QUIT
- WRITE !?15,T(2),T(3),":",!,LRH(0)
- QUIT
- T SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET LRDPF=$PIECE(^(0),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
- +1 SET T=0
- FOR Y=0:0
- SET T=$ORDER(^LRO(68,W,1,LRAD,1,N,4,T))
- if 'T
- QUIT
- SET T(4)=^(T,0)
- SET X=$PIECE($GET(^LAB(60,T,0)),"^",4)
- IF X'="WK"
- SET V=$PIECE(T(4),"^",4)
- SET T(6)=$PIECE($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
- +2 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 IF LRPF="^LAB(62.3,"
- SET C(6)=N
- SET N=N/1000
- SET ^TMP($JOB,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6)
- SET N=C(6)
- QUIT
- +4 SET ^TMP($JOB,W,1,T,N)=LRP_"^"_SSN(1)_"^"_LRLLOC_"^"_T(1)_"^"_V_"^"_T(4)_"^"_T(6)
- QUIT
- WRT FOR W=0:0
- SET LRQ=0
- SET W=$ORDER(^TMP($JOB,W))
- if 'W!(LR("Q"))
- 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
- 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