LRBLJC ; IHS/DIR/FJE - COMPONENT DISPOSITION LIST 09:10 ; [ 2/18/93 ]
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
D END W !!?20,"COMPONENT DISPOSITION BY DATE UNIT RECEIVED"
W ! S DIC=66,DIC(0)="AEQM",DIC("A")="Select BLOOD COMPONENT: " D ^DIC K DIC G:Y<1 END S LRM=+Y,LRM(1)=$P(Y,U,2)
ABO R !,"Select ABO Group: ",X:DTIME G:X=""!(X[U) END I X'="A",X'="B",X'="AB",X'="O" W $C(7)," Enter A, B, AB or O" G ABO
S LRABO=X
ASK W !!,"Select (T)ransfusions or (A)ll other dispositions: " R X:DTIME G:X=""!(X[U) END S X=$A(X) S:X>97 X=X-32 I X'=65,X'=84 D HLP^LRBLJB G ASK
S LRW=$C(X) D B^LRU G:Y<0 END S ZTRTN="QUE^LRBLJC" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S:LRW="A" LRS=$P(^DD(65,4.1,0),U,3) S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99 D L^LRU,S^LRU,H
F LRA=LRSDT:0 S LRA=$O(^LRD(65,"A",LRA)) Q:'LRA!(LRA>LRLDT) F LRI=0:0 S LRI=$O(^LRD(65,"A",LRA,LRI)) Q:'LRI D B
G:LRW="A" D
F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)") S ^TMP($J,"B",$P(X,"^"),A)=$P(X,"^",9)
;S LRP=0 F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP="" F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2) D SSN^LRU,W
S LRP=0 F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP="" F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3) D SSN^LRU,W ;IHS/ANMC/CLS 11/1/95
OUT D END^LRUTL,END Q
D S LRE=0 F LRF=0:0 S LRE=$O(^TMP($J,LRE)) Q:LRE="" S X=LRE_":",LRD=$P($P(LRS,X,2),";") D:$Y>(IOSL-6) H W !?11,LRD D F
G OUT
F S LRC=0 F LRA=0:0 S LRC=$O(^TMP($J,LRE,LRC)) Q:LRC="" F LRI=0:0 S LRI=$O(^TMP($J,LRE,LRC,LRI)) Q:'LRI D:$Y>(IOSL-6) H2 W !?45,LRC S X1=$P(^LRD(65,LRI,4),"^",2),X2=$P(^(0),"^",5) D ^%DTC S:X=0 X="<1" W ?65,$J(X,5)
Q
W ;D:$Y>(IOSL-6) H W !!,LRP," ",SSN
D:$Y>(IOSL-6) H W !!,LRP," ",HRCN ;IHS/ANMC/CLS 11/1/95
S LRE=0 F LRF=0:0 S LRE=$O(^TMP($J,LRDFN,LRE)) Q:LRE="" S LRI=$O(^TMP($J,LRDFN,LRE,0)) D Y
Q
Y D:$Y>(IOSL-6) H1 S X1=$P(^LRD(65,LRI,4),"^",2),X2=$P(^(0),"^",5) D ^%DTC S:X=0 X="<1" I LRW="A" S LRX=$P(^LRD(65,LRI,4),"^")_":",LRX=$P($P(LRS,LRX,2),";")
W !?11,$S(LRW="T":$P(^LRD(65,LRI,6),"^",3),1:LRX),?45,LRE,?65,$J(X,5) Q
;
B I '$D(^LRD(65,LRI,0)) K ^LRD(65,"A",LRA,LRI) Q
S X=^LRD(65,LRI,0) I $D(^(4)),$P(X,"^",4)=LRM,$P(X,"^",7)=LRABO S LRY=$P(^(4),"^") D @(LRW)
Q
T Q:'$D(^LRD(65,LRI,6)) S X=+^(6) Q:'X
S S Z=^LRD(65,LRI,0),^TMP($J,X,$P(Z,"^"),LRI)="" Q
A Q:LRY="T"!(LRY="") S X=LRY G S
Q
;
H S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU W @IOF,Y," ",LRQ(1),?(IOM-10),"Pg: ",LRQ,!,LRM(1),?45,"ABO Group: ",LRABO
W !,$S(LRW="T":"Transfusions",1:"")," (Units received from ",LRSTR," to ",LRLST,")",!?11,$S(LRW="T":"Treating Specialty",1:"Disposition"),?45,"Unit ID",?60,"Days in inventory",!,LR("%") Q
H1 ;D H W !,LRP," ",SSN Q
D H W !,LRP," ",HRCN Q ;IHS/ANMC/CLS 11/1/95
H2 D H W !,LRE Q
;
END D V^LRU Q
LRBLJC ; IHS/DIR/FJE - COMPONENT DISPOSITION LIST 09:10 ; [ 2/18/93 ]
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 DO END
WRITE !!?20,"COMPONENT DISPOSITION BY DATE UNIT RECEIVED"
+5 WRITE !
SET DIC=66
SET DIC(0)="AEQM"
SET DIC("A")="Select BLOOD COMPONENT: "
DO ^DIC
KILL DIC
IF Y<1
GOTO END
SET LRM=+Y
SET LRM(1)=$PIECE(Y,U,2)
ABO READ !,"Select ABO Group: ",X:DTIME
IF X=""!(X[U)
GOTO END
IF X'="A"
IF X'="B"
IF X'="AB"
IF X'="O"
WRITE $CHAR(7)," Enter A, B, AB or O"
GOTO ABO
+1 SET LRABO=X
ASK WRITE !!,"Select (T)ransfusions or (A)ll other dispositions: "
READ X:DTIME
IF X=""!(X[U)
GOTO END
SET X=$ASCII(X)
IF X>97
SET X=X-32
IF X'=65
IF X'=84
DO HLP^LRBLJB
GOTO ASK
+1 SET LRW=$CHAR(X)
DO B^LRU
IF Y<0
GOTO END
SET ZTRTN="QUE^LRBLJC"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
IF LRW="A"
SET LRS=$PIECE(^DD(65,4.1,0),U,3)
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
DO L^LRU
DO S^LRU
DO H
+1 FOR LRA=LRSDT:0
SET LRA=$ORDER(^LRD(65,"A",LRA))
IF 'LRA!(LRA>LRLDT)
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LRD(65,"A",LRA,LRI))
IF 'LRI
QUIT
DO B
+2 IF LRW="A"
GOTO D
+3 FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
IF 'A
QUIT
SET X=^LR(A,0)
SET Y=$PIECE(X,"^",3)
SET X=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET X=@(X_Y_",0)")
SET ^TMP($JOB,"B",$PIECE(X,"^"),A)=$PIECE(X,"^",9)
+4 ;S LRP=0 F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP="" F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2) D SSN^LRU,W
+5 ;IHS/ANMC/CLS 11/1/95
SET LRP=0
FOR LRA=0:0
SET LRP=$ORDER(^TMP($JOB,"B",LRP))
IF LRP=""
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,"B",LRP,LRDFN))
IF 'LRDFN
QUIT
SET SSN=^(LRDFN)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
DO SSN^LRU
DO W
OUT DO END^LRUTL
DO END
QUIT
D SET LRE=0
FOR LRF=0:0
SET LRE=$ORDER(^TMP($JOB,LRE))
IF LRE=""
QUIT
SET X=LRE_":"
SET LRD=$PIECE($PIECE(LRS,X,2),";")
IF $Y>(IOSL-6)
DO H
WRITE !?11,LRD
DO F
+1 GOTO OUT
F SET LRC=0
FOR LRA=0:0
SET LRC=$ORDER(^TMP($JOB,LRE,LRC))
IF LRC=""
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^TMP($JOB,LRE,LRC,LRI))
IF 'LRI
QUIT
IF $Y>(IOSL-6)
DO H2
WRITE !?45,LRC
SET X1=$PIECE(^LRD(65,LRI,4),"^",2)
SET X2=$PIECE(^(0),"^",5)
DO ^%DTC
IF X=0
SET X="<1"
WRITE ?65,$JUSTIFY(X,5)
+1 QUIT
W ;D:$Y>(IOSL-6) H W !!,LRP," ",SSN
+1 ;IHS/ANMC/CLS 11/1/95
IF $Y>(IOSL-6)
DO H
WRITE !!,LRP," ",HRCN
+2 SET LRE=0
FOR LRF=0:0
SET LRE=$ORDER(^TMP($JOB,LRDFN,LRE))
IF LRE=""
QUIT
SET LRI=$ORDER(^TMP($JOB,LRDFN,LRE,0))
DO Y
+3 QUIT
Y IF $Y>(IOSL-6)
DO H1
SET X1=$PIECE(^LRD(65,LRI,4),"^",2)
SET X2=$PIECE(^(0),"^",5)
DO ^%DTC
IF X=0
SET X="<1"
IF LRW="A"
SET LRX=$PIECE(^LRD(65,LRI,4),"^")_":"
SET LRX=$PIECE($PIECE(LRS,LRX,2),";")
+1 WRITE !?11,$SELECT(LRW="T":$PIECE(^LRD(65,LRI,6),"^",3),1:LRX),?45,LRE,?65,$JUSTIFY(X,5)
QUIT
+2 ;
B IF '$DATA(^LRD(65,LRI,0))
KILL ^LRD(65,"A",LRA,LRI)
QUIT
+1 SET X=^LRD(65,LRI,0)
IF $DATA(^(4))
IF $PIECE(X,"^",4)=LRM
IF $PIECE(X,"^",7)=LRABO
SET LRY=$PIECE(^(4),"^")
DO @(LRW)
+2 QUIT
T IF '$DATA(^LRD(65,LRI,6))
QUIT
SET X=+^(6)
IF 'X
QUIT
S SET Z=^LRD(65,LRI,0)
SET ^TMP($JOB,X,$PIECE(Z,"^"),LRI)=""
QUIT
A IF LRY="T"!(LRY="")
QUIT
SET X=LRY
GOTO S
+1 QUIT
+2 ;
H SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
WRITE @IOF,Y," ",LRQ(1),?(IOM-10),"Pg: ",LRQ,!,LRM(1),?45,"ABO Group: ",LRABO
+1 WRITE !,$SELECT(LRW="T":"Transfusions",1:"")," (Units received from ",LRSTR," to ",LRLST,")",!?11,$SELECT(LRW="T":"Treating Specialty",1:"Disposition"),?45,"Unit ID",?60,"Days in inventory",!,LR("%")
QUIT
H1 ;D H W !,LRP," ",SSN Q
+1 ;IHS/ANMC/CLS 11/1/95
DO H
WRITE !,LRP," ",HRCN
QUIT
H2 DO H
WRITE !,LRE
QUIT
+1 ;
END DO V^LRU
QUIT
