- LRBLJB ; IHS/DIR/FJE - AUTOLOGOUS UNIT DISPOSITION LIST 09:08 ; [ 2/18/93 ]
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END W !!?10,"LIST OF AUTOLOGOUS UNIT DISPOSITIONS BY DATE UNIT RECEIVED"
- 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 G ASK
- S LRW=$C(X) D B^LRU G:Y<0 END S ZTRTN="QUE^LRBLJB" 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 I $D(^LRD(65,LRI,8)),$P(^(8),"^",3)="A" D @(LRW)
- 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
- W !! S LRA=0 F LRB=0:0 S LRA=$O(LRD(LRA)) Q:LRA="" D:$Y>(IOSL-6) H W !?3,LRA,?7," = ",LRD(LRA),?50,"(",$J(LRD(LRA,1),3)," units)"
- D END^LRUTL,END Q
- W ;D:$Y>(IOSL-6) H W !!,LRP," ",SSN
- D:$Y>(IOSL-6) H W !!,LRP," ",HRCN ;IHS/ANMC/CLS 11/1/95
- F LRC=0:0 S LRC=$O(^TMP($J,LRDFN,LRC)) Q:LRC="" S LRD=LRC D X
- Q
- X I LRC,$D(^LAB(66,LRC,0)) S X=^(0),LRD=$P(X,"^",2) S:LRD="" LRD="?" S LRD(LRD)=$P(X,"^") S:'$D(LRD(LRD,1)) LRD(LRD,1)=0
- S LRE=0 F LRF=0:0 S LRE=$O(^TMP($J,LRDFN,LRC,LRE)) Q:LRE="" S LRI=$O(^TMP($J,LRDFN,LRC,LRE,0)) D Y
- Q
- Y D:$Y>(IOSL-6) H1 S LRD(LRD,1)=LRD(LRD,1)+1,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 !?3,LRD,?11,$S(LRW="T":$P(^LRD(65,LRI,6),"^",3),1:LRX),?45,LRE,?65,$J(X,5) Q
- ;
- T Q:'$D(^LRD(65,LRI,6)) S X=^(6) Q:'+X
- S S Z=^LRD(65,LRI,0),Y=$P(Z,"^",4) S:Y="" Y="?" S ^TMP($J,+X,Y,$P(Z,"^"),LRI)="" Q
- A Q:'$D(^LRD(65,LRI,4)) S X=$P(^(4),"^") Q:X=""!(X="T") S X=+$P(^(8),"^") Q:'+X 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
- W !,"Autologous ",$S(LRW="T":"Transfusions",1:"")," (Units received from ",LRSTR," to ",LRLST,")",!,"Component",?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
- ;
- HLP W !!,"Enter 'T' for a list of autologous transfusions or",!,"enter 'A' for a list of all dispositions except transfusions",!,"for autologous units." Q
- ;
- END D V^LRU Q
- LRBLJB ; IHS/DIR/FJE - AUTOLOGOUS UNIT DISPOSITION LIST 09:08 ; [ 2/18/93 ]
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- WRITE !!?10,"LIST OF AUTOLOGOUS UNIT DISPOSITIONS BY DATE UNIT RECEIVED"
- 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
- GOTO ASK
- +1 SET LRW=$CHAR(X)
- DO B^LRU
- IF Y<0
- GOTO END
- SET ZTRTN="QUE^LRBLJB"
- 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
- IF $DATA(^LRD(65,LRI,8))
- IF $PIECE(^(8),"^",3)="A"
- DO @(LRW)
- +2 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)
- +3 ;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
- +4 ;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
- +5 WRITE !!
- SET LRA=0
- FOR LRB=0:0
- SET LRA=$ORDER(LRD(LRA))
- IF LRA=""
- QUIT
- IF $Y>(IOSL-6)
- DO H
- WRITE !?3,LRA,?7," = ",LRD(LRA),?50,"(",$JUSTIFY(LRD(LRA,1),3)," units)"
- +6 DO END^LRUTL
- DO END
- 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 FOR LRC=0:0
- SET LRC=$ORDER(^TMP($JOB,LRDFN,LRC))
- IF LRC=""
- QUIT
- SET LRD=LRC
- DO X
- +3 QUIT
- X IF LRC
- IF $DATA(^LAB(66,LRC,0))
- SET X=^(0)
- SET LRD=$PIECE(X,"^",2)
- IF LRD=""
- SET LRD="?"
- SET LRD(LRD)=$PIECE(X,"^")
- IF '$DATA(LRD(LRD,1))
- SET LRD(LRD,1)=0
- +1 SET LRE=0
- FOR LRF=0:0
- SET LRE=$ORDER(^TMP($JOB,LRDFN,LRC,LRE))
- IF LRE=""
- QUIT
- SET LRI=$ORDER(^TMP($JOB,LRDFN,LRC,LRE,0))
- DO Y
- +2 QUIT
- Y IF $Y>(IOSL-6)
- DO H1
- SET LRD(LRD,1)=LRD(LRD,1)+1
- 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 !?3,LRD,?11,$SELECT(LRW="T":$PIECE(^LRD(65,LRI,6),"^",3),1:LRX),?45,LRE,?65,$JUSTIFY(X,5)
- QUIT
- +2 ;
- T IF '$DATA(^LRD(65,LRI,6))
- QUIT
- SET X=^(6)
- IF '+X
- QUIT
- S SET Z=^LRD(65,LRI,0)
- SET Y=$PIECE(Z,"^",4)
- IF Y=""
- SET Y="?"
- SET ^TMP($JOB,+X,Y,$PIECE(Z,"^"),LRI)=""
- QUIT
- A IF '$DATA(^LRD(65,LRI,4))
- QUIT
- SET X=$PIECE(^(4),"^")
- IF X=""!(X="T")
- QUIT
- SET X=+$PIECE(^(8),"^")
- IF '+X
- QUIT
- 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
- +1 WRITE !,"Autologous ",$SELECT(LRW="T":"Transfusions",1:"")," (Units received from ",LRSTR," to ",LRLST,")",!,"Component",?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
- +2 ;
- HLP WRITE !!,"Enter 'T' for a list of autologous transfusions or",!,"enter 'A' for a list of all dispositions except transfusions",!,"for autologous units."
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
