LRBLA ;AVAMC/REG/CYM - BB ADM DATA ;6/21/96 07:34
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;
S LRC=0,%=0 I $P($G(^LAB(69.9,1,8.1,DUZ(2),0)),U,6) W !,"Print inventory data for only one division",!,"(Donor data will be included for all divisions) " S %=2 D YN^LRU G:%<1 END
I %=1 S LRC=1,DIC=4,DIC("A")="Select DIVISION: ",DIC(0)="AEQM",DIC("S")="I +$G(^DIC(4,+Y,99))=+$$SITE^VASITE" D ^DIC K DIC S LRC(1)=+Y,LRC(2)=$P(Y,U,2)
W ! D B^LRU G:Y=-1 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
S ZTRTN="QUE^LRBLA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J),^TMP("LR",$J) D L^LRU,S^LRBLA1
S DIWF="W",DIWR=IOM-5,DIWL=5,LRB="S" D H^LRBLA1 S LR("F")=1,A=LRSDT F S A=$O(^LRE("AD",A)) Q:'A!(A>LRLDT) F C=0:0 S C=$O(^LRE("AD",A,C)) Q:'C D P
S A=LRSDT F S A=$O(^LRD(65,"A",A)) Q:'A!(A>LRLDT) F C=0:0 S C=$O(^LRD(65,"A",A,C)) Q:'C D T,R
S A=LRSDT F S A=$O(^LRD(65,"AB",A)) Q:'A!(A>LRLDT) F C=0:0 S C=$O(^LRD(65,"AB",A,C)) Q:'C D T,D
F LRB="S","H","A","D" Q:LR("Q") D:LRB'="S" H^LRBLA1 Q:LR("Q") D C
D:'LR("Q") ^LRBLA1 D END,END^LRUTL Q
C F A=0:0 S A=$O(LRA(A)) Q:'A!(LR("Q")) D W Q:LR("Q") W !,LR("%")
Q:LR("Q") D:$D(^TMP($J)) D^LRBLA2 Q
W D:$Y>(IOSL-6) H^LRBLA1 Q:LR("Q") W !,"|",LRA(A),?20,"|",$J(^TMP("LR",$J,LRB,"A",A),8),?30,"|",$J(^TMP("LR",$J,LRB,"B",A),8),?40,"|",$J(^TMP("LR",$J,LRB,"C",A),9)
W ?51,"|",$J(^TMP("LR",$J,LRB,"D",A),6),?59,"|",$J(^TMP("LR",$J,LRB,"E",A),8),?69,"|",$J(^TMP("LR",$J,LRB,"F",A),8),?79,"|" D:$O(^TMP("LR",$J,LRB,"C",A,0)) S^LRBLA2 Q
;
P S I=9999999-A,Y=^LRE(C,5,I,0),X=$P(Y,"^",2),LRB=$P(Y,"^",11),Y=$P(Y,"^",10) D A Q:LRB=""!(Y=2)
F E=0:0 S E=$O(^LRE(C,5,I,66,E)) Q:'E S Y=$P(^(E,0),U,8),F=$S($D(^LAB(66,E,0)):$P(^(0),U,26),1:"") D:F P1
Q
P1 S ^(F)=^TMP("LR",$J,"S","A",F)+1 S:Y=2 ^(F)=^TMP("LR",$J,"S","F",F)+1 S ^(F)=^TMP("LR",$J,LRB,"A",F)+1 S:Y=2 ^(F)=^TMP("LR",$J,LRB,"F",F)+1
Q
R I '$D(^LRD(65,C,0)) K ^LRD(65,"A",A,C) Q
I LRC Q:$P(^LRD(65,C,0),"^",16)'=LRC(1)
S X=^LRD(65,C,0),E=+$P(X,"^",4),Y=$P(X,"^",2),F=$S($D(^LAB(66,E,0)):$P(^(0),"^",26),1:"") Q:'F
I "2346"[F,Y["SELF" S LRG=1 D CK I LRG S ^(F)=^TMP("LR",$J,"S","A",F)+1,^(F)=^TMP("LR",$J,LRB,"A",F)+1 Q
Q:Y["SELF" S ^(F)=^TMP("LR",$J,"S","B",F)+1,^(F)=^TMP("LR",$J,LRB,"B",F)+1 Q
CK S D=$P(X,"^"),LRP=$O(^LRE("C",D,0)) Q:'LRP S I=$O(^LRE("C",D,LRP,0)) Q:'I F G=0:0 S G=$O(^LRE(LRP,5,I,66,G)) Q:'G I E=G S LRG=0 Q
Q
D I '$D(^LRD(65,C,0)) K ^LRD(65,"AB",A,C) Q
I LRC Q:$P(^LRD(65,C,0),"^",16)'=LRC(1)
S E=+$P(^LRD(65,C,0),"^",4),F=$S($D(^LAB(66,E,0)):$P(^(0),"^",26),1:"") I F S Y=$S($D(^LRD(65,C,4)):$P(^(4),"^"),1:"") D:Y]"" D1
Q
D1 I Y="T" S B=$P($G(^LRD(65,C,6)),"^",8),X=1 D:$O(^LRD(65,C,9,0)) ^LRBLAB S ^(F)=^TMP("LR",$J,"S","C",F)+X,^(F)=^TMP("LR",$J,LRB,"C",F)+X D:B R^LRBLA2 Q
S LRT=$P(^LRD(65,C,0),"^",6),LRT(2)=$P(^(4),"^",2) I LRT'["."!(LRT(2)'[".") S LRT=$P(LRT,"."),LRT(2)=$P(LRT(2),".")
I LRT<LRT(2) S ^(F)=^TMP("LR",$J,"S","E",F)+1,^(F)=^TMP("LR",$J,LRB,"E",F)+1 Q
I "RS"[Y S ^(F)=^TMP("LR",$J,"S","D",F)+1,^(F)=^TMP("LR",$J,LRB,"D",F)+1 Q
I Y="D" S ^(F)=^TMP("LR",$J,"S","F",F)+1,^(F)=^TMP("LR",$J,LRB,"F",F)+1 Q
Q
T S LRB=$S($D(^LRD(65,C,8)):$P(^(8),"^",3),1:"H") S:LRB="" LRB="H" Q
;
A I X="N" S ^(X)=^TMP("LR",$J,X)+1 D A1 Q
I X]"",LRB]"" S Z=X_LRB,^(Z)=^TMP("LR",$J,Z)+1 S:Y=2 ^("D")=^TMP("LR",$J,Z,"D")+1 D B
Q
A1 I $P(^LRE(C,0),"^",10) S Y=$P(^(0),"^"),^("P")=^TMP("LR",$J,"N","P")+1,^TMP("LR",$J,"N","P",Y,C,I)=""
S ^("T")=^TMP("LR",$J,"N","T")+1 F E=0:0 S E=$O(^LRE(C,5,I,1,E)) Q:'E S D=+^(E,0) S:'$D(^TMP("LR",$J,"N","T",D)) ^(D)=0 S ^(D)=^(D)+1
Q
B S Z=X_LRB,B=0 F E=12:1:20 I $P($G(^LRE(C,5,I,E)),"^") S B=B+1,^(Z)=^TMP("LR",$J,"Y",E,Z)+1
S:B>1 ^(Z)=^TMP("LR",$J,"Y",Z)+1 Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLA 3809 printed Apr 09, 2024@21:11:52 Page 2
LRBLA ;AVAMC/REG/CYM - BB ADM DATA ;6/21/96 07:34
+1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;
+4 SET LRC=0
SET %=0
IF $PIECE($GET(^LAB(69.9,1,8.1,DUZ(2),0)),U,6)
WRITE !,"Print inventory data for only one division",!,"(Donor data will be included for all divisions) "
SET %=2
DO YN^LRU
if %<1
GOTO END
+5 IF %=1
SET LRC=1
SET DIC=4
SET DIC("A")="Select DIVISION: "
SET DIC(0)="AEQM"
SET DIC("S")="I +$G(^DIC(4,+Y,99))=+$$SITE^VASITE"
DO ^DIC
KILL DIC
SET LRC(1)=+Y
SET LRC(2)=$PIECE(Y,U,2)
+6 WRITE !
DO B^LRU
if Y=-1
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+7 SET ZTRTN="QUE^LRBLA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB),^TMP("LR",$JOB)
DO L^LRU
DO S^LRBLA1
+1 SET DIWF="W"
SET DIWR=IOM-5
SET DIWL=5
SET LRB="S"
DO H^LRBLA1
SET LR("F")=1
SET A=LRSDT
FOR
SET A=$ORDER(^LRE("AD",A))
if 'A!(A>LRLDT)
QUIT
FOR C=0:0
SET C=$ORDER(^LRE("AD",A,C))
if 'C
QUIT
DO P
+2 SET A=LRSDT
FOR
SET A=$ORDER(^LRD(65,"A",A))
if 'A!(A>LRLDT)
QUIT
FOR C=0:0
SET C=$ORDER(^LRD(65,"A",A,C))
if 'C
QUIT
DO T
DO R
+3 SET A=LRSDT
FOR
SET A=$ORDER(^LRD(65,"AB",A))
if 'A!(A>LRLDT)
QUIT
FOR C=0:0
SET C=$ORDER(^LRD(65,"AB",A,C))
if 'C
QUIT
DO T
DO D
+4 FOR LRB="S","H","A","D"
if LR("Q")
QUIT
if LRB'="S"
DO H^LRBLA1
if LR("Q")
QUIT
DO C
+5 if 'LR("Q")
DO ^LRBLA1
DO END
DO END^LRUTL
QUIT
C FOR A=0:0
SET A=$ORDER(LRA(A))
if 'A!(LR("Q"))
QUIT
DO W
if LR("Q")
QUIT
WRITE !,LR("%")
+1 if LR("Q")
QUIT
if $DATA(^TMP($JOB))
DO D^LRBLA2
QUIT
W if $Y>(IOSL-6)
DO H^LRBLA1
if LR("Q")
QUIT
WRITE !,"|",LRA(A),?20,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"A",A),8),?30,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"B",A),8),?40,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"C",A),9)
+1 WRITE ?51,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"D",A),6),?59,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"E",A),8),?69,"|",$JUSTIFY(^TMP("LR",$JOB,LRB,"F",A),8),?79,"|"
if $ORDER(^TMP("LR",$JOB,LRB,"C",A,0))
DO S^LRBLA2
QUIT
+2 ;
P SET I=9999999-A
SET Y=^LRE(C,5,I,0)
SET X=$PIECE(Y,"^",2)
SET LRB=$PIECE(Y,"^",11)
SET Y=$PIECE(Y,"^",10)
DO A
if LRB=""!(Y=2)
QUIT
+1 FOR E=0:0
SET E=$ORDER(^LRE(C,5,I,66,E))
if 'E
QUIT
SET Y=$PIECE(^(E,0),U,8)
SET F=$SELECT($DATA(^LAB(66,E,0)):$PIECE(^(0),U,26),1:"")
if F
DO P1
+2 QUIT
P1 SET ^(F)=^TMP("LR",$JOB,"S","A",F)+1
if Y=2
SET ^(F)=^TMP("LR",$JOB,"S","F",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"A",F)+1
if Y=2
SET ^(F)=^TMP("LR",$JOB,LRB,"F",F)+1
+1 QUIT
R IF '$DATA(^LRD(65,C,0))
KILL ^LRD(65,"A",A,C)
QUIT
+1 IF LRC
if $PIECE(^LRD(65,C,0),"^",16)'=LRC(1)
QUIT
+2 SET X=^LRD(65,C,0)
SET E=+$PIECE(X,"^",4)
SET Y=$PIECE(X,"^",2)
SET F=$SELECT($DATA(^LAB(66,E,0)):$PIECE(^(0),"^",26),1:"")
if 'F
QUIT
+3 IF "2346"[F
IF Y["SELF"
SET LRG=1
DO CK
IF LRG
SET ^(F)=^TMP("LR",$JOB,"S","A",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"A",F)+1
QUIT
+4 if Y["SELF"
QUIT
SET ^(F)=^TMP("LR",$JOB,"S","B",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"B",F)+1
QUIT
CK SET D=$PIECE(X,"^")
SET LRP=$ORDER(^LRE("C",D,0))
if 'LRP
QUIT
SET I=$ORDER(^LRE("C",D,LRP,0))
if 'I
QUIT
FOR G=0:0
SET G=$ORDER(^LRE(LRP,5,I,66,G))
if 'G
QUIT
IF E=G
SET LRG=0
QUIT
+1 QUIT
D IF '$DATA(^LRD(65,C,0))
KILL ^LRD(65,"AB",A,C)
QUIT
+1 IF LRC
if $PIECE(^LRD(65,C,0),"^",16)'=LRC(1)
QUIT
+2 SET E=+$PIECE(^LRD(65,C,0),"^",4)
SET F=$SELECT($DATA(^LAB(66,E,0)):$PIECE(^(0),"^",26),1:"")
IF F
SET Y=$SELECT($DATA(^LRD(65,C,4)):$PIECE(^(4),"^"),1:"")
if Y]""
DO D1
+3 QUIT
D1 IF Y="T"
SET B=$PIECE($GET(^LRD(65,C,6)),"^",8)
SET X=1
if $ORDER(^LRD(65,C,9,0))
DO ^LRBLAB
SET ^(F)=^TMP("LR",$JOB,"S","C",F)+X
SET ^(F)=^TMP("LR",$JOB,LRB,"C",F)+X
if B
DO R^LRBLA2
QUIT
+1 SET LRT=$PIECE(^LRD(65,C,0),"^",6)
SET LRT(2)=$PIECE(^(4),"^",2)
IF LRT'["."!(LRT(2)'[".")
SET LRT=$PIECE(LRT,".")
SET LRT(2)=$PIECE(LRT(2),".")
+2 IF LRT<LRT(2)
SET ^(F)=^TMP("LR",$JOB,"S","E",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"E",F)+1
QUIT
+3 IF "RS"[Y
SET ^(F)=^TMP("LR",$JOB,"S","D",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"D",F)+1
QUIT
+4 IF Y="D"
SET ^(F)=^TMP("LR",$JOB,"S","F",F)+1
SET ^(F)=^TMP("LR",$JOB,LRB,"F",F)+1
QUIT
+5 QUIT
T SET LRB=$SELECT($DATA(^LRD(65,C,8)):$PIECE(^(8),"^",3),1:"H")
if LRB=""
SET LRB="H"
QUIT
+1 ;
A IF X="N"
SET ^(X)=^TMP("LR",$JOB,X)+1
DO A1
QUIT
+1 IF X]""
IF LRB]""
SET Z=X_LRB
SET ^(Z)=^TMP("LR",$JOB,Z)+1
if Y=2
SET ^("D")=^TMP("LR",$JOB,Z,"D")+1
DO B
+2 QUIT
A1 IF $PIECE(^LRE(C,0),"^",10)
SET Y=$PIECE(^(0),"^")
SET ^("P")=^TMP("LR",$JOB,"N","P")+1
SET ^TMP("LR",$JOB,"N","P",Y,C,I)=""
+1 SET ^("T")=^TMP("LR",$JOB,"N","T")+1
FOR E=0:0
SET E=$ORDER(^LRE(C,5,I,1,E))
if 'E
QUIT
SET D=+^(E,0)
if '$DATA(^TMP("LR",$JOB,"N","T",D))
SET ^(D)=0
SET ^(D)=^(D)+1
+2 QUIT
B SET Z=X_LRB
SET B=0
FOR E=12:1:20
IF $PIECE($GET(^LRE(C,5,I,E)),"^")
SET B=B+1
SET ^(Z)=^TMP("LR",$JOB,"Y",E,Z)+1
+1 if B>1
SET ^(Z)=^TMP("LR",$JOB,"Y",Z)+1
QUIT
+2 ;
END DO V^LRU
QUIT
