source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJRB.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1LRBLJRB ;AVAMC/REG - UNIT ISSUE BOOK ;2/18/93 09:30 ;
2 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 W !!?20,"UNIT issue book" D END
5 W !!,"Delete issue book entries over 31 days " S %=2 D YN^LRU G:%<1 END D:%=1 D
6 W !!?15,"1. Print issue book entries by date",!?15,"2. Print issue book entries by patient"
7ASK 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
8 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)
9 G:Y<1 END S LRSDT=Y
10 S %DT="AETX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
11 G:Y<1 END S LRLDT=Y D D^LRU S LRLST=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
12 S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y
13 S LRSDT=LRSDT-.0001 S:LRLDT'["." LRLDT=LRLDT+.99
14 S ZTRTN="QUE^LRBLJRB" D BEG^LRUTL G:POP!($D(ZTSK)) END
15QUE U IO K ^TMP($J) D L^LRU,S^LRU,H1 S LR("F")=1
16 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
17 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
18 Q:LR("Q") D SUM W:IOST'?1"C".E @IOF D END^LRUTL,END Q
19X 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)
20 D:$Y>(IOSL-6) H1 Q:LR("Q")
21 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)
22 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
23 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
24T 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
25W I '$D(^LRD(65,B,3,C,0)) K ^LRD(65,"AL",C,B) Q
26 I LRA=1 S ^TMP($J,"B",A,B)=C Q
27 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
28HDR I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
29 D F^LRU W !,"TRANSFUSION SERVICE Unit issue book" Q
30 ;
31H1 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
32 ;
33D 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 "."
34 W $C(7),!!,"Deletion completed.",! Q
35SUM 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
36 W !,"-----------------------------------------",!,"Totals",?36,$J(T,5)
37 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")
38 Q
39A 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)
40 Q
41G 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"
42 Q
43H D HDR Q:LR("Q") W !,"Unit counts by location from ",LRSTR," to ",LRLST,!,LR("%") Q
44 ;
45END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.