- 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 Jan 18, 2025@03:12:55 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