source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLS.m@ 1297

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

initial load of WorldVistAEHR

File size: 3.7 KB
RevLine 
[613]1LRBLS ;AVAMC/REG - BLOOD BANK SUPERVISOR OPTS ;12/01/95 15:30 ;
2 ;;5.2;LAB SERVICE;**97,247,267,275**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4MSB ;max surg blood order edit
5 D END I '$D(^ICPT(0)) W $C(7),!!,"Current Procedure Terminology File (#81) not installed.",! G END
6 W ! S DIC="^ICPT(",DIC("A")="Select OPERATION: ",DIC(0)="AEOQMZ",DIC("S")="I $P(^(0),U,3),$P(^DIC(81.1,$P(^DIC(81.1,$P(^ICPT(Y,0),U,3),0),U,3),0),U)=""SURGERY""" D ^DIC K DIC G:Y<1 END S (DA,X)=+Y
7 D:'$D(^LAB(66.5,X,0)) SET^LRBLPCSS F A=0:0 S A=$O(^ICPT(X,"D",A)) Q:'A W !,^(A,0)
8 W !!,"Selection OK " S %=1 D YN^LRU G:%'=1 MSB W ! S DR=1,DIE="^LAB(66.5," D ^DIE G MSB
9CR ;blood component request
10 W ! S (DIC,DIE)="^LAB(66.9,",DIC(0)="AEQLM",DLAYGO=66 D ^DIC G:Y<1 END W ! S DA=+Y,DR=".01;2;1" D ^DIE G CR
11SNO N A
12 S A(1)="This option is case sensitive."
13 S A(1,"F")="!!"
14 S A(2)="Enter data using the EXACT case of the ANTIBODY or ANTIGEN."
15 S A(3)=" "
16 D EN^DDIOL(.A)
17SNO1 S DIC="^LAB(61.3,",DIC(0)="AEMQZ"
18 S DIC("A")="Select ANTIGEN or ANTIBODY: "
19 S DIC("S")="I $P(^(0),U,5)=""AN""!($P(^(0),U,5)=""AB"")"
20 D ^DIC K DIC G:Y<1 END
21 I $D(DTOUT)!($D(DUOUT)) G END
22 S LRBLDA=+Y
23 S LRBLA=$S($P(Y(0),U,5)="AB":"ANTIBODY",1:"ANTIGEN")
24 N A
25 S A(2)=LRBLA_": "_$P(Y,U,2)
26 S A(2,"F")="!!?6"
27 S A(3)="CORRESPONDING "_$S(LRBLA="ANTIBODY":"ANTIGEN",1:"ANTIBODY")_": "_$S($P(Y(0),U,4)]"":$P(^LAB(61.3,$P(Y(0),U,4),0),U),1:"")
28 S A(3,"F")="!?6"
29 S A(4)="SNOMED CODE: "_$P(Y(0),U,2)
30 S A(4,"F")="!?6"
31 S A(5,"F")="!"
32 D EN^DDIOL(.A)
33 N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="IS THIS CORRECT"
34 D ^DIR Q:$D(DIRUT) G:Y=0 SNO1
35 ;
36 S DA=LRBLDA,DR=".04;.06;7;5",DIE=61.3 D ^DIE K DA,DIE,DR,DIC G SNO
37DES S DIC="^LAB(65.4,",DIC(0)="AEQLM",DLAYGO=65,DIC("S")="I $P(^(0),U,2)]""""" W ! D ^DIC K DIC G:X=""!(X[U) END S DA=+Y,DR=".01;.02;S Z=X;.03;S:""GC""'[Z Y=0;.04:1.9;3:99",DIE=65.4 D ^DIE K DA,DIE,DR,DIC G DES
38BBD S DIC("A")="Select BLOOD BANK DESCRIPTIONS NAME: ",DIC="^LAB(62.5,",DIC(0)="AEQLM",DLAYGO=62,DIC("S")="I ""BDRJXZ""[$P(^(0),U,4)"
39 W ! D ^DIC K DIC G:X=""!(X[U) END S DA=+Y,DR=".01;5;1;.5",DIE="^LAB(62.5," D ^DIE K DA,DIE,DR,DIC,DLAYGO G BBD
40COM W ! S (DIC,DIE)="^LAB(66,",DIC(0)="AEQLM",DLAYGO=66 D ^DIC K DIC,DLAYGO G:X=""!(X[U) END S DA=+Y,LR=$S($P(Y,U,2)["PEDIATRIC":1,1:0),DR=".01:.05;.29;10;.055:.1;9;.11:.19;S:LR Y=.23;.21:.28;1:999" D ^DIE K DA,DR,DIE,DIC G COM
41LL W ! S (DIC,DIE)="^LAB(65.9,",DIC(0)="AEQLM",DLAYGO=65 D ^DIC G:Y<1 END S DA=+Y,DR=".01:99" D ^DIE G LL
42HX S DA=$O(^LAB(65.4,"B","DNRHX",0)) G:'DA END S DIE=65.4,DR=2 D ^DIE K DIE,DR,DIC,DA Q
43DL W ! S (DIC,DIE)="^LAB(65.9,",DIC(0)="AEQLM",DLAYGO=65,DIC("S")="I ""01""[$P(^(0),U,2)" D ^DIC K DIC,DLAYGO G:Y<1 END S DA=+Y,DR=".01:99" D ^DIE G DL
44CX S DA=$O(^LAB(65.4,"B","DNRCX",0)) G:'DA END S DIE=65.4,DR=3 D ^DIE K DIE,DR,DIC,DA Q
45LRAD W ! S (DIC,DIE)=65,DIC(0)="AEQM" D ^DIC K DIC G:Y<1 END S DA=+Y,DR="[LRBLIXR]" D ^DIE K DA,DR,DIE,DIC G LRAD
46A D Z G:Y=-1 END G EN1^LRUDIT
47 ;
48SP I $S('$D(^LAB(69.9,1,8,0)):1,$P(^(0),"^",4)<8:1,1:0) D C
49 W ! D END S DIE="^LAB(69.9,",DA=1,DR=".18;8.1" D ^DIE,END
50ASK W ! S DIC="^LAB(69.9,1,8,",DIC(0)="AEQM",DIC("A")="Select BLOOD BANK DEFAULT OPTION: " D ^DIC K DIC G:Y<1 END
51 S DA=+Y,DIE="^LAB(69.9,1,8,",DR=".02:.07" D ^DIE G ASK
52 ;
53C S Y="DONOR^INVENTORY^PATIENT^INQUIRIES^REPORTS^SUPERVISOR^TEST WORKLISTS^WARD"
54 F A=1:1:8 I '$D(^LAB(69.9,1,8,A,0)) S ^(0)=$P(Y,"^",A),^LAB(69.9,1,8,"B",$P(Y,"^",A),A)=""
55 S ^LAB(69.9,1,8,0)="^69.98A^8^8" Q
56 ;
57EN D:'$D(LRAA) Z W ! S (DIC,DIE)=65.5,DIC(0)="AEQM",D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") D MIX^DIC1 K DIC G:Y<1 END S DA=+Y,DR="[LRBLDEF]" D ^DIE K DA,DR,DIE,DIC G EN
58 ;
59Z S X="BLOOD BANK" D ^LRUTL Q
60 ;
61END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.