source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJLG1.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1LRBLJLG1 ;AVAMC/REG/CYM - REVIEW UNIT LOG-IN ;11/12/96 07:41 ;
2 ;;5.2;LAB SERVICE;**72,139,247,267**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 ;References to ^DIC(4 in this routine are covered by DBIA 2508
5 Q:'$D(LRL)
6 W @IOF,P," Source: ",LRW," Invoice: ",LRI,!,"Review:",?9,"Unit",?25,"ABO/Rh",?33,"Expiration date (*=Expired or expires today)"
7 S X=0 F A=0:1 S X=$O(LRL(X)) Q:'X W !,X,")",?9,$P(LRL(X),"^",2),?25,$P(LRL(X),"^",3),?28,$P(LRL(X),"^",4),?34 S Y=$P(LRL(X),"^",5) D D^LRU W Y,$P(LRL(X),"^",6)
8 Q:'A W !!,"All OK " S %=1 D YN^LRU G:%=1&LRCAPA WRK Q:%'=2 I %=1 L -^LRD(65)
9ASK W !!,"Select (1-",A,") to Edit: " R LRE:DTIME G:LRE=""!(LRE["^") ^LRBLJLG1 I LRE'?1N.N!(LRE<1!(LRE>A)) W $C(7),! D H G ASK
10DIE S DA=+LRL(LRE),DIE="^LRD(65,",LR(65,.01)=$P(^LRD(65,DA,0),U)
11 S LRA=""
12 S DR=".01;I X["" "" W $C(7),"" No spaces. Enter '@' to delete."" S Y=.01;D CK^LRBLJLG1;S:LRF Y=.01;S LRP=X;.07;S LRABO=X;.08;S LRRH=X;.06;S LRH=X;I LRS,LRH>LRS D A^LRBLJLG1 S Y=.06"
13 D ^DIE I $D(Y) W $C(7),!,"No entering '^' during this edit !!" G DIE
14 I '$D(DA) D FIX G LRBLJLG1
15 S X=$P(^LRD(65,DA,0),U) D:X'=LR(65,.01) KK^LRBLU
16 S LRL(LRE)=DA_"^"_LRP_"^"_LRABO_"^"_LRRH_"^"_LRH_"^"_LRA_"^"_LRC
17 S:$D(^LRO(69.2,LRAA,6,DA,0)) ^(0)=LRP_"^"_LRABO_"^"_LRRH
18 K DIE,DR,DA
19 G LRBLJLG1
20 ;
21WRK F LRL=0:0 S LRL=$O(LRL(LRL)) Q:'LRL S LRX=+LRL(LRL) D ^LRBLW
22 Q
23FIX S X=+LRL(LRE) K LRL(LRE)
24 I $D(^LRO(69.2,LRAA,6,X,0)) K ^(0) S X=^LRO(69.2,LRAA,6,0),^(0)=$P(X,"^",1,2)_"^^"_($P(X,"^",4)-1)
25 K B S X=0 F A=1:1 S X=$O(LRL(X)) Q:'X S B(A)=LRL(X)
26 K LRL F A=0:0 S A=$O(B(A)) Q:'A S LRL(A)=B(A) K B(A)
27 Q
28H W " Enter a number from 1 to ",A Q
29EN ;from LRBLJLG
30 S LRB(7)=$P(^LAB(66,LRC,0),"^",17),LRB(6)="" G:'LRB(7) END
31 S LRB(3)=$P(LRK,".",2),X1=LRK,X2=$P(LRB(7),".")
32 D C^%DTC S LRB(6)=X I LRB(7)["." S Z=LRB(6)_"."_LRB(3),X="."_$P(LRB(7),".",2),Z(0)=$P(X*24*60,".") D EN^LRBLDC
33END S LRS=LRB(6) K LRB Q
34 ;
35CK S LRF=0,LRO=$P(LRL(LRE),"^",2)
36 F C=0:0 S C=$O(^LRD(65,"B",X,C)) Q:'C I C'=DA,$D(^LRD(65,C,0)),$P(^(0),"^",4)=$P(LRL(LRE),"^",7) S $P(^LRD(65,DA,0),"^")=LRO,LRF=1 W $C(7)," Sorry, that unit exists in inventory." Q
37 Q:'LRF
38 K ^LRD(65,"B",$E(X,1,30),DA)
39 S Y=^LRD(65,DA,0) I $P(Y,U,4),$P(Y,U,6) K ^LRD(65,"AI",$P(Y,U,4),X,$P(Y,U,6),DA)
40 K ^LRD(65,"AT",X) F Z=0:0 S Z=$O(^LRD(65,DA,2,Z)) Q:Z<1 K ^LRD(65,"AP",Z,DA)
41 D K^LRBLU
42 S X=LRO
43 S ^LRD(65,"B",$E(X,1,30),DA)=""
44 S Y=^LRD(65,DA,0) I $P(Y,U,4),$P(Y,U,6),$P($G(^LRD(65,DA,4)),U)="" S ^LRD(65,"AI",$P(Y,U,4),X,$P(Y,U,6),DA)=""
45 S:'$D(^LRD(65,DA,10)) (^LRD(65,"AT",X,10,DA),^LRD(65,"AT",X,11,DA))="" I '$D(^LRD(65,DA,4)) F Z=0:0 S Z=$O(^LRD(65,DA,2,Z)) Q:Z<1 S:$P(^(Z,0),U,2) ^LRD(65,"AP",Z,DA)=""
46 D S^LRBLU
47 S Y=.01 Q
48EN1 ;
49 S X=$P($G(^DIC(4,+$P(Y(0),"^",16),0)),"^") W:X]"" !,"Institution: ",X
50 I $D(^LRD(65,C,4)) S W=^(4),LRP=$P(W,"^") I LRP="R"!(LRP="S") W !!,"DISPOSITION: ",$S(LRP="S":"SENT ELSEWHERE",1:"RETURNED TO SENDER"),". Re-enter unit in inventory " S %=2 D YN^LRU Q:%'=1 S ^(4)="^^^"_$P(W,"^",4)_"^^"_$P(W,"^",6,99) G Z
51 Q
52A W $C(7),!!?4,"Expiration date exceeds allowable limit !",! Q
53 ;
54Z S:'$D(^LRD(65,C,15,0)) ^(0)="^65.15DA^^" S A=^(0),X=$P(A,"^",4),X=X+1,^(0)=$P(A,"^",1,2)_"^"_X_"^"_X
55 S Z=^LRD(65,C,0),W(5)=$P(Z,U,5),Z(4)=$P(Z,U,4),Z(6)=$P(Z,U,6),^LRD(65,C,15,X,0)=LRK_U_$P(W,U,1,3)_U_$P(Z,U,13)_U_$P(Z,U,3)_U_$P(Z,U,9)_U_$P(Z,U,5)_U_$P(W,U,5),W(11)=$P(W,U,2)
56 K:W(11) ^LRD(65,"AB",W(11),C)
57 S $P(Z,"^",5)=LRK,$P(Z,"^",9)=DUZ,$P(Z,"^",10)=$P($P(Z,"^",14),"-",2),$P(Z,"^",14)="",$P(Z,"^",3)=LRI,$P(Z,"^",13)="",^LRD(65,C,0)=Z,^LRD(65,"A",W(5),C)=""
58 I Z(4),Z(6) S ^LRD(65,"AE",Z(4),Z(6),C)="",^LRD(65,"AI",Z(4),$P(Z,"^"),Z(6),C)=""
59 Q
Note: See TracBrowser for help on using the repository browser.