LRUMDP ;AVAMC/REG/CYM - MD SELECTED LAB RESULTS ;2/19/98 09:16 ;
;;5.2;LAB SERVICE;**3,153,201,439**;Sep 27, 1994;Build 2
W !!,"New page for each patient " S %=2 D YN^LRU G:%<1 END S:%=1 LRK=1
S ZTRTN="QUE^LRUMDP" 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 D:'$D(LRK) H S P=0,LR("F")=1 I LRDFN(1) D I G OUT
I LRG]""!(LRE) D EN:LRG]"",EN1:LRE D L G OUT
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")) D I
OUT W:$E(IOST)="P" @IOF D END^LRUTL,END Q
I I LRA]"" Q:'$D(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1)) Q:LRA'=^(1)
J ;
Q:'$D(^LR(LRDFN,0)) S X=^(0) D
.S 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)_" "_$G(@(X_Y_",.101)")),$D(^LR(LRDFN,.1)):^(.1)_" "_$G(@(X_Y_",.101)")),1:"No Room") D SSN^LRU
D:$Y>(IOSL-6)!($D(LRK)) H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP S LR=0 F F=0:1 S LR=$O(^TMP($J,"N",LR)) Q:'LR!(LR("Q")) D T
Q:LR("Q") W !,LR("%1") Q
T S LRI=LRLDT,W(1)=0 F 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) Q:LRT="" I $D(^LR(LRDFN,"CH",LRI,LRT)) D W Q
Q:LR("Q") W:W(1) !,LR("%") Q
;
W I $Y>(IOSL-6) D H1 Q:LR("Q") S W(1)=W(1)+1
S W(1)=W(1)+1,X=^LR(LRDFN,"CH",LRI,0),Y=+X,T=$P(X,"^",5),LRDATE=$TR($$Y2K^LRX(Y,"5M"),"@"," ")
D:W(1)=1 A W !,LRDATE W:T'=Z(2)&(T'=Z(3))&(T'=Z(5)) ?15,$E($P(^LAB(61,T,0),"^"),1,7)
F X=0:0 S X=$O(^TMP($J,"L",LR,X)) Q:'X S LRT=^(X) I LRT'="",$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:LRA]"" ?40,"PT GRP: ",LRA W:LRE ?40,LRE(1) W:IOST'?1"C".E !,"Work copy- DO NOT PUT IN PATIENT'S CHART" W !,LR("%") Q
H1 D H Q:LR("Q") W !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP Q:W(1)=1
A W ! 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)
Q
L 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:P'="N"&(P'="L") J
Q
EN F X=0:0 S X=$O(^DPT("CN",LRG,X)) Q:'X I $D(^DPT(X,"LR")) S Y=^("LR") S:Y ^TMP($J,$P(^DPT(X,0),"^"),Y)=""
Q
EN1 F X=LRE(2):0 S X=$O(^SC(LRE,"S",X)) Q:'X!(X\1-LRE(2)) F Y=0:0 S Y=$O(^SC(LRE,"S",X,1,Y)) Q:'Y S Z=+^(Y,0),A=$S($D(^DPT(Z,"LR")):+^("LR"),1:0) S:A ^TMP($J,$P(^DPT(Z,0),"^"),A)=""
Q
;
END W:$E(IOST)="P" @IOF D V^LRU K LRE,E Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUMDP 2688 printed Oct 16, 2024@18:22:27 Page 2
LRUMDP ;AVAMC/REG/CYM - MD SELECTED LAB RESULTS ;2/19/98 09:16 ;
+1 ;;5.2;LAB SERVICE;**3,153,201,439**;Sep 27, 1994;Build 2
+2 WRITE !!,"New page for each patient "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=1
SET LRK=1
+3 SET ZTRTN="QUE^LRUMDP"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
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
if '$DATA(LRK)
DO H
SET P=0
SET LR("F")=1
IF LRDFN(1)
DO I
GOTO OUT
+2 IF LRG]""!(LRE)
if LRG]""
DO EN
if LRE
DO EN1
DO L
GOTO OUT
+3 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
DO I
OUT if $EXTRACT(IOST)="P"
WRITE @IOF
DO END^LRUTL
DO END
QUIT
I IF LRA]""
if '$DATA(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,1))
QUIT
if LRA'=^(1)
QUIT
J ;
+1 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
Begin DoDot:1
+2 SET 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)_" "_$GET(@(X_Y_",.101)")),$DATA(^LR(LRDFN,.1)):^(.1)_" "_$GET(@(X_Y_",.101)")),1:"No Room")
DO SSN^LRU
End DoDot:1
+3 if $Y>(IOSL-6)!($DATA(LRK))
DO H
if LR("Q")
QUIT
WRITE !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP
SET LR=0
FOR F=0:1
SET LR=$ORDER(^TMP($JOB,"N",LR))
if 'LR!(LR("Q"))
QUIT
DO T
+4 if LR("Q")
QUIT
WRITE !,LR("%1")
QUIT
T SET LRI=LRLDT
SET W(1)=0
FOR
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 LRT=""
QUIT
IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
DO W
QUIT
+1 if LR("Q")
QUIT
if W(1)
WRITE !,LR("%")
QUIT
+2 ;
W IF $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
SET W(1)=W(1)+1
+1 SET W(1)=W(1)+1
SET X=^LR(LRDFN,"CH",LRI,0)
SET Y=+X
SET T=$PIECE(X,"^",5)
SET LRDATE=$TRANSLATE($$Y2K^LRX(Y,"5M"),"@"," ")
+2 if W(1)=1
DO A
WRITE !,LRDATE
if T'=Z(2)&(T'=Z(3))&(T'=Z(5))
WRITE ?15,$EXTRACT($PIECE(^LAB(61,T,0),"^"),1,7)
+3 FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L",LR,X))
if 'X
QUIT
SET LRT=^(X)
IF LRT'=""
IF $DATA(^LR(LRDFN,"CH",LRI,LRT))
SET Y=^(LRT)
WRITE ?(16+(X*8)),$JUSTIFY($PIECE(Y,"^"),6),$PIECE(Y,"^",2)
+4 QUIT
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 LRA]""
WRITE ?40,"PT GRP: ",LRA
if LRE
WRITE ?40,LRE(1)
if IOST'?1"C".E
WRITE !,"Work copy- DO NOT PUT IN PATIENT'S CHART"
WRITE !,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !,SSN,?19,"LOC:",LRL,?44,"Patient: ",LRP
if W(1)=1
QUIT
A WRITE !
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)
+1 QUIT
L 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
if P'="N"&(P'="L")
DO J
+1 QUIT
EN FOR X=0:0
SET X=$ORDER(^DPT("CN",LRG,X))
if 'X
QUIT
IF $DATA(^DPT(X,"LR"))
SET Y=^("LR")
if Y
SET ^TMP($JOB,$PIECE(^DPT(X,0),"^"),Y)=""
+1 QUIT
EN1 FOR X=LRE(2):0
SET X=$ORDER(^SC(LRE,"S",X))
if 'X!(X\1-LRE(2))
QUIT
FOR Y=0:0
SET Y=$ORDER(^SC(LRE,"S",X,1,Y))
if 'Y
QUIT
SET Z=+^(Y,0)
SET A=$SELECT($DATA(^DPT(Z,"LR")):+^("LR"),1:0)
if A
SET ^TMP($JOB,$PIECE(^DPT(Z,0),"^"),A)=""
+1 QUIT
+2 ;
END if $EXTRACT(IOST)="P"
WRITE @IOF
DO V^LRU
KILL LRE,E
QUIT
