LRBLPD1 ;SLC/DCM - BB PT INFO for OE/RR pt lists ;12/10/90 12:21
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
OERR ;
I '$D(^DPT(DFN,"LR")) W !,"No Lab Data for: "_$P(^(0),"^") Q
S LRDFN=$$LRDFN^LR7OR1(DFN) I 'LRDFN W !,"No Lab Data for: "_$P(^DPT(DFN,0),"^") Q
S LRDPF="2^DPT(" I '$D(^LR(LRDFN,0)) W !,"No Lab Data for: "_$P(^DPT(DFN,0),"^") Q
S LRQ=1 D INI
S DIWL=5,DIWR=IOM-5,DIWF="W",C(1.7)="RBC Antibody present:",C(1)="RBC Antigen present :",C(1.5)="RBC Antigen absent :"
D S^LRU I $A(IOST)=80 S A(1)=0 D L^LRU,H
I $A(IOST)'=80 W @IOF,!,LRP," ",SSN,?46,$J(LRPABO,2),?49,LRPRH S A(1)=$Y+(IOSL-3)
D S F B=0:1 S A=$O(^LR(LRDFN,3,A)) Q:'A S X=^(A,0) D:$Y>A(1)!'$Y MORE Q:A(2)?1P D ^DIWP
D:B ^DIWW D S F C=1.7,1,1.5 Q:A(2)?1P W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,C,A)) Q:'A!(A(2)?1P) W:'B C(C) W:B ! W ?21,$P(^LAB(61.3,A,0),"^") D:$Y>A(1)!'$Y MORE Q:A(2)?1P
D S F B=1:1 S A=$O(^LR(LRDFN,1.6,A)) Q:'A!(A(2)?1P) S X=^LR(LRDFN,1.6,A,0),Y=+X D D^LRU,N Q:A(2)?1P D:$Y>A(1)!'$Y MORE Q:A(2)?1P
I B=1,A(2)'?1P W !,"No transfused units on record",!
Q
;
N W:B=1 !!?34,"TRANSFUSIONS",?64,"Transfusion",!?6,"Unit",?18,"Component",?36,"(# of units/ml )",?60,"Date/time completed"
S X(1)=$P(X,"^",2),X(7)=$P(X,"^",7),X(10)=$P(X,"^",10),M=$S(X(1):$E($P(^LAB(66,X(1),0),"^"),1,30),1:"component not entered")
W !,$J(B,3),")",?6,$P(X,"^",3),?18,$E($P(M,"^"),1,30) I X(7)!(X(10)) W ?45,"(",X(7),"/",X(10),")"
W ?54,$P(X,"^",5)_" "_$P(X,"^",6),?60,Y
F F=1,2 F E=0:0 S E=$O(^LR(LRDFN,1.6,A,F,E)) Q:'E!(A(2)?1P) W !?6,^(E,0) D:$Y>A(1)!'$Y MORE Q:A(2)?1P
Q
;
MORE G:$A(IOST)=80 H R !,"^ TO STOP: ",A(2):DTIME I A(2)?1P S A=0 Q
S A(1)=A(1)+21 W $C(13),$J("",15),$C(13) Q
S S (A,A(2))=0 Q
;
H S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU W @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
W !,"LABORATORY SERVICE"
W !,LRP," ",SSN,?46,$J(LRPABO,2),?49,LRPRH S A(1)=A(1)+(IOSL-4) Q
SET ;
D V^LRU S X="BLOOD BANK" D ^LRUTL
I Y=-1 S OREND=1 Q
I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" S OREND=1 Q
Q
CLEAN ;
K A,AGE,B,C,DFN,DOB,I,LR,LRAA,LRABV,LRAD,LRADM,LRADX,LRAWRD,LRAX,LRCAPLOC,LRDFN,LRDPAF,LRDPF,LRFNAM,LRH,LRMD,LROLLOC,LRP,LRPABO,LRPARAM,LRPF,LRPFN,LRPRH,LRQ,LRS,LRSF,LRSS,LRSVC,LRU,LRWHO,N,P,R,SEX,SSN,X,Y
Q
INI ;
K LREXP S (LRS,LRS(1),LRSVC,DOB,LRAWRD,LRMD,LRMD(1),LRADX,LRADM)="",LRPF="^"_$P(LRDPF,"^",2),LRPFN=+LRDPF,LRFNAM=$P(^DIC(LRPFN,0),"^")
S Y=@(LRPF_DFN_",0)"),LRP=$P(Y,"^"),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3),SSN=$P(Y,"^",9),LRLLOC=$S($D(^(.1)):^(.1),1:""),X=$S($D(^(.104)):+^(.104),1:"") D SSN^LRU I 'X S X=$S($D(^LR(LRDFN,.2)):+^(.2),1:"")
S:LRLLOC="" LRLLOC="OUTPATIENT"
I X,$D(^VA(200,X,0)) S LRMD=$P(^(0),"^"),LRMD(1)=X
I $D(LRSS),LRSS="BB" S X=^LR(LRDFN,0),LRPABO=$P(X,"^",5),LRPRH=$P(X,"^",6)
S LRSVC=$S($D(@(LRPF_DFN_",.103)")):^(.103),1:"") I LRSVC S LRS=$S($D(^DIC(45.7,LRSVC,0)):$P(^(0),"^"),1:"") S:LRS]"" LRS(1)=LRSVC
S (X2,Y)=DOB,AGE="" I Y>1630000 D D^LRU S DOB=Y,X1=DT D ^%DTC S AGE=X\365.25
I $D(@(LRPF_DFN_",.35)")),$P(@(LRPF_DFN_",.35)"),"^") S (LREXP,Y)=+^(.35) D D^LRU S (LRLLOC,^LR(LRDFN,.1))="DIED "_Y W $C(7),!!,?34,"",LRLLOC,"",! Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPD1 3213 printed Dec 13, 2024@02:11:48 Page 2
LRBLPD1 ;SLC/DCM - BB PT INFO for OE/RR pt lists ;12/10/90 12:21
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
OERR ;
+1 IF '$DATA(^DPT(DFN,"LR"))
WRITE !,"No Lab Data for: "_$PIECE(^(0),"^")
QUIT
+2 SET LRDFN=$$LRDFN^LR7OR1(DFN)
IF 'LRDFN
WRITE !,"No Lab Data for: "_$PIECE(^DPT(DFN,0),"^")
QUIT
+3 SET LRDPF="2^DPT("
IF '$DATA(^LR(LRDFN,0))
WRITE !,"No Lab Data for: "_$PIECE(^DPT(DFN,0),"^")
QUIT
+4 SET LRQ=1
DO INI
+5 SET DIWL=5
SET DIWR=IOM-5
SET DIWF="W"
SET C(1.7)="RBC Antibody present:"
SET C(1)="RBC Antigen present :"
SET C(1.5)="RBC Antigen absent :"
+6 DO S^LRU
IF $ASCII(IOST)=80
SET A(1)=0
DO L^LRU
DO H
+7 IF $ASCII(IOST)'=80
WRITE @IOF,!,LRP," ",SSN,?46,$JUSTIFY(LRPABO,2),?49,LRPRH
SET A(1)=$Y+(IOSL-3)
+8 DO S
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,3,A))
if 'A
QUIT
SET X=^(A,0)
if $Y>A(1)!'$Y
DO MORE
if A(2)?1P
QUIT
DO ^DIWP
+9 if B
DO ^DIWW
DO S
FOR C=1.7,1,1.5
if A(2)?1P
QUIT
WRITE !
SET A=0
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,C,A))
if 'A!(A(2)?1P)
QUIT
if 'B
WRITE C(C)
if B
WRITE !
WRITE ?21,$PIECE(^LAB(61.3,A,0),"^")
if $Y>A(1)!'$Y
DO MORE
if A(2)?1P
QUIT
+10 DO S
FOR B=1:1
SET A=$ORDER(^LR(LRDFN,1.6,A))
if 'A!(A(2)?1P)
QUIT
SET X=^LR(LRDFN,1.6,A,0)
SET Y=+X
DO D^LRU
DO N
if A(2)?1P
QUIT
if $Y>A(1)!'$Y
DO MORE
if A(2)?1P
QUIT
+11 IF B=1
IF A(2)'?1P
WRITE !,"No transfused units on record",!
+12 QUIT
+13 ;
N if B=1
WRITE !!?34,"TRANSFUSIONS",?64,"Transfusion",!?6,"Unit",?18,"Component",?36,"(# of units/ml )",?60,"Date/time completed"
+1 SET X(1)=$PIECE(X,"^",2)
SET X(7)=$PIECE(X,"^",7)
SET X(10)=$PIECE(X,"^",10)
SET M=$SELECT(X(1):$EXTRACT($PIECE(^LAB(66,X(1),0),"^"),1,30),1:"component not entered")
+2 WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(X,"^",3),?18,$EXTRACT($PIECE(M,"^"),1,30)
IF X(7)!(X(10))
WRITE ?45,"(",X(7),"/",X(10),")"
+3 WRITE ?54,$PIECE(X,"^",5)_" "_$PIECE(X,"^",6),?60,Y
+4 FOR F=1,2
FOR E=0:0
SET E=$ORDER(^LR(LRDFN,1.6,A,F,E))
if 'E!(A(2)?1P)
QUIT
WRITE !?6,^(E,0)
if $Y>A(1)!'$Y
DO MORE
if A(2)?1P
QUIT
+5 QUIT
+6 ;
MORE if $ASCII(IOST)=80
GOTO H
READ !,"^ TO STOP: ",A(2):DTIME
IF A(2)?1P
SET A=0
QUIT
+1 SET A(1)=A(1)+21
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
S SET (A,A(2))=0
QUIT
+1 ;
H SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
WRITE @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
+1 WRITE !,"LABORATORY SERVICE"
+2 WRITE !,LRP," ",SSN,?46,$JUSTIFY(LRPABO,2),?49,LRPRH
SET A(1)=A(1)+(IOSL-4)
QUIT
SET ;
+1 DO V^LRU
SET X="BLOOD BANK"
DO ^LRUTL
+2 IF Y=-1
SET OREND=1
QUIT
+3 IF LRSS'="BB"
WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"
SET OREND=1
QUIT
+4 QUIT
CLEAN ;
+1 KILL A,AGE,B,C,DFN,DOB,I,LR,LRAA,LRABV,LRAD,LRADM,LRADX,LRAWRD,LRAX,LRCAPLOC,LRDFN,LRDPAF,LRDPF,LRFNAM,LRH,LRMD,LROLLOC,LRP,LRPABO,LRPARAM,LRPF,LRPFN,LRPRH,LRQ,LRS,LRSF,LRSS,LRSVC,LRU,LRWHO,N,P,R,SEX,SSN,X,Y
+2 QUIT
INI ;
+1 KILL LREXP
SET (LRS,LRS(1),LRSVC,DOB,LRAWRD,LRMD,LRMD(1),LRADX,LRADM)=""
SET LRPF="^"_$PIECE(LRDPF,"^",2)
SET LRPFN=+LRDPF
SET LRFNAM=$PIECE(^DIC(LRPFN,0),"^")
+2 SET Y=@(LRPF_DFN_",0)")
SET LRP=$PIECE(Y,"^")
SET SEX=$PIECE(Y,"^",2)
SET DOB=$PIECE(Y,"^",3)
SET SSN=$PIECE(Y,"^",9)
SET LRLLOC=$SELECT($DATA(^(.1)):^(.1),1:"")
SET X=$SELECT($DATA(^(.104)):+^(.104),1:"")
DO SSN^LRU
IF 'X
SET X=$SELECT($DATA(^LR(LRDFN,.2)):+^(.2),1:"")
+3 if LRLLOC=""
SET LRLLOC="OUTPATIENT"
+4 IF X
IF $DATA(^VA(200,X,0))
SET LRMD=$PIECE(^(0),"^")
SET LRMD(1)=X
+5 IF $DATA(LRSS)
IF LRSS="BB"
SET X=^LR(LRDFN,0)
SET LRPABO=$PIECE(X,"^",5)
SET LRPRH=$PIECE(X,"^",6)
+6 SET LRSVC=$SELECT($DATA(@(LRPF_DFN_",.103)")):^(.103),1:"")
IF LRSVC
SET LRS=$SELECT($DATA(^DIC(45.7,LRSVC,0)):$PIECE(^(0),"^"),1:"")
if LRS]""
SET LRS(1)=LRSVC
+7 SET (X2,Y)=DOB
SET AGE=""
IF Y>1630000
DO D^LRU
SET DOB=Y
SET X1=DT
DO ^%DTC
SET AGE=X\365.25
+8 IF $DATA(@(LRPF_DFN_",.35)"))
IF $PIECE(@(LRPF_DFN_",.35)"),"^")
SET (LREXP,Y)=+^(.35)
DO D^LRU
SET (LRLLOC,^LR(LRDFN,.1))="DIED "_Y
WRITE $CHAR(7),!!,?34,"",LRLLOC,"",!
QUIT
+9 QUIT
