LRBLJPA1 ; IHS/DIR/AAB - UNIT FINAL DISPOSITION 02/11/98 09:24 ; [ 07/07/1998 12:41 PM ]
;;5.2;LR;**1002,1006**;SEP 01, 1998
;
;;5.2;LAB SERVICE;**72,203**;Sep 27, 1994
D FIELD^DID(65,4.1,"","POINTER","LRD") S LRD=LRD("POINTER")
D FIELD^DID(65.02,.04,"","POINTER","LRT") S LRT=LRT("POINTER")
D FIELD^DID(65.03,.02,"","POINTER","LRTINS") S LRTINS=LRTINS("POINTER")
D FIELD^DID(65,10,"","POINTER","LRTABO") S LRTABO=LRTABO("POINTER")
D FIELD^DID(65,11,"","POINTER","LRTRH") S LRTRH=LRTRH("POINTER")
D FIELD^DID(65,8.1,"","POINTER","LRE") S LRE=LRE("POINTER")
D FIELD^DID(65,8.1,"","POINTER","LRF") S LRF=LRF("POINTER")
S (LRQ,LRID)=0 D H
S LR("F")=1 F A=1:1 S LRID=$O(^LRO(69.2,LRAA,8,65,1,"B",LRID)) Q:LRID=""!(LR("Q")) F LRI=0:0 S LRI=$O(^LRO(69.2,LRAA,8,65,1,"B",LRID,LRI)) Q:'LRI!(LR("Q")) D R
Q
R D:$Y>(IOSL-7) H Q:LR("Q") S X=^LRD(65,LRI,0),Y=$P($G(^(1)),"^"),Z=+$P(X,"^",4),LRP=$P(X,"^"),LRC=$S($D(^LAB(66,Z,0)):$P(^(0),"^"),1:Z) W !!,LRP,?14,LRC,?55,$P(X,"^",3),?66,$P(X,"^",2)
I Y]"" W !?14,"(Bag Lot #: ",Y,")"
S Y=$P(X,"^",5) D Y W !,Y W ?18,$P(X,"^",7),?20,$P(X,"^",8) S Y=$P(X,"^",6) D Y W ?24,Y,?37 S Y=$P(X,"^",9) W $S('Y:Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:""),?65,$J($P(X,"^",10),7,2),?73,$P(X,"^",11)
S Y=$P(X,"^",12) W:Y !,"Typing charge: ",$J($P(X,"^",12),6,2) S Z=$P(X,"^",13) I Z]"" W:'Y ! W " Shipping invoice:",Z
S X=$P(X,"^",14) I X]"" W:'Y&(Z="") ! W " Return credit: ",X
D H4 Q:LR("Q") S X=^LRD(65,LRI,4),X(1)=$P(X,"^")_":",Y=$P(X,"^",2),X(3)=$P(X,"^",3),X(4)=$P(X,"^",4) D Y W !,$P($P(LRD,X(1),2),";",1),?20,Y,?39,$S('X(3):X(3),$D(^VA(200,X(3),0)):$P(^(0),"^"),1:""),?66 W:X(4)]"" "Pool/div:",X(4)
I $P(X,"^",5)]"" W !?2,"Shipped to: ",$P(X,"^",5)
I $O(^LRD(65,LRI,5,0)) D H4 Q:LR("Q") W !,"Disposition comment(s):" F LRA=0:0 S LRA=$O(^LRD(65,LRI,5,LRA)) Q:'LRA!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") W !,^LRD(65,LRI,5,LRA,0)
I $D(^LRD(65,LRI,8)) D H4 Q:LR("Q") S Y=^(8),X=+Y,W(2)=$P(Y,"^",2),W(3)=$P(Y,"^",3) D AU
I $O(^LRD(65,LRI,15,0)) D H4 Q:LR("Q") F LRA=0:0 S LRA=$O(^LRD(65,LRI,15,LRA)) Q:'LRA!(LR("Q")) S Z=^(LRA,0) D H4 Q:LR("Q") S Y=$P(Z,"^") D Y,W
D H4 Q:LR("Q") I $D(^LRD(65,LRI,6)) S Z=^(6) D:+Z T
D H4 Q:LR("Q") D ^LRBLJPA2 Q
Y Q:'Y S Y=$TR($$FMTE^XLFDT(Y,"5M"),"@"," ")
I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;-->pad for 2 digit day
I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;-->pad for 2 digit month
Q
P ;Q:'$D(^LR(X,0)) S X(1)=^(0),Y=$P(X(1),"^",3),(LRDPF,X)=$P(X(1),"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)"),SSN=$P(Y,"^",9) D SSN^LRU Q
Q:'$D(^LR(X,0)) S X(1)=^(0),(DFN,Y)=$P(X(1),"^",3),(LRDPF,X)=$P(X(1),"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)"),SSN=$P(Y,"^",9) D SSN^LRU Q ;IHS/ANMC/CLS 11/1/95
T ;S X=+Z,(Y,X(1))="" D P W !,"Pt transfused:",$P(Y,"^")," ssn:",SSN," ABO:",$P(X(1),"^",5)," Rh:",$P(X(1),"^",6)
S X=+Z,(Y,X(1))="" D P W !,"Pt transfused:",$P(Y,"^")," HRCN:",HRCN," ABO:",$P(X(1),"^",5)," Rh:",$P(X(1),"^",6) ;IHS/ANMC/CLS 11/1/95
W:$P(Z,"^",2)]"" " Physician:",$P(Z,"^",2) W:$P(Z,"^",6) "(",$P(Z,"^",6),")" S X=$P(Z,"^",5) W:$P(Z,"^",4) " Tx record#:",$P(Z,"^",4)
W !,"Tx reaction:",$S(X=0:"NO",X:"YES",1:"")," Rx specialty: ",$P(Z,"^",3) W:$P(Z,"^",7) "(",$P(Z,"^",7),")" D H4
I $O(^LRD(65,LRI,7,0)) W !,"Transfusion comment(s):" F LRA=0:0 S LRA=$O(^LRD(65,LRI,7,LRA)) Q:'LRA!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") W !,^LRD(65,LRI,7,LRA,0)
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRAA(1),!,"DISPOSITION (Date rec'd from: ",LRSTR," to: ",LRLST,")"
W !,"UNIT ID",?14,"Component",?55,"Invoice #",?66,"Source"
W !,"Date rec'd",?17,"ABO",?21,"Rh",?24,"Exp date",?36,"Logged-in by",?67,"Cost",?72,"Vol(ml)",!,"Disposition",?21,"Disposition date",?39,"Person entering disposition"
W !,LR("%") Q
H1 D H Q:LR("Q") W !,LRP,?14,LRC," (continued from pg ",LRQ-1,")" Q
H2 D H1 Q:LR("Q") W !,"Disposition comment(s):" Q
H3 D H1 Q:LR("Q") W !,"Transfusion comment(s):" Q
H4 D:$Y>(IOSL-6) H1 Q
AU ;I X D P W !,"Restricted for:",$P(Y,"^")," ",SSN
I X D P W !,"Restricted for:",$P(Y,"^")," ",HRCN ;IHS/ANMC/CLS 11/1/95
I W(2)]""!(W(3)]"") W ! W:W(2)]"" "Pos/incomplete screen tests:",$P($P(LRE,W(2)_":",2),";") W:W(3)]"" ?40,"Donation type:",$P($P(LRF,W(3)_":",2),";")
Q
W W !,"Date re-entered: ",Y," Previous disposition: ",$P(Z,"^",2)," Date: " S Y=$P(Z,"^",3) D Y W Y,!?3,"Previous disp entering person: ",$P(^VA(200,$P(Z,"^",4),0),"^")
D H4 Q:LR("Q") W !?3,"Previous shipping invoice: ",$P(Z,"^",5)," Receiving invoice: ",$P(Z,"^",6)
D H4 Q:LR("Q") W !?3,"Previous log-in person: ",$P(^VA(200,$P(Z,"^",7),0),"^"),!?3,"Previous date logged-in: " S Y=$P(Z,"^",8) D Y W Y W:$P(Z,"^",9)]"" !?3,"Ship to: ",$P(Z,"^",9) Q
LRBLJPA1 ; IHS/DIR/AAB - UNIT FINAL DISPOSITION 02/11/98 09:24 ; [ 07/07/1998 12:41 PM ]
+1 ;;5.2;LR;**1002,1006**;SEP 01, 1998
+2 ;
+3 ;;5.2;LAB SERVICE;**72,203**;Sep 27, 1994
+4 DO FIELD^DID(65,4.1,"","POINTER","LRD")
SET LRD=LRD("POINTER")
+5 DO FIELD^DID(65.02,.04,"","POINTER","LRT")
SET LRT=LRT("POINTER")
+6 DO FIELD^DID(65.03,.02,"","POINTER","LRTINS")
SET LRTINS=LRTINS("POINTER")
+7 DO FIELD^DID(65,10,"","POINTER","LRTABO")
SET LRTABO=LRTABO("POINTER")
+8 DO FIELD^DID(65,11,"","POINTER","LRTRH")
SET LRTRH=LRTRH("POINTER")
+9 DO FIELD^DID(65,8.1,"","POINTER","LRE")
SET LRE=LRE("POINTER")
+10 DO FIELD^DID(65,8.1,"","POINTER","LRF")
SET LRF=LRF("POINTER")
+11 SET (LRQ,LRID)=0
DO H
+12 SET LR("F")=1
FOR A=1:1
SET LRID=$ORDER(^LRO(69.2,LRAA,8,65,1,"B",LRID))
IF LRID=""!(LR("Q"))
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LRO(69.2,LRAA,8,65,1,"B",LRID,LRI))
IF 'LRI!(LR("Q"))
QUIT
DO R
+13 QUIT
R IF $Y>(IOSL-7)
DO H
IF LR("Q")
QUIT
SET X=^LRD(65,LRI,0)
SET Y=$PIECE($GET(^(1)),"^")
SET Z=+$PIECE(X,"^",4)
SET LRP=$PIECE(X,"^")
SET LRC=$SELECT($DATA(^LAB(66,Z,0)):$PIECE(^(0),"^"),1:Z)
WRITE !!,LRP,?14,LRC,?55,$PIECE(X,"^",3),?66,$PIECE(X,"^",2)
+1 IF Y]""
WRITE !?14,"(Bag Lot #: ",Y,")"
+2 SET Y=$PIECE(X,"^",5)
DO Y
WRITE !,Y
WRITE ?18,$PIECE(X,"^",7),?20,$PIECE(X,"^",8)
SET Y=$PIECE(X,"^",6)
DO Y
WRITE ?24,Y,?37
SET Y=$PIECE(X,"^",9)
WRITE $SELECT('Y:Y,$DATA(^VA(200,Y,0)):$PIECE(^(0),"^"),1:""),?65,$JUSTIFY($PIECE(X,"^",10),7,2),?73,$PIECE(X,"^",11)
+3 SET Y=$PIECE(X,"^",12)
IF Y
WRITE !,"Typing charge: ",$JUSTIFY($PIECE(X,"^",12),6,2)
SET Z=$PIECE(X,"^",13)
IF Z]""
IF 'Y
WRITE !
WRITE " Shipping invoice:",Z
+4 SET X=$PIECE(X,"^",14)
IF X]""
IF 'Y&(Z="")
WRITE !
WRITE " Return credit: ",X
+5 DO H4
IF LR("Q")
QUIT
SET X=^LRD(65,LRI,4)
SET X(1)=$PIECE(X,"^")_":"
SET Y=$PIECE(X,"^",2)
SET X(3)=$PIECE(X,"^",3)
SET X(4)=$PIECE(X,"^",4)
DO Y
WRITE !,$PIECE($PIECE(LRD,X(1),2),";",1),?20,Y,?39,$SELECT('X(3):X(3),$DATA(^VA(200,X(3),0)):$PIECE(^(0),"^"),1:""),?66
IF X(4)]""
WRITE "Pool/div:",X(4)
+6 IF $PIECE(X,"^",5)]""
WRITE !?2,"Shipped to: ",$PIECE(X,"^",5)
+7 IF $ORDER(^LRD(65,LRI,5,0))
DO H4
IF LR("Q")
QUIT
WRITE !,"Disposition comment(s):"
FOR LRA=0:0
SET LRA=$ORDER(^LRD(65,LRI,5,LRA))
IF 'LRA!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H2
IF LR("Q")
QUIT
WRITE !,^LRD(65,LRI,5,LRA,0)
+8 IF $DATA(^LRD(65,LRI,8))
DO H4
IF LR("Q")
QUIT
SET Y=^(8)
SET X=+Y
SET W(2)=$PIECE(Y,"^",2)
SET W(3)=$PIECE(Y,"^",3)
DO AU
+9 IF $ORDER(^LRD(65,LRI,15,0))
DO H4
IF LR("Q")
QUIT
FOR LRA=0:0
SET LRA=$ORDER(^LRD(65,LRI,15,LRA))
IF 'LRA!(LR("Q"))
QUIT
SET Z=^(LRA,0)
DO H4
IF LR("Q")
QUIT
SET Y=$PIECE(Z,"^")
DO Y
DO W
+10 DO H4
IF LR("Q")
QUIT
IF $DATA(^LRD(65,LRI,6))
SET Z=^(6)
IF +Z
DO T
+11 DO H4
IF LR("Q")
QUIT
DO ^LRBLJPA2
QUIT
Y IF 'Y
QUIT
SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"5M"),"@"," ")
+1 ;-->pad for 2 digit day
IF $LENGTH($PIECE(Y,"/"))=1
SET $PIECE(Y,"/")="0"_$PIECE(Y,"/")
+2 ;-->pad for 2 digit month
IF $LENGTH($PIECE(Y,"/",2))=1
SET $PIECE(Y,"/",2)="0"_$PIECE(Y,"/",2)
+3 QUIT
PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P ;Q:'$D(^LR(X,0)) S X(1)=^(0),Y=$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(X(1),"^",3),(LRDPA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">PF,X)=$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(X(1),"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)"),SSN=$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(Y,"^",9) D SSN^LRU Q
+1 ;IHS/ANMC/CLS 11/1/95
IF '$DATA(^LR(X,0))
QUIT
SET X(1)=^(0)
SET (DFN,Y)=$PIECE(X(1),"^",3)
SET (LRDPF,X)=$PIECE(X(1),"^",2)
SET X=^DIC(X,0,"GL")
SET Y=@(X_Y_",0)")
SET SSN=$PIECE(Y,"^",9)
DO SSN^LRU
QUIT
T ;S X=+Z,(Y,X(1))="" D PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P W !,"PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">Pt transfused:",$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(Y,"^")," ssn:",SSN," ABO:",$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(X(1),"^",5)," Rh:",$PA1_source.html#xP">PA1_source.html#xPA1_source.html#xP">P">PA1_source.html#xP">P(X(1),"^",6)
+1 ;IHS/ANMC/CLS 11/1/95
SET X=+Z
SET (Y,X(1))=""
DO P
WRITE !,"Pt transfused:",$PIECE(Y,"^")," HRCN:",HRCN," ABO:",$PIECE(X(1),"^",5)," Rh:",$PIECE(X(1),"^",6)
+2 IF $PIECE(Z,"^",2)]""
WRITE " Physician:",$PIECE(Z,"^",2)
IF $PIECE(Z,"^",6)
WRITE "(",$PIECE(Z,"^",6),")"
SET X=$PIECE(Z,"^",5)
IF $PIECE(Z,"^",4)
WRITE " Tx record#:",$PIECE(Z,"^",4)
+3 WRITE !,"Tx reaction:",$SELECT(X=0:"NO",X:"YES",1:"")," Rx specialty: ",$PIECE(Z,"^",3)
IF $PIECE(Z,"^",7)
WRITE "(",$PIECE(Z,"^",7),")"
DO H4
+4 IF $ORDER(^LRD(65,LRI,7,0))
WRITE !,"Transfusion comment(s):"
FOR LRA=0:0
SET LRA=$ORDER(^LRD(65,LRI,7,LRA))
IF 'LRA!(LR("Q"))
QUIT
IF $Y>(IOSL-6)
DO H3
IF LR("Q")
QUIT
WRITE !,^LRD(65,LRI,7,LRA,0)
+5 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRAA(1),!,"DISPOSITION (Date rec'd from: ",LRSTR," to: ",LRLST,")"
+2 WRITE !,"UNIT ID",?14,"Component",?55,"Invoice #",?66,"Source"
+3 WRITE !,"Date rec'd",?17,"ABO",?21,"Rh",?24,"Exp date",?36,"Logged-in by",?67,"Cost",?72,"Vol(ml)",!,"Disposition",?21,"Disposition date",?39,"Person entering disposition"
+4 WRITE !,LR("%")
QUIT
H1 DO H
IF LR("Q")
QUIT
WRITE !,LRP,?14,LRC," (continued from pg ",LRQ-1,")"
QUIT
H2 DO H1
IF LR("Q")
QUIT
WRITE !,"Disposition comment(s):"
QUIT
H3 DO H1
IF LR("Q")
QUIT
WRITE !,"Transfusion comment(s):"
QUIT
H4 IF $Y>(IOSL-6)
DO H1
QUIT
AU ;I X D P W !,"Restricted for:",$P(Y,"^")," ",SSN
+1 ;IHS/ANMC/CLS 11/1/95
IF X
DO P
WRITE !,"Restricted for:",$PIECE(Y,"^")," ",HRCN
+2 IF W(2)]""!(W(3)]"")
WRITE !
IF W(2)]""
WRITE "Pos/incomplete screen tests:",$PIECE($PIECE(LRE,W(2)_":",2),";")
IF W(3)]""
WRITE ?40,"Donation type:",$PIECE($PIECE(LRF,W(3)_":",2),";")
+3 QUIT
W WRITE !,"Date re-entered: ",Y," Previous disposition: ",$PIECE(Z,"^",2)," Date: "
SET Y=$PIECE(Z,"^",3)
DO Y
WRITE Y,!?3,"Previous disp entering person: ",$PIECE(^VA(200,$PIECE(Z,"^",4),0),"^")
+1 DO H4
IF LR("Q")
QUIT
WRITE !?3,"Previous shipping invoice: ",$PIECE(Z,"^",5)," Receiving invoice: ",$PIECE(Z,"^",6)
+2 DO H4
IF LR("Q")
QUIT
WRITE !?3,"Previous log-in person: ",$PIECE(^VA(200,$PIECE(Z,"^",7),0),"^"),!?3,"Previous date logged-in: "
SET Y=$PIECE(Z,"^",8)
DO Y
WRITE Y
IF $PIECE(Z,"^",9)]""
WRITE !?3,"Ship to: ",$PIECE(Z,"^",9)
QUIT
