LRUPQ1 ; IHS/DIR/FJE - LAB RESULTS BY ACCESSION AREA (COND'T) 3/8/94 09:03 ;
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
S X=$S($D(^LRO(68,LR,1,LRAD,1,N,5,1,0)):^(0),1:""),C(3)=+X S:'C(3) C(3)=LRU S C(2)=$P(X,"^",2) S:'C(2) C(2)=LRU(1)
Q:'$D(^LRO(68,LR,1,LRAD,1,N,0)) S X=^(0),LRDFN=+X,A(3)=$P(X,"^",3),A(7)=$P(X,"^",7) Q:'$D(^(3)) S X=^(3),LRI=$P(X,"^",5),(Y,A(3))=$S($P(X,"^",3):$P(X,"^",3),1:A(3)) D:Y T S M=Y
I '$D(^LR(LRDFN,0)) W !,$J(N,7),?11,"Entry not in lab results file" Q
S Y=$P(^LR(LRDFN,LR(3),LRI,0),"^",3) D:Y T S M(1)=Y
;D:$Y>(IOSL-6) H^LRUPQ Q:LR("Q") W !,$J(N,5) S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL")
D:$Y>(IOSL-6) H^LRUPQ Q:LR("Q") W !,$J(N,5) S X=^LR(LRDFN,0),(DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL") ;IHS/ANMC/CLS 08/18/96
S X=@(X_Y_",0)"),SSN=$P(X,"^",9),LRP=$P(X,"^") D SSN^LRU
;W ?7 W:P(0)'="PATIENT" "#" W $E(LRP,1,20),?28,SSN(1),?34,$E(A(7),1,5)
W ?7 W:P(0)'="VA PATIENT" "#" W $E(LRP,1,18),?27,HRCN,?34,$E(A(7),1,5) ;IHS/ANMC/CLS/ 08/18/96
I '$D(^LR(LRDFN,LR(3),LRI,0)) W ?40,"Not in lab results file" Q
W ?41,$S(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$E($P(^LAB(62,C(2),0),"^"),1,14),$D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,13),1:""),?56,M,?68,M(1)
W S Z=0 F A=0:1 S Z=$O(^LRO(68,LR,1,LRAD,1,N,4,Z)) Q:'Z!(LR("Q")) W:'A !?7,"Test(s): " S Z(3)=^(Z,0) D:+Z(3) L
F Z=2,3,8,7,6,5,19,18,17,15,4,11,12,10,9,14,13,16 I $D(^LR(LRDFN,"CH",LRI,Z)) S LR(5)=^(Z) D:$Y>(IOSL-6) H Q:LR("Q") W !,$E($P(^DD(63.04,Z,0),"^"),1,20),?21,$J($P(LR(5),"^"),7)
S Z=19 F A=0:1 S Z=$O(^LR(LRDFN,"CH",LRI,Z)) Q:'Z!(LR("Q")) S LR(5)=^(Z) D:$Y>(IOSL-6) H Q:LR("Q") W !,$E($P(^DD(63.04,Z,0),"^"),1,20),?21,$J($P(LR(5),"^"),7)
Q
L W:$X>(IOM-7) ! W " ",$P(^LAB(60,Z,.1),"^") Q
;
H ;D H^LRUPQ Q:LR("Q") W !,LR(4),!,LRP," ",SSN," (continued from pg ",LRQ-1,")" Q
D H^LRUPQ Q:LR("Q") W !,LR(4),!,LRP," ",HRCN," (continued from pg ",LRQ-1,")" Q ;IHS/ANMC/CLS 08/18/96
T S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_" "_$S(Y[".":$E(Y,9,10)_":"_$E(Y,11,12),1:"") Q
LRUPQ1 ; IHS/DIR/FJE - LAB RESULTS BY ACCESSION AREA (COND'T) 3/8/94 09:03 ;
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 SET X=$SELECT($DATA(^LRO(68,LR,1,LRAD,1,N,5,1,0)):^(0),1:"")
SET C(3)=+X
IF 'C(3)
SET C(3)=LRU
SET C(2)=$PIECE(X,"^",2)
IF 'C(2)
SET C(2)=LRU(1)
+5 IF '$DATA(^LRO(68,LR,1,LRAD,1,N,0))
QUIT
SET X=^(0)
SET LRDFN=+X
SET A(3)=$PIECE(X,"^",3)
SET A(7)=$PIECE(X,"^",7)
IF '$DATA(^(3))
QUIT
SET X=^(3)
SET LRI=$PIECE(X,"^",5)
SET (Y,A(3))=$SELECT($PIECE(X,"^",3):$PIECE(X,"^",3),1:A(3))
IF Y
DO T
SET M=Y
+6 IF '$DATA(^LR(LRDFN,0))
WRITE !,$JUSTIFY(N,7),?11,"Entry not in lab results file"
QUIT
+7 SET Y=$PIECE(^LR(LRDFN,LR(3),LRI,0),"^",3)
IF Y
DO T
SET M(1)=Y
+8 ;D:$Y>(IOSL-6) H^LRUPQ Q:LR("Q") W !,$J(N,5) S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL")
+9 ;IHS/ANMC/CLS 08/18/96
IF $Y>(IOSL-6)
DO H^LRUPQ
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(N,5)
SET X=^LR(LRDFN,0)
SET (DFN,Y)=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET P(0)=$PIECE(^DIC(X,0),"^")
SET X=^DIC(X,0,"GL")
+10 SET X=@(X_Y_",0)")
SET SSN=$PIECE(X,"^",9)
SET LRP=$PIECE(X,"^")
DO SSN^LRU
+11 ;W ?7 W:P(0)'="PATIENT" "#" W $E(LRP,1,20),?28,SSN(1),?34,$E(A(7),1,5)
+12 ;IHS/ANMC/CLS/ 08/18/96
WRITE ?7
IF P(0)'="VA PATIENT"
WRITE "#"
WRITE $EXTRACT(LRP,1,18),?27,HRCN,?34,$EXTRACT(A(7),1,5)
+13 IF '$DATA(^LR(LRDFN,LR(3),LRI,0))
WRITE ?40,"Not in lab results file"
QUIT
+14 WRITE ?41,$SELECT(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$EXTRACT($PIECE(^LAB(62,C(2),0),"^"),1,14),$DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^(0),"^"),1,13),1:""),?56,M,?68,M(1)
W SET Z=0
FOR A=0:1
SET Z=$ORDER(^LRO(68,LR,1,LRAD,1,N,4,Z))
IF 'Z!(LR("Q"))
QUIT
IF 'A
WRITE !?7,"Test(s): "
SET Z(3)=^(Z,0)
IF +Z(3)
DO L
+1 FOR Z=2,3,8,7,6,5,19,18,17,15,4,11,12,10,9,14,13,16
IF $DATA(^LR(LRDFN,"CH",LRI,Z))
SET LR(5)=^(Z)
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !,$EXTRACT($PIECE(^DD(63.04,Z,0),"^"),1,20),?21,$JUSTIFY($PIECE(LR(5),"^"),7)
+2 SET Z=19
FOR A=0:1
SET Z=$ORDER(^LR(LRDFN,"CH",LRI,Z))
IF 'Z!(LR("Q"))
QUIT
SET LR(5)=^(Z)
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
WRITE !,$EXTRACT($PIECE(^DD(63.04,Z,0),"^"),1,20),?21,$JUSTIFY($PIECE(LR(5),"^"),7)
+3 QUIT
L IF $X>(IOM-7)
WRITE !
WRITE " ",$PIECE(^LAB(60,Z,.1),"^")
QUIT
+1 ;
H ;D H^LRUPQ Q:LR("Q") W !,LR(4),!,LRP," ",SSN," (continued from pg ",LRQ-1,")" Q
+1 ;IHS/ANMC/CLS 08/18/96
DO H^LRUPQ
IF LR("Q")
QUIT
WRITE !,LR(4),!,LRP," ",HRCN," (continued from pg ",LRQ-1,")"
QUIT
T SET Y=Y_"000"
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_" "_$SELECT(Y[".":$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
QUIT
