- LRBLJRB ; IHS/DIR/FJE - UNIT ISSUE BOOK 2/18/93 09:30 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- W !!?20,"UNIT issue book" D END
- W !!,"Delete issue book entries over 31 days " S %=2 D YN^LRU G:%<1 END D:%=1 D
- W !!?15,"1. Print issue book entries by date",!?15,"2. Print issue book entries by patient"
- ASK R !,"Select 1 or 2: ",LRA:DTIME G:LRA["^"!(LRA="") END I LRA<1!(LRA>2) W $C(7)," Enter a '1' or '2'.",! G ASK
- D ^LRU S %DT="AETX",%DT(0)="-N",%DT("A")="Start with Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
- G:Y<1 END S LRSDT=Y
- S %DT="AETX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
- G:Y<1 END S LRLDT=Y D D^LRU S LRLST=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
- S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y
- S LRSDT=LRSDT-.0001 S:LRLDT'["." LRLDT=LRLDT+.99
- S ZTRTN="QUE^LRBLJRB" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) D L^LRU,S^LRU,H1 S LR("F")=1
- S A=LRSDT F E=0:0 S A=$O(^LRD(65,"AL",A)) Q:'A!(A>LRLDT) S B=0 F F=0:0 S B=$O(^LRD(65,"AL",A,B)) Q:'B S C=9999999-A D W
- K G S J=0 F I=0:0 S J=$O(^TMP($J,J)) Q:J=""!(LR("Q")) S A=0 F LRA=0:0 S A=$O(^TMP($J,J,A)) Q:A=""!(LR("Q")) F B=0:0 S B=$O(^TMP($J,J,A,B)) Q:'B!(LR("Q")) S C=^(B) D X
- Q:LR("Q") D SUM W:IOST'?1"C".E @IOF D END^LRUTL,END Q
- X S W=^LRD(65,B,0),G=^(3,C,0),T=+G D T S L=$P(G,"^",4),M=$P(^LAB(66,$P(W,"^",4),0),"^",2),V=$P(G,"^",3) S:V="" V="?" S V=$S($D(^VA(200,V,0)):$P(^(0),"^",2),1:V)
- D:$Y>(IOSL-6) H1 Q:LR("Q")
- W !,T,?12,$P(W,"^"),?25,M,?30,$P(G,"^",2),?34,V,?38,$E($P(G,"^",5),1,12),?51,$E($P(G,"^",6),1,19),?71,$E(L,1,8) S X=$P(G,"^",7)
- ;I X S X=$S($D(^DPT(X,0)):$P(^(0),"^",9),1:"") I X]"" S LRDPF=2,SSN=X D SSN^LRU W:IOM>80 ?81,SSN W:IOM<81 !?51,SSN
- I X S DFN=X,X=$S($D(^DPT(X,0)):$P(^(0),"^",9),1:"") I X]"" S LRDPF=2,SSN=X D SSN^LRU W:IOM>80 ?81,HRCN W:IOM<81 !?51,HRCN ;IHS/ANMC/CLS 11/1/95
- S:L="" L="UNKNOWN" S:'$D(G(L)) G(L)=0 S G(L)=G(L)+1 S:'$D(G(L,M)) G(L,M)=0 S G(L,M)=G(L,M)+1 Q
- T S T=T_"000",T=$E(T,4,5)_"/"_$E(T,6,7)_$S(T[".":" "_$E(T,9,10)_":"_$E(T,11,12),1:"") Q
- W I '$D(^LRD(65,B,3,C,0)) K ^LRD(65,"AL",C,B) Q
- I LRA=1 S ^TMP($J,"B",A,B)=C Q
- S G=^LRD(65,B,3,C,0),G(6)=$S($P(G,"^",6)]"":$P(G,"^",6),1:"?"),^TMP($J,G(6),A,B)=C Q
- HDR I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"TRANSFUSION SERVICE Unit issue book" Q
- ;
- H1 ;D HDR Q:LR("Q") W !,"Mo/Da TIME",?12,"Unit ID",?24,"Prod",?29,"Insp",?34,"By",?38,"Issued to",?51,"Patient",?71,"Location" W:IOM>80 ?81,"Patient SSN" W:IOM<81 !?53,"SSN" W !,LR("%") Q
- D HDR Q:LR("Q") W !,"Mo/Da TIME",?12,"Unit ID",?24,"Prod",?29,"Insp",?34,"By",?38,"Issued to",?51,"Patient",?71,"Location" W:IOM>80 ?81,"Patient HRCN" W:IOM<81 !?53,"HRCN" W !,LR("%") Q
- ;
- D S X="T-31",%DT="" D ^%DT F A=0:0 S A=$O(^LRD(65,"AL",A)) Q:'A!(A>Y) K ^LRD(65,"AL",A) W "."
- W $C(7),!!,"Deletion completed.",! Q
- SUM D H Q:LR("Q") S Z=-1,T=0 F A=1:1 S Z=$O(G(Z)) Q:Z=""!(LR("Q")) S T=T+G(Z) D A
- W !,"-----------------------------------------",!,"Totals",?36,$J(T,5)
- S L=-1 F A=0:0 S L=$O(L(L)) Q:L=""!(LR("Q")) W !?8,L,?20,$J(L(L),5) S X=$O(^LAB(66,"B",L,0)) W:X " (",$P(^LAB(66,X,0),"^"),")" D G:$D(G("BLOOD BANK",L)) D:$Y>(IOSL-6) H Q:LR("Q")
- Q
- A D:$Y>(IOSL-6) H Q:LR("Q") W !,$J(A,2),".)",?6,Z,?36,$J(G(Z),5) S M=-1 F B=0:0 S M=$O(G(Z,M)) Q:M=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W !?8,M,?20,$J(G(Z,M),5) S:'$D(L(M)) L(M)=0 S L(M)=L(M)+G(Z,M)
- Q
- G S X=G("BLOOD BANK",L),Y=L(L)-X I X,Y,X<Y W ?(IOM-15),$J(X*100/Y,4,1),"% returned"
- Q
- H D HDR Q:LR("Q") W !,"Unit counts by location from ",LRSTR," to ",LRLST,!,LR("%") Q
- ;
- END D V^LRU Q
- LRBLJRB ; IHS/DIR/FJE - UNIT ISSUE BOOK 2/18/93 09:30 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 WRITE !!?20,"UNIT issue book"
- DO END
- +5 WRITE !!,"Delete issue book entries over 31 days "
- SET %=2
- DO YN^LRU
- IF %<1
- GOTO END
- IF %=1
- DO D
- +6 WRITE !!?15,"1. Print issue book entries by date",!?15,"2. Print issue book entries by patient"
- ASK READ !,"Select 1 or 2: ",LRA:DTIME
- IF LRA["^"!(LRA="")
- GOTO END
- IF LRA<1!(LRA>2)
- WRITE $CHAR(7)," Enter a '1' or '2'.",!
- GOTO ASK
- +1 DO ^LRU
- SET %DT="AETX"
- SET %DT(0)="-N"
- SET %DT("A")="Start with Date TODAY// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET Y=DT
- WRITE H(10)
- +2 IF Y<1
- GOTO END
- SET LRSDT=Y
- +3 SET %DT="AETX"
- SET %DT("A")="Go to Date TODAY// "
- DO ^%DT
- KILL %DT
- IF X=""
- SET Y=DT
- WRITE H(10)
- +4 IF Y<1
- GOTO END
- SET LRLDT=Y
- DO D^LRU
- SET LRLST=Y
- IF LRSDT>LRLDT
- SET X=LRSDT
- SET LRSDT=LRLDT
- SET LRLDT=X
- +5 SET Y=LRSDT
- DO D^LRU
- SET LRSTR=Y
- SET Y=LRLDT
- DO D^LRU
- SET LRLST=Y
- +6 SET LRSDT=LRSDT-.0001
- IF LRLDT'["."
- SET LRLDT=LRLDT+.99
- +7 SET ZTRTN="QUE^LRBLJRB"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- DO L^LRU
- DO S^LRU
- DO H1
- SET LR("F")=1
- +1 SET A=LRSDT
- FOR E=0:0
- SET A=$ORDER(^LRD(65,"AL",A))
- IF 'A!(A>LRLDT)
- QUIT
- SET B=0
- FOR F=0:0
- SET B=$ORDER(^LRD(65,"AL",A,B))
- IF 'B
- QUIT
- SET C=9999999-A
- DO W
- +2 KILL G
- SET J=0
- FOR I=0:0
- SET J=$ORDER(^TMP($JOB,J))
- IF J=""!(LR("Q"))
- QUIT
- SET A=0
- FOR LRA=0:0
- SET A=$ORDER(^TMP($JOB,J,A))
- IF A=""!(LR("Q"))
- QUIT
- FOR B=0:0
- SET B=$ORDER(^TMP($JOB,J,A,B))
- IF 'B!(LR("Q"))
- QUIT
- SET C=^(B)
- DO X
- +3 IF LR("Q")
- QUIT
- DO SUM
- IF IOST'?1"C".E
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- X SET W=^LRD(65,B,0)
- SET G=^(3,C,0)
- SET T=+G
- DO T
- SET L=$PIECE(G,"^",4)
- SET M=$PIECE(^LAB(66,$PIECE(W,"^",4),0),"^",2)
- SET V=$PIECE(G,"^",3)
- IF V=""
- SET V="?"
- SET V=$SELECT($DATA(^VA(200,V,0)):$PIECE(^(0),"^",2),1:V)
- +1 IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- +2 WRITE !,T,?12,$PIECE(W,"^"),?25,M,?30,$PIECE(G,"^",2),?34,V,?38,$EXTRACT($PIECE(G,"^",5),1,12),?51,$EXTRACT($PIECE(G,"^",6),1,19),?71,$EXTRACT(L,1,8)
- SET X=$PIECE(G,"^",7)
- +3 ;I X S X=$S($D(^DPT(X,0)):$P(^(0),"^",9),1:"") I X]"" S LRDPF=2,SSN=X D SSN^LRU W:IOM>80 ?81,SSN W:IOM<81 !?51,SSN
- +4 ;IHS/ANMC/CLS 11/1/95
- IF X
- SET DFN=X
- SET X=$SELECT($DATA(^DPT(X,0)):$PIECE(^(0),"^",9),1:"")
- IF X]""
- SET LRDPF=2
- SET SSN=X
- DO SSN^LRU
- IF IOM>80
- WRITE ?81,HRCN
- IF IOM<81
- WRITE !?51,HRCN
- +5 IF L=""
- SET L="UNKNOWN"
- IF '$DATA(G(L))
- SET G(L)=0
- SET G(L)=G(L)+1
- IF '$DATA(G(L,M))
- SET G(L,M)=0
- SET G(L,M)=G(L,M)+1
- QUIT
- T SET T=T_"000"
- SET T=$EXTRACT(T,4,5)_"/"_$EXTRACT(T,6,7)_$SELECT(T[".":" "_$EXTRACT(T,9,10)_":"_$EXTRACT(T,11,12),1:"")
- QUIT
- W IF '$DATA(^LRD(65,B,3,C,0))
- KILL ^LRD(65,"AL",C,B)
- QUIT
- +1 IF LRA=1
- SET ^TMP($JOB,"B",A,B)=C
- QUIT
- +2 SET G=^LRD(65,B,3,C,0)
- SET G(6)=$SELECT($PIECE(G,"^",6)]"":$PIECE(G,"^",6),1:"?")
- SET ^TMP($JOB,G(6),A,B)=C
- QUIT
- HDR IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"TRANSFUSION SERVICE Unit issue book"
- QUIT
- +2 ;
- H1 ;D HDR Q:LR("Q") W !,"Mo/Da TIME",?12,"Unit ID",?24,"Prod",?29,"Insp",?34,"By",?38,"Issued to",?51,"Patient",?71,"Location" W:IOM>80 ?81,"Patient SSN" W:IOM<81 !?53,"SSN" W !,LR("%") Q
- +1 DO HDR
- IF LR("Q")
- QUIT
- WRITE !,"Mo/Da TIME",?12,"Unit ID",?24,"Prod",?29,"Insp",?34,"By",?38,"Issued to",?51,"Patient",?71,"Location"
- IF IOM>80
- WRITE ?81,"Patient HRCN"
- IF IOM<81
- WRITE !?53,"HRCN"
- WRITE !,LR("%")
- QUIT
- +2 ;
- D SET X="T-31"
- SET %DT=""
- DO ^%DT
- FOR A=0:0
- SET A=$ORDER(^LRD(65,"AL",A))
- IF 'A!(A>Y)
- QUIT
- KILL ^LRD(65,"AL",A)
- WRITE "."
- +1 WRITE $CHAR(7),!!,"Deletion completed.",!
- QUIT
- SUM DO H
- IF LR("Q")
- QUIT
- SET Z=-1
- SET T=0
- FOR A=1:1
- SET Z=$ORDER(G(Z))
- IF Z=""!(LR("Q"))
- QUIT
- SET T=T+G(Z)
- DO A
- +1 WRITE !,"-----------------------------------------",!,"Totals",?36,$JUSTIFY(T,5)
- +2 SET L=-1
- FOR A=0:0
- SET L=$ORDER(L(L))
- IF L=""!(LR("Q"))
- QUIT
- WRITE !?8,L,?20,$JUSTIFY(L(L),5)
- SET X=$ORDER(^LAB(66,"B",L,0))
- IF X
- WRITE " (",$PIECE(^LAB(66,X,0),"^"),")"
- IF $DATA(G("BLOOD BANK",L))
- DO G
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- +3 QUIT
- A IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !,$JUSTIFY(A,2),".)",?6,Z,?36,$JUSTIFY(G(Z),5)
- SET M=-1
- FOR B=0:0
- SET M=$ORDER(G(Z,M))
- IF M=""!(LR("Q"))
- QUIT
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !?8,M,?20,$JUSTIFY(G(Z,M),5)
- IF '$DATA(L(M))
- SET L(M)=0
- SET L(M)=L(M)+G(Z,M)
- +1 QUIT
- G SET X=G("BLOOD BANK",L)
- SET Y=L(L)-X
- IF X
- IF Y
- IF X<Y
- WRITE ?(IOM-15),$JUSTIFY(X*100/Y,4,1),"% returned"
- +1 QUIT
- H DO HDR
- IF LR("Q")
- QUIT
- WRITE !,"Unit counts by location from ",LRSTR," to ",LRLST,!,LR("%")
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
