- LRBLJPP ; IHS/DIR/FJE - PLATLET TX 2/18/93 09:28 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- W !!,"Platelet transfusions from one date received to another."
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END S LRS=$O(^LAB(61,"B","BLOOD",0)) I 'LRS W $C(7),!,"BLOOD must be an entry in TOPOGRAPHY file (#61)",! G END
- I '$O(^LRO(69.2,LRAA,61,LRS,2,0)) W $C(7),!!,"Must have tests to print entered in the",!,"'Tests for inclusion in transfusion report option' in",!,"Blood bank supervisor menu",! G END
- S DIC="^LRO(69.2,LRAA,61,LRS,2,",DIC(0)="AEQMZ" F LRA=1:1 D ^DIC Q:Y<1 S W=$P(Y(0),"^",2),Y=+Y(0) D S
- I LRA=1 W $C(7),!,"No tests selected." G END
- S LRT(0)=LRA-1 D B^LRU G:Y<0 END S LRE=LRLDT+.99,LRB=LRSDT-.0001,ZTRTN="QUE^LRBLJPP" D BEG^LRUTL G:$D(ZTSK)!(POP) END
- QUE U IO K ^TMP($J) D:IOST?1"C".E WAIT^LRU D L^LRU,S^LRU,H S LR("F")=1
- F B=0:0 S LRB=$O(^LRD(65,"A",LRB)) Q:'LRB!(LRB>LRE) F LRI=0:0 S LRI=$O(^LRD(65,"A",LRB,LRI)) Q:'LRI I $D(^LRD(65,LRI,4)),$P(^(4),"^")="T",$D(^(0)) S Y=$P(^(0),"^",4) I Y,$D(^LAB(66,Y,0)) S Y=$P(^(0),"^") D:Y["PLAT"!(Y["PLT") A
- S X1=LRLDT,X2=5 D C^%DTC S LRLDT=9999998-X S X1=LRSDT,X2=-5 D C^%DTC S LRSDT=9999999-X
- F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRDFN)) Q:'LRDFN D B
- D WRT W:IO'=IO(0) @IOF D END^LRUTL,END Q
- A S X=^LRD(65,LRI,6),Y=$P(X,"^",4),LRDFN=+X,X=^LR(LRDFN,1.6,Y,0),^TMP($J,LRDFN)="",^(LRDFN,Y,0)=+X,^(.1)=$P(X,"^",2,99) Q
- B F A=LRLDT:0 S A=$O(^LR(LRDFN,"CH",A)) Q:'A!(A>LRSDT) S X=^(A,0) F B=1:1:LRT(0) S Z=$S($D(^LR(LRDFN,"CH",A,LRV(B))):$P(^(LRV(B)),"^"),1:"") I Z]"",$P(X,"^",5)=LRS(B) S ^TMP($J,LRDFN,A,0)=+X,^(B)=Z
- Q
- WRT 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)"),^TMP($J,"B",$P(X,"^"),A)=$P(X,"^",2,99)
- ;S LRP=0 F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S LRX=^(LRDFN),SSN=$P(LRX,"^",8),Y=$P(LRX,"^",2),LRDPF=$P(^LR(LRDFN,0),U,2) D D^LRU,SSN^LRU S DOB=Y D W
- S LRP=0 F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S LRX=^(LRDFN),SSN=$P(LRX,"^",8),Y=$P(LRX,"^",2),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D D^LRU,SSN^LRU S DOB=Y D W
- ;IHS/ANMC/CLS 11/1/95
- Q
- W ;D:$Y>(IOSL-6) H Q:LR("Q") W !!,LRP,?31,SSN,?45,"DOB: ",DOB F A=0:0 S A=$O(^TMP($J,LRDFN,A)) Q:'A!(LR("Q")) S T=+^(A,0) D T,P
- D:$Y>(IOSL-6) H Q:LR("Q") W !!,LRP,?31,HRCN,?45,"DOB: ",DOB F A=0:0 S A=$O(^TMP($J,LRDFN,A)) Q:'A!(LR("Q")) S T=+^(A,0) D T,P ;IHS/ANMC/CLS 11/1/95
- S X=^LR(LRDFN,0) I $P(X,"^",2)=2 S DFN=$P(X,"^",3) D ^LRBLJPP1
- Q
- P D:$Y>(IOSL-6) H1 Q:LR("Q") W !,T S Q=$S($D(^TMP($J,LRDFN,A,.1)):^(.1),1:"") W:Q ?15,$E($P(^LAB(66,+Q,0),"^"),1,25),$S($P(Q,"^",6):"("_$P(Q,"^",6)_")",1:"")
- Q:'$O(^TMP($J,LRDFN,A,.1))
- D:$Y>(IOSL-6) H1 Q:LR("Q") S X(1)=0 F B=1:1:LRT(0) S X(1)=X(1)+1 S:$X>(IOM-9) X(1)=1 W:$X>(IOM-9) !?32 W ?32+(8*X(1)) I $D(^TMP($J,LRDFN,A,B)) W $J(^(B),5)
- Q
- S S X=^LAB(60,Y,0),X(1)=$S($D(^(.1)):$P(^(.1),"^"),1:"??"),Z=$S($D(^(1,W,0)):$P(^(0),"^",7),1:"")
- S LRT(LRA)=$P($P(X,"^",5),";",2,3)_"^"_W_"^"_$P(X,"^")_"^"_Z_"^"_$P(^LAB(61,W,0),"^")_"^"_Y_"^"_X(1),LRV(LRA)=+LRT(LRA),LRS(LRA)=W Q
- T S T=T_"000",T=$E(T,4,5)_"/"_$E(T,6,7)_"/"_$E(T,2,3)_$S(T[".":" "_$E(T,9,10)_":"_$E(T,11,12),1:"") Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"Mo/Da TIME",?12,"Blood component"
- S X(1)=0 F X=1:1:LRT(0) S X(1)=X(1)+1 S:$X>(IOM-8) X(1)=1 W:$X>(IOM-8) !?32 W ?32+(8*X(1)),$P(LRT(X),"^",7)
- W !,LR("%") Q
- H1 ;D H Q:LR("Q") W !!,LRP,?31,SSN,?45,"DOB: ",DOB Q
- D H Q:LR("Q") W !!,LRP,?31,HRCN,?45,"DOB: ",DOB Q ;IHS/ANMC/CLS 11/1/95
- ;
- END D V^LRU Q
- LRBLJPP ; IHS/DIR/FJE - PLATLET TX 2/18/93 09:28 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 WRITE !!,"Platelet transfusions from one date received to another."
- +5 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- SET LRS=$ORDER(^LAB(61,"B","BLOOD",0))
- IF 'LRS
- WRITE $CHAR(7),!,"BLOOD must be an entry in TOPOGRAPHY file (#61)",!
- GOTO END
- +6 IF '$ORDER(^LRO(69.2,LRAA,61,LRS,2,0))
- WRITE $CHAR(7),!!,"Must have tests to print entered in the",!,"'Tests for inclusion in transfusion report option' in",!,"Blood bank supervisor menu",!
- GOTO END
- +7 SET DIC="^LRO(69.2,LRAA,61,LRS,2,"
- SET DIC(0)="AEQMZ"
- FOR LRA=1:1
- DO ^DIC
- IF Y<1
- QUIT
- SET W=$PIECE(Y(0),"^",2)
- SET Y=+Y(0)
- DO S
- +8 IF LRA=1
- WRITE $CHAR(7),!,"No tests selected."
- GOTO END
- +9 SET LRT(0)=LRA-1
- DO B^LRU
- IF Y<0
- GOTO END
- SET LRE=LRLDT+.99
- SET LRB=LRSDT-.0001
- SET ZTRTN="QUE^LRBLJPP"
- DO BEG^LRUTL
- IF $DATA(ZTSK)!(POP)
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- IF IOST?1"C".E
- DO WAIT^LRU
- DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- +1 FOR B=0:0
- SET LRB=$ORDER(^LRD(65,"A",LRB))
- IF 'LRB!(LRB>LRE)
- QUIT
- FOR LRI=0:0
- SET LRI=$ORDER(^LRD(65,"A",LRB,LRI))
- IF 'LRI
- QUIT
- IF $DATA(^LRD(65,LRI,4))
- IF $PIECE(^(4),"^")="T"
- IF $DATA(^(0))
- SET Y=$PIECE(^(0),"^",4)
- IF Y
- IF $DATA(^LAB(66,Y,0))
- SET Y=$PIECE(^(0),"^")
- IF Y["PLAT"!(Y["PLT")
- DO A
- +2 SET X1=LRLDT
- SET X2=5
- DO C^%DTC
- SET LRLDT=9999998-X
- SET X1=LRSDT
- SET X2=-5
- DO C^%DTC
- SET LRSDT=9999999-X
- +3 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP($JOB,LRDFN))
- IF 'LRDFN
- QUIT
- DO B
- +4 DO WRT
- IF IO'=IO(0)
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- A SET X=^LRD(65,LRI,6)
- SET Y=$PIECE(X,"^",4)
- SET LRDFN=+X
- SET X=^LR(LRDFN,1.6,Y,0)
- SET ^TMP($JOB,LRDFN)=""
- SET ^(LRDFN,Y,0)=+X
- SET ^(.1)=$PIECE(X,"^",2,99)
- QUIT
- B FOR A=LRLDT:0
- SET A=$ORDER(^LR(LRDFN,"CH",A))
- IF 'A!(A>LRSDT)
- QUIT
- SET X=^(A,0)
- FOR B=1:1:LRT(0)
- SET Z=$SELECT($DATA(^LR(LRDFN,"CH",A,LRV(B))):$PIECE(^(LRV(B)),"^"),1:"")
- IF Z]""
- IF $PIECE(X,"^",5)=LRS(B)
- SET ^TMP($JOB,LRDFN,A,0)=+X
- SET ^(B)=Z
- +1 QUIT
- WRT 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,"^",2,99)
- +1 ;S LRBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P=0 F LRA=0:0 S LRBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P=$O(^TMBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P($J,"B",LRBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P)) Q:LRBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P($J,"B",LRBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P,LRDFN)) Q:'LRDFN!(LR("Q")) S LRX=^(LRDFN),SSN=$BLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P(LRX,"^",8),Y=$BLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P(LRX,"^",2),LRDBLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PF=$BLJBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">PBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P_source.html#xBLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P">BLJBLJPP_source.html#xP">PBLJPP_source.html#xP">P_source.html#xBLJPP_source.html#xP">P">BLJPP_source.html#xP">P(^LR(LRDFN,0),U,2) D D^LRU,SSN^LRU S DOB=Y D W
- +2 SET LRP=0
- FOR LRA=0:0
- SET LRP=$ORDER(^TMP($JOB,"B",LRP))
- IF LRP=""!(LR("Q"))
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP($JOB,"B",LRP,LRDFN))
- IF 'LRDFN!(LR("Q"))
- QUIT
- SET LRX=^(LRDFN)
- SET SSN=$PIECE(LRX,"^",8)
- SET Y=$PIECE(LRX,"^",2)
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO D^LRU
- DO SSN^LRU
- SET DOB=Y
- DO W
- +3 ;IHS/ANMC/CLS 11/1/95
- +4 QUIT
- W ;D:$Y>(IOSL-6) H Q:LR("Q") W !!,LRP,?31,SSN,?45,"DOBLJPP_source.html#xB">B: ",DOBLJPP_source.html#xB">B F A=0:0 S A=$O(^TMP($J,LRDFN,A)) Q:'A!(LR("Q")) S T=+^(A,0) D T,P
- +1 ;IHS/ANMC/CLS 11/1/95
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !!,LRP,?31,HRCN,?45,"DOBLJPP_source.html#xB">B: ",DOBLJPP_source.html#xB">B
- FOR A=0:0
- SET A=$ORDER(^TMP($JOB,LRDFN,A))
- IF 'A!(LR("Q"))
- QUIT
- SET T=+^(A,0)
- DO T
- DO P
- +2 SET X=^LR(LRDFN,0)
- IF $PIECE(X,"^",2)=2
- SET DFN=$PIECE(X,"^",3)
- DO ^LRBLJPP1
- +3 QUIT
- P IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- WRITE !,T
- SET Q=$SELECT($DATA(^TMP($JOB,LRDFN,A,.1)):^(.1),1:"")
- IF Q
- WRITE ?15,$EXTRACT($PIECE(^LAB(66,+Q,0),"^"),1,25),$SELECT($PIECE(Q,"^",6):"("_$PIECE(Q,"^",6)_")",1:"")
- +1 IF '$ORDER(^TMP($JOB,LRDFN,A,.1))
- QUIT
- +2 IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- SET X(1)=0
- FOR B=1:1:LRT(0)
- SET X(1)=X(1)+1
- IF $X>(IOM-9)
- SET X(1)=1
- IF $X>(IOM-9)
- WRITE !?32
- WRITE ?32+(8*X(1))
- IF $DATA(^TMP($JOB,LRDFN,A,B))
- WRITE $JUSTIFY(^(B),5)
- +3 QUIT
- S SET X=^LAB(60,Y,0)
- SET X(1)=$SELECT($DATA(^(.1)):$PIECE(^(.1),"^"),1:"??")
- SET Z=$SELECT($DATA(^(1,W,0)):$PIECE(^(0),"^",7),1:"")
- +1 SET LRT(LRA)=$PIECE($PIECE(X,"^",5),";",2,3)_"^"_W_"^"_$PIECE(X,"^")_"^"_Z_"^"_$PIECE(^LAB(61,W,0),"^")_"^"_Y_"^"_X(1)
- SET LRV(LRA)=+LRT(LRA)
- SET LRS(LRA)=W
- QUIT
- T SET T=T_"000"
- SET T=$EXTRACT(T,4,5)_"/"_$EXTRACT(T,6,7)_"/"_$EXTRACT(T,2,3)_$SELECT(T[".":" "_$EXTRACT(T,9,10)_":"_$EXTRACT(T,11,12),1:"")
- QUIT
- +1 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"Mo/Da TIME",?12,"Blood component"
- +2 SET X(1)=0
- FOR X=1:1:LRT(0)
- SET X(1)=X(1)+1
- IF $X>(IOM-8)
- SET X(1)=1
- IF $X>(IOM-8)
- WRITE !?32
- WRITE ?32+(8*X(1)),$PIECE(LRT(X),"^",7)
- +3 WRITE !,LR("%")
- QUIT
- H1 ;D H Q:LR("Q") W !!,LRP,?31,SSN,?45,"DOBLJPP_source.html#xB">B: ",DOBLJPP_source.html#xB">B Q
- +1 ;IHS/ANMC/CLS 11/1/95
- DO H
- IF LR("Q")
- QUIT
- WRITE !!,LRP,?31,HRCN,?45,"DOBLJPP_source.html#xB">B: ",DOBLJPP_source.html#xB">B
- QUIT
- +2 ;
- END DO V^LRU
- QUIT
