LRUMD ;AVAMC/REG/CYM - MD SELECTED LAB RESULTS ; 13-Aug-2013 09:16 ; MKK
;;5.2;LAB SERVICE;**1006,201,341,1027,411,1033**;NOV 1, 1997
;
D L G:Y=-1 END K LRDPAF D LR^LRUMD2 S LRDFN(1)=0,(LRA,LRE,LRG,LRV)=""
W !!,"Print/display tests for a single patient or group " S %=2 D YN^LRU I %=1 D ^LRUMDS G END:'$D(X),MI
D ^LRUMD1 G END:LRV=1,D^LRUMD2:LRV=2 I '$O(^LRO(69.2,LRAA,7,DUZ,1,0)) G END
MI W !!?11,"Print/display microbiology results (excluding antibiotics)",!?26,"instead of defined lab tests" S %=2 D YN^LRU G END:%<1 I %=1 S LRM=1 G DT
A W !!,"Print by (T)est list (P)atient list",! R "Enter T or P: ",Z:DTIME Q:Z=""!(Z[U) S X=$A(Z) S:X>84 X=X-32,Z=$C(X) I X'=80,X'=84 W $C(7)," Enter 'T' for Test List or 'P' for Patient list" G A
D EN^LRUMDS G:%<1 END
;
DT D B^LRU G:Y<0 END S LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT G:$D(LRM) ^LRUMDM
G ^LRUMDP:$A(Z)=80 S ZTRTN="QUE^LRUMD" D BEG^LRUTL G:POP!($D(ZTSK)) END
;
QUE U IO K ^TMP($J) S Z(2)=$O(^LAB(61,"B","SERUM",0)),Z(3)=$O(^LAB(61,"B","BLOOD",0)),Z(5)=$O(^LAB(61,"B","PLASMA",0))
D L^LRU,L1^LRU,S^LRU,EN^LRUMD1 S LR=0 F F=0:1 S LR=$O(^TMP($J,"N",LR)) Q:'LR!(LR("Q")) D P
W:$E(IOST)="P" @IOF D END^LRUTL,END Q
;
P S LRR=0 I LRDFN(1) D I Q
I LRG]""!(LRE) D EN^LRUMDP:LRG]"",EN1^LRUMDP:LRE S P=0 F R=0:0 S P=$O(^TMP($J,P)) Q:P=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,P,LRDFN)) Q:'LRDFN!(LR("Q")) D I
Q:LRG]""!(LRE) S P=0 F R=0:0 S P=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P)) Q:P=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P,LRDFN)) Q:'LRDFN!(LR("Q")) Q:'$$GRP D I
Q
;
I S LRI=LRLDT,W(1)=0 F E=0:0 S LRI=$O(^LR(LRDFN,"CH",LRI)) Q:'LRI!(LRI>LRSDT)!(LR("Q")) I $P(^(LRI,0),"^",4) F B=0:0 S B=$O(^TMP($J,"L",LR,B)) Q:'B!(LR("Q")) S LRT=^(B) I $D(^LR(LRDFN,"CH",LRI,LRT)) D W Q
Q:LR("Q") W:W(1) !,LR("%") Q
;
W S LRR=LRR+1 I LRR=1 D H Q:LR("Q") S LR("F")=1
S W(1)=W(1)+1,X=^LR(LRDFN,"CH",LRI,0),T=$P(X,"^",5),LRDATE=$TR($$Y2K^LRX(+X,"5M"),"@"," ")
; I W(1)=1 S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9),LRL=$S($D(@(X_Y_".1)")):^(.1),$D(^LR(LRDFN,.1)):^(.1),1:"") D SSN^LRU
I W(1)=1 S X=^LR(LRDFN,0),(DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9),LRL=$S($D(@(X_Y_".1)")):^(.1),$D(^LR(LRDFN,.1)):^(.1),1:"") D SSN^LRU ;IHS/ANMC/CLS 08/18/96
; D:$Y>(IOSL-6) H1 Q:LR("Q") W:W(1)=1 !,SSN,?18,$E(LRL,1,5),?39,LRP W !,LRDATE W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?17,$E($P(^LAB(61,T,0),"^"),1,7)
D:$Y>(IOSL-6) H1 Q:LR("Q") W:W(1)=1 !,HRCN,?18,$E(LRL,1,5),?39,LRP W !,LRDATE W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?17,$E($P(^LAB(61,T,0),"^"),1,7) ;IHS/ANMC/CLS 08/18/96
F X=0:0 S X=$O(^TMP($J,"L",LR,X)) Q:'X S LRT=^(X) I $D(^LR(LRDFN,"CH",LRI,LRT)) S Y=^(LRT) W ?(16+(X*8)),$J($P(Y,"^"),6),$P(Y,"^",2)
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"List for: ",$P(^VA(200,DUZ,0),"^") W:LRE ?40,LRE(1) W:IOST'?1"C".E !,"Work copy- DO NOT PUT IN PATIENT'S CHART"
; W !?3,"SSN",?18,"Location",?39,"Patient",! F X=0:0 S X=$O(^TMP($J,"N",LR,X)) Q:'X W ?(16+(X*8)),$J(^TMP($J,"N",LR,X),7)
W !?3,"HRCN",?18,"Location",?39,"Patient",! F X=0:0 S X=$O(^TMP($J,"N",LR,X)) Q:'X W ?(16+(X*8)),$J(^TMP($J,"N",LR,X),7) ; IHS/ANMC/CLS 08/18/96
W !,LR("%1") Q
;
H1 ; D H Q:LR("Q") I W(1)>1 W !,SSN,?18,$E(LRL,1,5),?39,LRP
D H Q:LR("Q") I W(1)>1 W !,HRCN,?18,$E(LRL,1,5),?39,LRP ; IHS/ANMC/CLS 08/18/96
Q
;
L ;from LRUMDU
D END S X="CHEMISTRY" D ^LRUTL Q
;
EN D L Q:Y=-1 S DA=LRAA,DR=60,DIE=69.2 D ^DIE G END
END D V^LRU Q
;
EN2 D L Q:Y=-1 W !?10,"Delete users' lab test/patient lists" R !?10,"if they haven't used the lists since: T-6 MONTHS// ",X:DTIME Q:X[U!'$T S:X="" X="T-6M"
S %DT="E",%DT(0)="-N" D ^%DT K %DT I Y<1 W !?10,"Enter a date in the past",! G EN2
W !!?10,"OK to delete " S %=1 D YN^LRU Q:%'=1
S Y=Y+.99,A(1)=0 F A=0:0 S A=$O(^LRO(69.2,LRAA,7,A)) Q:'A S X=$G(^(A,0)) I $P(X,"^",2)'="",$P(X,"^",2)<Y K ^LRO(69.2,LRAA,7,A) W "." S A(1)=A(1)+1
S X(1)=$O(^LRO(69.2,LRAA,7,0)) S:'X(1) X(1)=0 L +^LRO(69.2,LRAA,7):999 S X=^LRO(69.2,LRAA,7,0),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)=0:X(1),1:($P(X,"^",4)-1)) L -^LRO(69.2,LRAA,7) W !!,"DONE" Q
W !!?10,$C(7),"DONE" D V^LRU Q
GRP() ; function to determine if patient is in selected patient group list when printing by test list
; returns 1 if patient is ok to print, 0 if patient is not in selected patient group list
N X,Y
S X=1
I $G(LRA)]"" D
. S Y=$G(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1))
. I Y'=LRA S X=0
Q X
LRUMD ;AVAMC/REG/CYM - MD SELECTED LAB RESULTS ; 13-Aug-2013 09:16 ; MKK
+1 ;;5.2;LAB SERVICE;**1006,201,341,1027,411,1033**;NOV 1, 1997
+2 ;
+3 DO L
IF Y=-1
GOTO END
KILL LRDPAF
DO LR^LRUMD2
SET LRDFN(1)=0
SET (LRA,LRE,LRG,LRV)=""
+4 WRITE !!,"Print/display tests for a single patient or group "
SET %=2
DO YN^LRU
IF %=1
DO ^LRUMDS
IF '$DATA(X)
GOTO END
GOTO MI
+5 DO ^LRUMD1
IF LRV=1
GOTO END
IF LRV=2
GOTO D^LRUMD2
IF '$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
GOTO END
MI WRITE !!?11,"Print/display microbiology results (excluding antibiotics)",!?26,"instead of defined lab tests"
SET %=2
DO YN^LRU
IF %<1
GOTO END
IF %=1
SET LRM=1
GOTO DT
A WRITE !!,"Print by (T)est list (P)atient list",!
READ "Enter T or P: ",Z:DTIME
IF Z=""!(Z[U)
QUIT
SET X=$ASCII(Z)
IF X>84
SET X=X-32
SET Z=$CHAR(X)
IF X'=80
IF X'=84
WRITE $CHAR(7)," Enter 'T' for Test List or 'P' for Patient list"
GOTO A
+1 DO EN^LRUMDS
IF %<1
GOTO END
+2 ;
DT DO B^LRU
IF Y<0
GOTO END
SET LRLDT=9999998-LRLDT
SET LRSDT=9999999-LRSDT
IF $DATA(LRM)
GOTO ^LRUMDM
+1 IF $ASCII(Z)=80
GOTO ^LRUMDP
SET ZTRTN="QUE^LRUMD"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
+2 ;
QUE USE IO
KILL ^TMP($JOB)
SET Z(2)=$ORDER(^LAB(61,"B","SERUM",0))
SET Z(3)=$ORDER(^LAB(61,"B","BLOOD",0))
SET Z(5)=$ORDER(^LAB(61,"B","PLASMA",0))
+1 DO L^LRU
DO L1^LRU
DO S^LRU
DO EN^LRUMD1
SET LR=0
FOR F=0:1
SET LR=$ORDER(^TMP($JOB,"N",LR))
IF 'LR!(LR("Q"))
QUIT
DO P
+2 IF $EXTRACT(IOST)="P"
WRITE @IOF
DO END^LRUTL
DO END
QUIT
+3 ;
P SET LRR=0
IF LRDFN(1)
DO I
QUIT
+1 IF LRG]""!(LRE)
IF LRG]""
DO EN^LRUMDP
IF LRE
DO EN1^LRUMDP
SET P=0
FOR R=0:0
SET P=$ORDER(^TMP($JOB,P))
IF P=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,P,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
DO I
+2 IF LRG]""!(LRE)
QUIT
SET P=0
FOR R=0:0
SET P=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P))
IF P=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
IF '$$GRP
QUIT
DO I
+3 QUIT
+4 ;
I SET LRI=LRLDT
SET W(1)=0
FOR E=0:0
SET LRI=$ORDER(^LR(LRDFN,"CH",LRI))
IF 'LRI!(LRI>LRSDT)!(LR("Q"))
QUIT
IF $PIECE(^(LRI,0),"^",4)
FOR B=0:0
SET B=$ORDER(^TMP($JOB,"L",LR,B))
IF 'B!(LR("Q"))
QUIT
SET LRT=^(B)
IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
DO W
QUIT
+1 IF LR("Q")
QUIT
IF W(1)
WRITE !,LR("%")
QUIT
+2 ;
W SET LRR=LRR+1
IF LRR=1
DO H
IF LR("Q")
QUIT
SET LR("F")=1
+1 SET W(1)=W(1)+1
SET X=^LR(LRDFN,"CH",LRI,0)
SET T=$PIECE(X,"^",5)
SET LRDATE=$TRANSLATE($$Y2K^LRX(+X,"5M"),"@"," ")
+2 ; I W(1)=1 S X=^LR(LRDFN,0),Y=$P">P">P">P">P">P">P">P(X,"^",3),(LRDP">P">P">P">P">P">P">PF,X)=$P">P">P">P">P">P">P">P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP">P">P">P">P">P">P">P=$P">P">P">P">P">P">P">P(V,"^"),SSN=$P">P">P">P">P">P">P">P(V,"^",9),LRL=$S($D(@(X_Y_".1)")):^(.1),$D(^LR(LRDFN,.1)):^(.1),1:"") D SSN^LRU
+3 ;IHS/ANMC/CLS 08/18/96
IF W(1)=1
SET X=^LR(LRDFN,0)
SET (DFN,Y)=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET V=@(X_Y_",0)")
SET LRP=$PIECE(V,"^")
SET SSN=$PIECE(V,"^",9)
SET LRL=$SELECT($DATA(@(X_Y_".1)")):^(.1),$DATA(^LR(LRDFN,.1)):^(.1),1:"")
DO SSN^LRU
+4 ; D:$Y>(IOSL-6) H1 Q:LR("Q") W:W(1)=1 !,SSN,?18,$E(LRL,1,5),?39,LRP W !,LRDATE W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?17,$E($P(^LAB(61,T,0),"^"),1,7)
+5 ;IHS/ANMC/CLS 08/18/96
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
IF W(1)=1
WRITE !,HRCN,?18,$EXTRACT(LRL,1,5),?39,LRP
WRITE !,LRDATE
IF T'=Z(2)&(T'=Z(3))&(T'=Z(5))
WRITE ?17,$EXTRACT($PIECE(^LAB(61,T,0),"^"),1,7)
+6 FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L",LR,X))
IF 'X
QUIT
SET LRT=^(X)
IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
SET Y=^(LRT)
WRITE ?(16+(X*8)),$JUSTIFY($PIECE(Y,"^"),6),$PIECE(Y,"^",2)
+7 QUIT
+8 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"List for: ",$PIECE(^VA(200,DUZ,0),"^")
IF LRE
WRITE ?40,LRE(1)
IF IOST'?1"C".E
WRITE !,"Work copy- DO NOT PUT IN PATIENT'S CHART"
+2 ; W !?3,"SSN",?18,"Location",?39,"Patient",! F X=0:0 S X=$O(^TMP($J,"N",LR,X)) Q:'X W ?(16+(X*8)),$J(^TMP($J,"N",LR,X),7)
+3 ; IHS/ANMC/CLS 08/18/96
WRITE !?3,"HRCN",?18,"Location",?39,"Patient",!
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"N",LR,X))
IF 'X
QUIT
WRITE ?(16+(X*8)),$JUSTIFY(^TMP($JOB,"N",LR,X),7)
+4 WRITE !,LR("%1")
QUIT
+5 ;
H1 ; D H Q:LR("Q") I W(1)>1 W !,SSN,?18,$E(LRL,1,5),?39,LRP
+1 ; IHS/ANMC/CLS 08/18/96
DO H
IF LR("Q")
QUIT
IF W(1)>1
WRITE !,HRCN,?18,$EXTRACT(LRL,1,5),?39,LRP
+2 QUIT
+3 ;
L ;from LRUMDU
+1 DO END
SET X="CHEMISTRY"
DO ^LRUTL
QUIT
+2 ;
EN DO L
IF Y=-1
QUIT
SET DA=LRAA
SET DR=60
SET DIE=69.2
DO ^DIE
GOTO END
END DO V^LRU
QUIT
+1 ;
EN2 DO L
IF Y=-1
QUIT
WRITE !?10,"Delete users' lab test/patient lists"
READ !?10,"if they haven't used the lists since: T-6 MONTHS// ",X:DTIME
IF X[U!'$TEST
QUIT
IF X=""
SET X="T-6M"
+1 SET %DT="E"
SET %DT(0)="-N"
DO ^%DT
KILL %DT
IF Y<1
WRITE !?10,"Enter a date in the past",!
GOTO EN2
+2 WRITE !!?10,"OK to delete "
SET %=1
DO YN^LRU
IF %'=1
QUIT
+3 SET Y=Y+.99
SET A(1)=0
FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,7,A))
IF 'A
QUIT
SET X=$GET(^(A,0))
IF $PIECE(X,"^",2)'=""
IF $PIECE(X,"^",2)<Y
KILL ^LRO(69.2,LRAA,7,A)
WRITE "."
SET A(1)=A(1)+1
+4 SET X(1)=$ORDER(^LRO(69.2,LRAA,7,0))
IF 'X(1)
SET X(1)=0
LOCK +^LRO(69.2,LRAA,7):999
SET X=^LRO(69.2,LRAA,7,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)=0:X(1),1:($PIECE(X,"^",4)-1))
LOCK -^LRO(69.2,LRAA,7)
WRITE !!,"DONE"
QUIT
+5 WRITE !!?10,$CHAR(7),"DONE"
DO V^LRU
QUIT
GRP() ; function to determine if patient is in selected patient group list when printing by test list
+1 ; returns 1 if patient is ok to print, 0 if patient is not in selected patient group list
+2 NEW X,Y
+3 SET X=1
+4 IF $GET(LRA)]""
Begin DoDot:1
+5 SET Y=$GET(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1))
+6 IF Y'=LRA
SET X=0
End DoDot:1
+7 QUIT X
