- LRBLJU1 ; IHS/DIR/AAB - FIND UNITS NO DISPOSITION 08:34 ; [ 5/17/96 ]
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- S (LRK,T(1),LRF)=0
- F C=0:0 S C=$O(^TMP($J,C)) Q:'C!(LR("Q")) S LRF=LRF+1,C(1)=$S($D(^LAB(66,C,0)):$P(^(0),"^"),1:C) D H Q:LR("Q") S LR("F")=1 D A
- I 'LRF D F^LRU W !,"Transfusion Service - Units ",$S(LROPT="EN1":"in & out date without final disposition",1:"available"),!,LR("%"),!,"There are no units ",$S(LROPT="":"available.",1:"without a final disposition.")
- Q
- A S A=0 F A(1)=0:0 S A=$O(^TMP($J,C,A)) Q:A=""!(LR("Q")) D B
- Q:LR("Q") W !,C(1)," Total units: ",T(1) S T(1)=0 Q
- B S R=0 F A(2)=0:0 S R=$O(^TMP($J,C,A,R)) Q:R=""!(LR("Q")) W ! D C
- Q
- C S E=0,T(2)=0 F A(3)=0:0 S E=$O(^TMP($J,C,A,R,E)) Q:E=""!(LR("Q")) S Y=E D D^LRU S C(6)=Y D D
- Q:LR("Q") W !?4,"Total ",A," ",R," units: ",T(2) Q
- D S I=0 F A(4)=0:0 S I=$O(^TMP($J,C,A,R,E,I)) Q:I=""!(LR("Q")) S W=^(I),I(1)=+W D:$Y>(IOSL-6) H Q:LR("Q") W !,A,?3,R,?7,I,?20,C(6),?40,$E($P(W,"^",2),1,8) D E
- Q
- E S C(2)=0,T(1)=T(1)+1,T(2)=T(2)+1,X=$S($D(^LRD(65,I(1),8)):$P(^(8),"^",3),1:""),LRJ=$S(X="":0,X="A":1,X="D":1,1:0)
- S P=0 F P(1)=0:1 S P=$O(^LRD(65,I(1),2,P)) Q:'P!(LR("Q")) D F
- I 'P(1)&LRJ!(LRJ&LRK) S P=+^LRD(65,I(1),8) W ?49,"*" I P D P W $E($P(Y,"^"),1,17)
- Q
- F S LRK=0 I '$P(^LRD(65,I(1),2,P,0),"^",2) S LRK=1 Q
- S C(2)=C(2)+1 W:C(2)>1 ! Q:'$D(^LR(P,0)) D P
- W:LRJ ?49,"*" W ?50,$E($P(Y,"^"),1,17) S LRI=$O(^LRD(65,I(1),2,P,1,0)) Q:'LRI S I(2)=+^(LRI,0),I(3)=$P(I(2),".",2),I(3)=I(3)_"0000",I(3)=$E(I(3),1,4) W ?68,$E(I(2),4,5)_"/"_$E(I(2),6,7) W:I(3) ?74,$E(I(3),1,2)_":"_$E(I(3),3,4) Q
- ;
- P S X=^LR(P,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)") Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"Transfusion Service ",LRAA(4),!,"Units of ",C(1),$S(LROPT["EN1":" in & out date ",1:" available")," (no disposition)"
- W !?49,"*Autologous/Directed",!,"ABO",?4,"Rh",?7,"ID",?20,"Expiration Date",?40,"Location",?51,"Patient Assigned",?69,"Spec Date",!,LR("%") Q
- LRBLJU1 ; IHS/DIR/AAB - FIND UNITS NO DISPOSITION 08:34 ; [ 5/17/96 ]
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 SET (LRK,T(1),LRF)=0
- +4 FOR C=0:0
- SET C=$ORDER(^TMP($JOB,C))
- IF 'C!(LR("Q"))
- QUIT
- SET LRF=LRF+1
- SET C(1)=$SELECT($DATA(^LAB(66,C,0)):$PIECE(^(0),"^"),1:C)
- DO H
- IF LR("Q")
- QUIT
- SET LR("F")=1
- DO A
- +5 IF 'LRF
- DO F^LRU
- WRITE !,"Transfusion Service - Units ",$SELECT(LROPT="EN1":"in & out date without final disposition",1:"available"),!,LR("%"),!,"There are no units ",$SELECT(LROPT="":"available.",1:"without a final disposition.")
- +6 QUIT
- A SET A=0
- FOR A(1)=0:0
- SET A=$ORDER(^TMP($JOB,C,A))
- IF A=""!(LR("Q"))
- QUIT
- DO B
- +1 IF LR("Q")
- QUIT
- WRITE !,C(1)," Total units: ",T(1)
- SET T(1)=0
- QUIT
- B SET R=0
- FOR A(2)=0:0
- SET R=$ORDER(^TMP($JOB,C,A,R))
- IF R=""!(LR("Q"))
- QUIT
- WRITE !
- DO C
- +1 QUIT
- C SET E=0
- SET T(2)=0
- FOR A(3)=0:0
- SET E=$ORDER(^TMP($JOB,C,A,R,E))
- IF E=""!(LR("Q"))
- QUIT
- SET Y=E
- DO D^LRU
- SET C(6)=Y
- DO D
- +1 IF LR("Q")
- QUIT
- WRITE !?4,"Total ",A," ",R," units: ",T(2)
- QUIT
- D SET I=0
- FOR A(4)=0:0
- SET I=$ORDER(^TMP($JOB,C,A,R,E,I))
- IF I=""!(LR("Q"))
- QUIT
- SET W=^(I)
- SET I(1)=+W
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !,A,?3,R,?7,I,?20,C(6),?40,$EXTRACT($PIECE(W,"^",2),1,8)
- DO E
- +1 QUIT
- E SET C(2)=0
- SET T(1)=T(1)+1
- SET T(2)=T(2)+1
- SET X=$SELECT($DATA(^LRD(65,I(1),8)):$PIECE(^(8),"^",3),1:"")
- SET LRJ=$SELECT(X="":0,X="A":1,X="D":1,1:0)
- +1 SET P=0
- FOR P(1)=0:1
- SET P=$ORDER(^LRD(65,I(1),2,P))
- IF 'P!(LR("Q"))
- QUIT
- DO F
- +2 IF 'P(1)&LRJ!(LRJ&LRK)
- SET P=+^LRD(65,I(1),8)
- WRITE ?49,"*"
- IF P
- DO P
- WRITE $EXTRACT($PIECE(Y,"^"),1,17)
- +3 QUIT
- F SET LRK=0
- IF '$PIECE(^LRD(65,I(1),2,P,0),"^",2)
- SET LRK=1
- QUIT
- +1 SET C(2)=C(2)+1
- IF C(2)>1
- WRITE !
- IF '$DATA(^LR(P,0))
- QUIT
- DO P
- +2 IF LRJ
- WRITE ?49,"*"
- WRITE ?50,$EXTRACT($PIECE(Y,"^"),1,17)
- SET LRI=$ORDER(^LRD(65,I(1),2,P,1,0))
- IF 'LRI
- QUIT
- SET I(2)=+^(LRI,0)
- SET I(3)=$PIECE(I(2),".",2)
- SET I(3)=I(3)_"0000"
- SET I(3)=$EXTRACT(I(3),1,4)
- WRITE ?68,$EXTRACT(I(2),4,5)_"/"_$EXTRACT(I(2),6,7)
- IF I(3)
- WRITE ?74,$EXTRACT(I(3),1,2)_":"_$EXTRACT(I(3),3,4)
- QUIT
- +3 ;
- P SET X=^LR(P,0)
- SET Y=$PIECE(X,"^",3)
- SET X=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET Y=@(X_Y_",0)")
- QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"Transfusion Service ",LRAA(4),!,"Units of ",C(1),$SELECT(LROPT["EN1":" in & out date ",1:" available")," (no disposition)"
- +2 WRITE !?49,"*Autologous/Directed",!,"ABO",?4,"Rh",?7,"ID",?20,"Expiration Date",?40,"Location",?51,"Patient Assigned",?69,"Spec Date",!,LR("%")
- QUIT
