- 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 Feb 18, 2025@23:37:41 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