- LRBLA ; IHS/DIR/AAB - BB ADM DATA 07:34 ; [ 6/21/96 ]
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- ;
- 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
- LRBLA ; IHS/DIR/AAB - BB ADM DATA 07:34 ; [ 6/21/96 ]
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +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
