LRBLS ;AVAMC/REG - BLOOD BANK SUPERVISOR OPTS ;12/01/95 15:30 ;
;;5.2;LAB SERVICE;**97,247,267,275,315,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;Reference to $$CPTD^ICPTCOD Supported by 1995
;Reference to EN^DDIOL Supported by ICR# 10142
;Reference to ^DIC Supported by ICR# 2051
;Reference to MIX^DIC1 Supported by ICR# 10007
;Reference to ^DIE Supported by ICR# 10018
;Reference to ^DIR Supported by ICR# 10026
MSB ;max surg blood order edit
Q D END I '$D(^ICPT(0)) W $C(7),!!,"Current Procedure Terminology File (#81) not installed.",! G END
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
D:'$D(^LAB(66.5,X,0)) SET^LRBLPCSS D
. N LRX
. S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX")
. I +LRX=-1 Q
. F I=1:1:LRX W !,LRX(I)
. Q
W !!,"Selection OK " S %=1 D YN^LRU G:%'=1 MSB W ! S DR=1,DIE="^LAB(66.5," D ^DIE G MSB
CR ;blood component request
Q 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
SNO Q N A
S A(1)="This option is case sensitive."
S A(1,"F")="!!"
S A(2)="Enter data using the EXACT case of the ANTIBODY or ANTIGEN."
S A(3)=" "
D EN^DDIOL(.A)
SNO1 S DIC="^LAB(61.3,",DIC(0)="AEMQZ"
S DIC("A")="Select ANTIGEN or ANTIBODY: "
S DIC("S")="I $P(^(0),U,5)=""AN""!($P(^(0),U,5)=""AB"")"
D ^DIC K DIC G:Y<1 END
I $D(DTOUT)!($D(DUOUT)) G END
S LRBLDA=+Y
S LRBLA=$S($P(Y(0),U,5)="AB":"ANTIBODY",1:"ANTIGEN")
N A
S A(2)=LRBLA_": "_$P(Y,U,2)
S A(2,"F")="!!?6"
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:"")
S A(3,"F")="!?6"
S A(4)="SNOMED CODE: "_$P(Y(0),U,2)
S A(4,"F")="!?6"
S A(5,"F")="!"
D EN^DDIOL(.A)
N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="IS THIS CORRECT"
D ^DIR Q:$D(DIRUT) G:Y=0 SNO1
;
S DA=LRBLDA,DR=".04;.06;7;5",DIE=61.3 D ^DIE K DA,DIE,DR,DIC G SNO
DES Q 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
BBD Q 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)"
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
COM Q 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
LL Q 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
HX Q 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
DL Q 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
CX Q 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
LRAD 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
A Q D Z G:Y=-1 END G EN1^LRUDIT
;
SP Q I $S('$D(^LAB(69.9,1,8,0)):1,$P(^(0),"^",4)<8:1,1:0) D C
W ! D END S DIE="^LAB(69.9,",DA=1,DR=".18;8.1" D ^DIE,END
ASK 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
S DA=+Y,DIE="^LAB(69.9,1,8,",DR=".02:.07" D ^DIE G ASK
;
C S Y="DONOR^INVENTORY^PATIENT^INQUIRIES^REPORTS^SUPERVISOR^TEST WORKLISTS^WARD"
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)=""
S ^LAB(69.9,1,8,0)="^69.98A^8^8" Q
;
EN Q 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
;
Z S X="BLOOD BANK" D ^LRUTL Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLS 4196 printed Apr 09, 2024@21:05:33 Page 2
LRBLS ;AVAMC/REG - BLOOD BANK SUPERVISOR OPTS ;12/01/95 15:30 ;
+1 ;;5.2;LAB SERVICE;**97,247,267,275,315,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;Reference to $$CPTD^ICPTCOD Supported by 1995
+4 ;Reference to EN^DDIOL Supported by ICR# 10142
+5 ;Reference to ^DIC Supported by ICR# 2051
+6 ;Reference to MIX^DIC1 Supported by ICR# 10007
+7 ;Reference to ^DIE Supported by ICR# 10018
+8 ;Reference to ^DIR Supported by ICR# 10026
MSB ;max surg blood order edit
+1 QUIT
DO END
IF '$DATA(^ICPT(0))
WRITE $CHAR(7),!!,"Current Procedure Terminology File (#81) not installed.",!
GOTO END
+2 WRITE !
SET DIC="^ICPT("
SET DIC("A")="Select OPERATION: "
SET DIC(0)="AEOQMZ"
SET 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"""
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET (DA,X)=+Y
+3 if '$DATA(^LAB(66.5,X,0))
DO SET^LRBLPCSS
Begin DoDot:1
+4 NEW LRX
+5 SET LRX=X
SET LRX=$$CPTD^ICPTCOD(LRX,"LRX")
+6 IF +LRX=-1
QUIT
+7 FOR I=1:1:LRX
WRITE !,LRX(I)
+8 QUIT
End DoDot:1
+9 WRITE !!,"Selection OK "
SET %=1
DO YN^LRU
if %'=1
GOTO MSB
WRITE !
SET DR=1
SET DIE="^LAB(66.5,"
DO ^DIE
GOTO MSB
CR ;blood component request
+1 QUIT
WRITE !
SET (DIC,DIE)="^LAB(66.9,"
SET DIC(0)="AEQLM"
SET DLAYGO=66
DO ^DIC
if Y<1
GOTO END
WRITE !
SET DA=+Y
SET DR=".01;2;1"
DO ^DIE
GOTO CR
SNO QUIT
NEW A
+1 SET A(1)="This option is case sensitive."
+2 SET A(1,"F")="!!"
+3 SET A(2)="Enter data using the EXACT case of the ANTIBODY or ANTIGEN."
+4 SET A(3)=" "
+5 DO EN^DDIOL(.A)
SNO1 SET DIC="^LAB(61.3,"
SET DIC(0)="AEMQZ"
+1 SET DIC("A")="Select ANTIGEN or ANTIBODY: "
+2 SET DIC("S")="I $P(^(0),U,5)=""AN""!($P(^(0),U,5)=""AB"")"
+3 DO ^DIC
KILL DIC
if Y<1
GOTO END
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
+5 SET LRBLDA=+Y
+6 SET LRBLA=$SELECT($PIECE(Y(0),U,5)="AB":"ANTIBODY",1:"ANTIGEN")
+7 NEW A
+8 SET A(2)=LRBLA_": "_$PIECE(Y,U,2)
+9 SET A(2,"F")="!!?6"
+10 SET A(3)="CORRESPONDING "_$SELECT(LRBLA="ANTIBODY":"ANTIGEN",1:"ANTIBODY")_": "_$SELECT($PIECE(Y(0),U,4)]"":$PIECE(^LAB(61.3,$PIECE(Y(0),U,4),0),U),1:"")
+11 SET A(3,"F")="!?6"
+12 SET A(4)="SNOMED CODE: "_$PIECE(Y(0),U,2)
+13 SET A(4,"F")="!?6"
+14 SET A(5,"F")="!"
+15 DO EN^DDIOL(.A)
+16 NEW DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="IS THIS CORRECT"
+17 DO ^DIR
if $DATA(DIRUT)
QUIT
if Y=0
GOTO SNO1
+18 ;
+19 SET DA=LRBLDA
SET DR=".04;.06;7;5"
SET DIE=61.3
DO ^DIE
KILL DA,DIE,DR,DIC
GOTO SNO
DES QUIT
SET DIC="^LAB(65.4,"
SET DIC(0)="AEQLM"
SET DLAYGO=65
SET DIC("S")="I $P(^(0),U,2)]"""""
WRITE !
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO END
SET DA=+Y
SET DR=".01;.02;S Z=X;.03;S:""GC""'[Z Y=0;.04:1.9;3:99"
SET DIE=65.4
DO ^DIE
KILL DA,DIE,DR,DIC
GOTO DES
BBD QUIT
SET DIC("A")="Select BLOOD BANK DESCRIPTIONS NAME: "
SET DIC="^LAB(62.5,"
SET DIC(0)="AEQLM"
SET DLAYGO=62
SET DIC("S")="I ""BDRJXZ""[$P(^(0),U,4)"
+1 WRITE !
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO END
SET DA=+Y
SET DR=".01;5;1;.5"
SET DIE="^LAB(62.5,"
DO ^DIE
KILL DA,DIE,DR,DIC,DLAYGO
GOTO BBD
COM QUIT
WRITE !
SET (DIC,DIE)="^LAB(66,"
SET DIC(0)="AEQLM"
SET DLAYGO=66
DO ^DIC
KILL DIC,DLAYGO
if X=""!(X[U)
GOTO END
SET DA=+Y
SET LR=$SELECT($PIECE(Y,U,2)["PEDIATRIC":1,1:0)
SET DR=".01:.05;.29;10;.055:.1;9;.11:.19;S:LR Y=.23;.21:.28;1:999"
DO ^DIE
KILL DA,DR,DIE,DIC
GOTO COM
LL QUIT
WRITE !
SET (DIC,DIE)="^LAB(65.9,"
SET DIC(0)="AEQLM"
SET DLAYGO=65
DO ^DIC
if Y<1
GOTO END
SET DA=+Y
SET DR=".01:99"
DO ^DIE
GOTO LL
HX QUIT
SET DA=$ORDER(^LAB(65.4,"B","DNRHX",0))
if 'DA
GOTO END
SET DIE=65.4
SET DR=2
DO ^DIE
KILL DIE,DR,DIC,DA
QUIT
DL QUIT
WRITE !
SET (DIC,DIE)="^LAB(65.9,"
SET DIC(0)="AEQLM"
SET DLAYGO=65
SET DIC("S")="I ""01""[$P(^(0),U,2)"
DO ^DIC
KILL DIC,DLAYGO
if Y<1
GOTO END
SET DA=+Y
SET DR=".01:99"
DO ^DIE
GOTO DL
CX QUIT
SET DA=$ORDER(^LAB(65.4,"B","DNRCX",0))
if 'DA
GOTO END
SET DIE=65.4
SET DR=3
DO ^DIE
KILL DIE,DR,DIC,DA
QUIT
LRAD WRITE !
SET (DIC,DIE)=65
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET DA=+Y
SET DR="[LRBLIXR]"
DO ^DIE
KILL DA,DR,DIE,DIC
GOTO LRAD
A QUIT
DO Z
if Y=-1
GOTO END
GOTO EN1^LRUDIT
+1 ;
SP QUIT
IF $SELECT('$DATA(^LAB(69.9,1,8,0)):1,$PIECE(^(0),"^",4)<8:1,1:0)
DO C
+1 WRITE !
DO END
SET DIE="^LAB(69.9,"
SET DA=1
SET DR=".18;8.1"
DO ^DIE
DO END
ASK WRITE !
SET DIC="^LAB(69.9,1,8,"
SET DIC(0)="AEQM"
SET DIC("A")="Select BLOOD BANK DEFAULT OPTION: "
DO ^DIC
KILL DIC
if Y<1
GOTO END
+1 SET DA=+Y
SET DIE="^LAB(69.9,1,8,"
SET DR=".02:.07"
DO ^DIE
GOTO ASK
+2 ;
C SET Y="DONOR^INVENTORY^PATIENT^INQUIRIES^REPORTS^SUPERVISOR^TEST WORKLISTS^WARD"
+1 FOR A=1:1:8
IF '$DATA(^LAB(69.9,1,8,A,0))
SET ^(0)=$PIECE(Y,"^",A)
SET ^LAB(69.9,1,8,"B",$PIECE(Y,"^",A),A)=""
+2 SET ^LAB(69.9,1,8,0)="^69.98A^8^8"
QUIT
+3 ;
EN QUIT
if '$DATA(LRAA)
DO Z
WRITE !
SET (DIC,DIE)=65.5
SET DIC(0)="AEQM"
SET D="B^C^"_$SELECT("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D")
DO MIX^DIC1
KILL DIC
if Y<1
GOTO END
SET DA=+Y
SET DR="[LRBLDEF]"
DO ^DIE
KILL DA,DR,DIE,DIC
GOTO EN
+1 ;
Z SET X="BLOOD BANK"
DO ^LRUTL
QUIT
+1 ;
END DO V^LRU
QUIT
