LRBLJRB ;AVAMC/REG - UNIT ISSUE BOOK ;2/18/93 09:30 ;
;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
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,"^"),?28,M,?33,$P(G,"^",2),?37,V,?41,$E($P(G,"^",5),1,9),?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
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",?27,"Prod",?32,"Insp",?37,"By",?41,"Issued to",?51,"Patient",?71,"Location" W:IOM>80 ?81,"Patient SSN" W:IOM<81 !?53,"SSN" 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJRB 3359 printed Nov 22, 2024@17:21:31 Page 2
LRBLJRB ;AVAMC/REG - UNIT ISSUE BOOK ;2/18/93 09:30 ;
+1 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 WRITE !!?20,"UNIT issue book"
DO END
+4 WRITE !!,"Delete issue book entries over 31 days "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=1
DO D
+5 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,"^"),?28,M,?33,$PIECE(G,"^",2),?37,V,?41,$EXTRACT($PIECE(G,"^",5),1,9),?51,$EXTRACT($PIECE(G,"^",6),1,19),?71,$EXTRACT(L,1,8)
SET X=$PIECE(G,"^",7)
+3 IF 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,SSN
if IOM<81
WRITE !?51,SSN
+4 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 DO HDR
if LR("Q")
QUIT
WRITE !,"Mo/Da TIME",?12,"Unit ID",?27,"Prod",?32,"Insp",?37,"By",?41,"Issued to",?51,"Patient",?71,"Location"
if IOM>80
WRITE ?81,"Patient SSN"
if IOM<81
WRITE !?53,"SSN"
WRITE !,LR("%")
QUIT
+1 ;
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
