LRBLQPR ;AVAMC/REG - PRINT UNITS/COMPONENTS ;2/18/93 09:48 ;
;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
P W ! K DIC D ^LRDPA K DIC,DIE,DR W ! G:LRDFN=-1 END
W !,"Is this the patient " S %=1 D YN^LRU G:%'=1 P
S ZTRTN="QUE^LRBLQPR" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D S^LRU I $A(IOST)=80 S A(1)=0 D L^LRU,H
I $A(IOST)'=80 W @IOF,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH
D S S A(1)=(IOSL-3) F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A D N
I B=1 W !,"No UNITS assigned/xmatched",!
G:A(2)?1P END W ! D S F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A S X=^(A,0) W:'B !,"Component Requests",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By" D L
I 'B W "No component requests",!
D END^LRUTL,END Q
;
N W:B=1 !?6,"Unit assigned/xmatched:",?50,"Exp date",?69,"Loc"
I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
D:$Y>A(1) R Q:A(2)?1P S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
S M=^LAB(66,$P(X,"^",4),0) W !,$J(B,2),")",?6,$P(X,"^"),?21,$E($P(M,"^"),1,19),?42,$P(X,"^",7)_" "_$P(X,"^",8),?49 S Y=$P(X,"^",6) D D^LRU S:L<0 L="Blood bank" W Y,?69,$E(L,1,11)
S C=$O(^LRD(65,A,2,LRDFN,1,0)) I C F E=0:0 S E=$O(^LRD(65,A,2,LRDFN,1,C,3,E)) Q:'E D:$Y>A(1) R Q:A(2)?1P W !?2,^(E,0)
Q
;
L D:$Y>A(1) R Q:A(2)?1P
W !,$E($P(^LAB(66,+X,0),"^"),1,27),?27,$J($P(X,"^",4),3),?33 S Y=$P(X,"^",3) D M W Y,?47 S Y=$P(X,"^",5) D M W Y,?59,$P(X,"^",9),?77,$S($P(X,"^",8)="":"",$D(^VA(200,$P(X,"^",8),0)):$P(^(0),"^",2),1:$P(X,"^",8)) Q
M S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y'[".":"",1:" "_$E(Y,9,12)) Q
D END^LRUTL,END Q
;
R G:$A(IOST)=80 H S A(1)=A(1)+21 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 D F^LRU W !,"LABORATORY SERVICE",!,LR("%")
W !,LRP," ",SSN(1),?37,$J(LRPABO,2),?40,LRPRH S A(1)=A(1)+(IOSL-4) Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLQPR 2023 printed Jan 18, 2025@03:12:52 Page 2
LRBLQPR ;AVAMC/REG - PRINT UNITS/COMPONENTS ;2/18/93 09:48 ;
+1 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 DO END
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
P WRITE !
KILL DIC
DO ^LRDPA
KILL DIC,DIE,DR
WRITE !
if LRDFN=-1
GOTO END
+1 WRITE !,"Is this the patient "
SET %=1
DO YN^LRU
if %'=1
GOTO P
+2 SET ZTRTN="QUE^LRBLQPR"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO S^LRU
IF $ASCII(IOST)=80
SET A(1)=0
DO L^LRU
DO H
+1 IF $ASCII(IOST)'=80
WRITE @IOF,LRP," ",SSN(1),?37,$JUSTIFY(LRPABO,2),?40,LRPRH
+2 DO S
SET A(1)=(IOSL-3)
FOR B=1:1
SET A=$ORDER(^LRD(65,"AP",LRDFN,A))
if 'A
QUIT
DO N
+3 IF B=1
WRITE !,"No UNITS assigned/xmatched",!
+4 if A(2)?1P
GOTO END
WRITE !
DO S
FOR B=0:1
SET A=$ORDER(^LR(LRDFN,1.8,A))
if 'A
QUIT
SET X=^(A,0)
if 'B
WRITE !,"Component Requests",?27,"Units",?33,"Request date",?47,"Date wanted",?59,"Requestor",?77,"By"
DO L
+5 IF 'B
WRITE "No component requests",!
+6 DO END^LRUTL
DO END
QUIT
+7 ;
N if B=1
WRITE !?6,"Unit assigned/xmatched:",?50,"Exp date",?69,"Loc"
+1 IF '$DATA(^LRD(65,A,0))
KILL ^LRD(65,"AP",LRDFN,A)
QUIT
+2 if $Y>A(1)
DO R
if A(2)?1P
QUIT
SET X=^LRD(65,A,0)
SET L=$ORDER(^(3,0))
if 'L
SET L="Blood Bank"
IF L
SET L=$PIECE(^(L,0),"^",4)
+3 SET M=^LAB(66,$PIECE(X,"^",4),0)
WRITE !,$JUSTIFY(B,2),")",?6,$PIECE(X,"^"),?21,$EXTRACT($PIECE(M,"^"),1,19),?42,$PIECE(X,"^",7)_" "_$PIECE(X,"^",8),?49
SET Y=$PIECE(X,"^",6)
DO D^LRU
if L<0
SET L="Blood bank"
WRITE Y,?69,$EXTRACT(L,1,11)
+4 SET C=$ORDER(^LRD(65,A,2,LRDFN,1,0))
IF C
FOR E=0:0
SET E=$ORDER(^LRD(65,A,2,LRDFN,1,C,3,E))
if 'E
QUIT
if $Y>A(1)
DO R
if A(2)?1P
QUIT
WRITE !?2,^(E,0)
+5 QUIT
+6 ;
L if $Y>A(1)
DO R
if A(2)?1P
QUIT
+1 WRITE !,$EXTRACT($PIECE(^LAB(66,+X,0),"^"),1,27),?27,$JUSTIFY($PIECE(X,"^",4),3),?33
SET Y=$PIECE(X,"^",3)
DO M
WRITE Y,?47
SET Y=$PIECE(X,"^",5)
DO M
WRITE Y,?59,$PIECE(X,"^",9),?77,$SELECT($PIECE(X,"^",8)="":"",$DATA(^VA(200,$PIECE(X,"^",8),0)):$PIECE(^(0),"^",2),1:$PIECE(X,"^",8))
QUIT
M SET Y=Y_"000"
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_$SELECT(Y'[".":"",1:" "_$EXTRACT(Y,9,12))
QUIT
+1 DO END^LRUTL
DO END
QUIT
+2 ;
R if $ASCII(IOST)=80
GOTO H
SET A(1)=A(1)+21
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 DO F^LRU
WRITE !,"LABORATORY SERVICE",!,LR("%")
+1 WRITE !,LRP," ",SSN(1),?37,$JUSTIFY(LRPABO,2),?40,LRPRH
SET A(1)=A(1)+(IOSL-4)
QUIT
+2 ;
END DO V^LRU
QUIT
