source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJCK.m@ 1259

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1LRBLJCK ;AVAMC/REG - INVENTORY ABO/RH CK ;7/30/95 15:38 ; 12/18/00 2:03pm
2 ;;5.2;LAB SERVICE;**72,247,267**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 ;
5 ; References to ^DD(65, supported by DBIA3261
6 ;
7SD S Y(1)=Y+.99,Y=Y-.0001 F T=Y:0 S T=$O(^LRD(65,"A",T)) Q:'T!(T>Y(1)) F A=0:0 S A=$O(^LRD(65,"A",T,A)) Q:'A S X=^LRD(65,A,0) I $P(X,"^",3)=LRA,$P(^LAB(66,$P(X,"^",4),0),"^",19) S ^TMP($J,$P(X,"^"),A)=""
8 Q
9ST F A=0:0 S A=$O(^LRD(65,"A",Y,A)) Q:'A S X=^LRD(65,A,0) I $P(X,"^",3)=LRA,$P(^LAB(66,$P(X,"^",4),0),"^",19) S ^TMP($J,$P(X,"^"),A)=""
10 Q
11E S (LRW(10),LRW(11))="" W !! S X=$$READ^LRBLB("UNIT ID: ") G:X=""!(X["^") END
12 I LR,$E(X,1,$L(LR(2)))=LR(2) D ^LRBLBU G:'$D(X) E
13 W:'LR $$STRIP^LRBLB(.X) ; Strip off data identifiers just in case
14 X $P(^DD(65,.01,0),"^",5,99) I $D(X),X["?" K X
15 I '$D(X) W !!,$C(7),$S($D(^DD(65,.01,3)):^(3),1:""),! X:$D(^(4)) ^(4) G E
16 S DIC=65,DIC(0)="EFMXZ",DIC("S")="I $P(^(0),U,16)=DUZ(2)" D ^DIC K DIC I Y<1 W $C(7)," (NOT IN INVENTORY FILE)" G E
17 S (DA,LRX)=+Y,DIE="^LRD(65,",DR="[LRBLIABRH]" D ^DIE D DT^LRBLU I LRCAPA D:LRW(10)]""&(LRW(10)'="ND") ABO D:LRW(11)]""&(LRW(11)'="ND") RH
18 G E
19 ;
20ABO K LRT S LRT=LRW("ABO") Q:$D(^LRD(65,LRX,99,LRT)) F A=0:0 S A=$O(LRW("ABO",A)) Q:'A S LRT(A)=""
21 D:LRCAPA ^LRBLW Q
22RH K LRT S LRT=LRW("RH") Q:$D(^LRD(65,LRX,99,LRT)) F A=0:0 S A=$O(LRW("RH",A)) Q:'A S LRT(A)=""
23 D:LRCAPA ^LRBLW Q
24EN ;
25 D V^LRU,S^LRBLW S LR("M")=1,X="BLOOD BANK" D ^LRUTL G:Y=-1 END W !!?28,"Inventory ABO/Rh check",!!?15,"Division: ",LRAA(4) K LRE Q:'$D(DUZ)#2
26 I LRCAPA F Y="ABO","RH" K LRT S X="UNIT "_Y_" RECHECK" D X^LRUWK G:'$D(X) END S LRW(Y)=LRT F A=0:0 S A=$O(LRT(A)) Q:'A S LRW(Y,A)=""
27 K LRT D BAR^LRBLB W !!,"Enter TEST COMMENT(s) " S %=2 D YN^LRU G:%<1 END S:%=1 LRQ=1
28ASK W !!?14,"1) Enter by invoice# (batch)",!?14,"2) Entry by unit ID",!,"Select 1 or 2:" R X:DTIME G:X=""!(X[U) END
29 I X<1!(X>2) W $C(7),!,"Enter a '1' to automatically request data entry for all units in a given invoice",!,"Enter a '2' to specify unit ID" G ASK
30 S DIE=("NO")="OUTOK",LR(3)="" G:X=2 E
31I W !!,"Select ",$P(^DD(65,.03,0),"^"),": " R X:DTIME G:X=""!(X[U) END S:X["?" X="?" X $P(^(0),"^",5,99) I '$D(X) W:$D(^(3)) !,^(3) X:$D(^(4)) ^(4) G I
32 S LRA=X
33 S %DT="AETX",%DT("A")="Enter date received: ",%DT(0)="-N" D ^%DT K %DT G:Y<1 END S LRB=Y
34 D WAIT^LRU D @($S(Y[".":"ST",1:"SD")) I '$D(^TMP($J)) W $C(7),!!,"There are no units in inventory for invoice# ",LRA," for " S Y=LRB D D^LRU W Y G ASK
35 D DT^LRBLU S LRD(1)=0 F LRA=0:0 S LRD(1)=$O(^TMP($J,LRD(1))) Q:LRD(1)=""!($D(LRE)) F LRD=0:0 S LRD=$O(^TMP($J,LRD(1),LRD)) Q:'LRD!($D(LRE)) D A
36 G:$D(LRE) E Q
37A S (LRW(10),LRW(11))="" W !!,LRD(1) S (DA,LRX)=LRD,DIE="^LRD(65,",DR="[LRBLIABRH]" D ^DIE I $D(Y) W !!,"WANT TO STOP LOOPING " S %=1 D YN^LRU S:%=1 LRE=1
38 I LRCAPA D:LRW(10)]""&(LRW(10)'="ND") ABO D:LRW(11)]""&(LRW(11)'="ND") RH
39 Q
40 ;
41END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.