- LRBLJU ; IHS/DIR/AAB - FIND UNITS NO DISPOSITION 10/6/95 10:10 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- S %DT="T",X="N" D ^%DT S N=Y,E(1)=$S($D(E(1)):E(1),1:DT-.0001) S:'$D(LROPT) LROPT=""
- S IOP="HOME" D ^%ZIS W !!?20,$S($D(A)#2:A,1:""),!!
- ASK R !,"Select: (A)ll blood components or (S)pecific component: ",S:DTIME G:S=""!(S[U) END G:S?1"A".E T I S'?1"S" W !!,"Enter A to list all components or S for a specific component",! G ASK
- S DIC=66,DIC(0)="AEQMZ",DIC("A")="Select BLOOD COMPONENT: ",DIC("S")="I $P(^(0),U,4)=""BB""" D ^DIC K DIC G:X=""!(X[U) END S C=+Y,C(1)=$P(Y(0),"^",3)
- T R !,"Select: (A)ll units or (S)pecific ABO/Rh: ",X:DTIME G:X=""!(X[U) END G DEV:X?1"A".E I X'?1"S".E W !!,"Select A for all units or S for specific T & Rh",! G T
- AB R !,"ABO GROUP: ",X:DTIME G:X=""!(X[U) END S T=$S(X="A":"A",X="O":"O",X="B":"B",X="AB":"AB",1:"") I T="" W $C(7),!!,"Enter A, O, B, or AB",! G AB
- R R !,"Rh TYPE: ",X:DTIME G:X=""!(X[U) END S R=$S(X?1"P".E:"POS",X?1"N".E:"NEG",1:"") I R="" W $C(7),!!,"Enter P or N",! G R
- DEV S ZTRTN="QUE^LRBLJU" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) D L^LRU,S^LRU
- G:S?1"A".E ALL
- L S E=E(1) F E=E:0 S E=$O(^LRD(65,"AE",C,E)) Q:'E D I
- Q:S?1"A".E
- OUT D ^LRBLJU1 W:IOST'?1"C".E @IOF K ^TMP($J) D END^LRUTL,END Q
- I I LROPT="" Q:E<N&(E[".") I E'[".",E<$P(N,".") Q
- F I=0:0 S I=$O(^LRD(65,"AE",C,E,I)) Q:'I D S
- Q
- S Q:'$D(^LRD(65,I,0)) I $D(^(4)),$P(^(4),"^")]"" K ^LRD(65,"AE",C,E,I) Q
- S W=^LRD(65,I,0) Q:$P(W,"^",16)'=DUZ(2)
- S LRB=$P(W,"^",7),R(1)=$S($P(W,"^",8)]"":$P(W,"^",8),1:"?"),LRLLOC=$O(^LRD(65,I,3,0)),LRLLOC=$S(LRLLOC="":"Bld Bank",1:$P(^(LRLLOC,0),"^",4))
- I $D(T)#2,$D(R) Q:T'=LRB!(R'=R(1))
- S ^TMP($J,C,LRB,R(1),$P(W,"^",6),$P(W,"^"))=I_"^"_LRLLOC Q
- ALL F C=0:0 S C=$O(^LRD(65,"AE",C)) Q:'C D L
- G OUT
- EN D END,SET G:Y=-1 END S LROPT="" G LRBLJU
- EN1 D END,SET G:Y=-1 END S E(1)=0,LROPT="EN1" G LRBLJU
- ;
- SET S X="BLOOD BANK" D ^LRUTL Q
- ;
- END D V^LRU Q
- LRBLJU ; IHS/DIR/AAB - FIND UNITS NO DISPOSITION 10/6/95 10:10 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 SET %DT="T"
- SET X="N"
- DO ^%DT
- SET N=Y
- SET E(1)=$SELECT($DATA(E(1)):E(1),1:DT-.0001)
- IF '$DATA(LROPT)
- SET LROPT=""
- +4 SET IOP="HOME"
- DO ^%ZIS
- WRITE !!?20,$SELECT($DATA(A)#2:A,1:""),!!
- ASK READ !,"Select: (A)ll blood components or (S)pecific component: ",S:DTIME
- IF S=""!(S[U)
- GOTO END
- IF S?1"A".E
- GOTO T
- IF S'?1"S"
- WRITE !!,"Enter A to list all components or S for a specific component",!
- GOTO ASK
- +1 SET DIC=66
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select BLOOD COMPONENT: "
- SET DIC("S")="I $P(^(0),U,4)=""BB"""
- DO ^DIC
- KILL DIC
- IF X=""!(X[U)
- GOTO END
- SET C=+Y
- SET C(1)=$PIECE(Y(0),"^",3)
- T READ !,"Select: (A)ll units or (S)pecific ABO/Rh: ",X:DTIME
- IF X=""!(X[U)
- GOTO END
- IF X?1"A".E
- GOTO DEV
- IF X'?1"S".E
- WRITE !!,"Select A for all units or S for specific T & Rh",!
- GOTO T
- AB READ !,"ABO GROUP: ",X:DTIME
- IF X=""!(X[U)
- GOTO END
- SET T=$SELECT(X="A":"A",X="O":"O",X="B":"B",X="AB":"AB",1:"")
- IF T=""
- WRITE $CHAR(7),!!,"Enter A, O, B, or AB",!
- GOTO AB
- R READ !,"Rh TYPE: ",X:DTIME
- IF X=""!(X[U)
- GOTO END
- SET R=$SELECT(X?1"P".E:"POS",X?1"N".E:"NEG",1:"")
- IF R=""
- WRITE $CHAR(7),!!,"Enter P or N",!
- GOTO R
- DEV SET ZTRTN="QUE^LRBLJU"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- DO L^LRU
- DO S^LRU
- +1 IF S?1"A".E
- GOTO ALL
- L SET E=E(1)
- FOR E=E:0
- SET E=$ORDER(^LRD(65,"AE",C,E))
- IF 'E
- QUIT
- DO I
- +1 IF S?1"A".E
- QUIT
- OUT DO ^LRBLJU1
- IF IOST'?1"C".E
- WRITE @IOF
- KILL ^TMP($JOB)
- DO END^LRUTL
- DO END
- QUIT
- I IF LROPT=""
- IF E<N&(E[".")
- QUIT
- IF E'["."
- IF E<$PIECE(N,".")
- QUIT
- +1 FOR I=0:0
- SET I=$ORDER(^LRD(65,"AE",C,E,I))
- IF 'I
- QUIT
- DO S
- +2 QUIT
- S IF '$DATA(^LRD(65,I,0))
- QUIT
- IF $DATA(^(4))
- IF $PIECE(^(4),"^")]""
- KILL ^LRD(65,"AE",C,E,I)
- QUIT
- +1 SET W=^LRD(65,I,0)
- IF $PIECE(W,"^",16)'=DUZ(2)
- QUIT
- +2 SET LRB=$PIECE(W,"^",7)
- SET R(1)=$SELECT($PIECE(W,"^",8)]"":$PIECE(W,"^",8),1:"?")
- SET LRLLOC=$ORDER(^LRD(65,I,3,0))
- SET LRLLOC=$SELECT(LRLLOC="":"Bld Bank",1:$PIECE(^(LRLLOC,0),"^",4))
- +3 IF $DATA(T)#2
- IF $DATA(R)
- IF T'=LRB!(R'=R(1))
- QUIT
- +4 SET ^TMP($JOB,C,LRB,R(1),$PIECE(W,"^",6),$PIECE(W,"^"))=I_"^"_LRLLOC
- QUIT
- ALL FOR C=0:0
- SET C=$ORDER(^LRD(65,"AE",C))
- IF 'C
- QUIT
- DO L
- +1 GOTO OUT
- EN DO END
- DO SET
- IF Y=-1
- GOTO END
- SET LROPT=""
- GOTO LRBLJU
- EN1 DO END
- DO SET
- IF Y=-1
- GOTO END
- SET E(1)=0
- SET LROPT="EN1"
- GOTO LRBLJU
- +1 ;
- SET SET X="BLOOD BANK"
- DO ^LRUTL
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
