LRBLPED ;AVAMC/REG/CRT - PEDIATRIC UNIT PREPARATION ;7/30/95 15:36 ; 12/18/00 2:19pm
;;5.2;LAB SERVICE;**72,247,267,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;
; References to ^DD(65, and ^DD(66, are supported in DBIA3261
;
Q D END S LR("M")=1,X="BLOOD BANK" D ^LRUTL G:Y=-1 END S %DT="T",X="N" D ^%DT S LRN=Y,LRM=$P(Y,".") W !?15,"Division: ",LRAA(4)
I LRCAPA S X="PEDIATRIC UNIT PREPARATION",X("NOCODES")=1 D X^LRUWK G:'$D(X) END K X
S LR(3)="" D BAR^LRBLB
P W !! S X=$$READ^LRBLB("Blood component for pediatric prep: ") G:X=""!(X["^") END I X=" " W $C(7)," SPACE BAR not allowed." G P
I LR,$E(X,1,$L(LR(2)))=LR(2) D
.D P^LRBLB
E W $$STRIP^LRBLB(.X) ; Strip off the data identifiers just in case
I '$D(X) W $C(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",! G P
S DIC=66,DIC(0)="EQMZ",DIC("S")="I $$SCRN^LRBLPED" D ^DIC K DIC G:X["?" P I Y<1 W $C(7),!,"Either not an entry in BLOOD COMPONENT FILE (#66) or",!,"Must enter MAX AGE FOR PEDIATRIC USE field for the entry in file 66." G P
S X=0,LRO=+$P(Y(0),U,22) I 'LRO!('$D(^LAB(66,LRO,0))) W $C(7),!,$P(^DD(66,.22,0),U)," must be entered for this component",!,"and pediatric product selection must be an entry in the Blood Product file." S X=1
I '$P(Y(0),U,23) W $C(7),!,$P(^DD(66,.23,0),U)," must be entered for this component" S X=1
G:X P S LRC=+Y F A=0:0 S A=$O(^LAB(66,LRO,9,A)) Q:'A S LRT(A)=""
I LRCAPA,$D(LRT)'=11 W $C(7),!!,"Must have WKLD codes entered in Blood Product file for ",$P(^LAB(66,LRO,0),U) G END
S LRD=$P(Y(0),U,17),LRZ=$P(^LAB(66,$P(Y(0),U,22),0),U,18),LRP=$P(Y(0),U,22),LRA=-(LRD-$P(Y(0),U,21)),LRV=$P(Y(0),U,10),LRV(.4)=LRV*.4\1,LRV(.6)=LRV*.6\1,LRS=$P(Y(0),U,23),LR(66,.135)=$P(^LAB(66,LRO,0),U,17)
I 'LRV W $C(7),!!,"Volume of component must be entered in BLOOD COMPONENT file",!?20,"for ",$P(Y,U,2),"." G P
U K LRF,Z S Z=0 W !! S X=$$READ^LRBLB("Select UNIT: ") G:X=""!(X[U) END I X["?"!(X[" ")!(X'?.ANP) D H G U
I LR,$E(X,1,$L(LR(2)))=LR(2) D
.D ^LRBLBU
E W $$STRIP^LRBLB(.X) ; Strip off the data identifiers just in case
G:'$D(X) U
S DIC=65,DIC(0)="EQM",DIC("W")="W "" "",$P(^(0),U)",DIC("S")="I $P(^(0),U,16)=DUZ(2),$P(^(0),U,4)=LRC,$S('$D(^(4)):1,$P(^(4),U)="""":1,1:0)" D ^DIC K DIC G:Y<1 U S X=$P(^LRD(65,+Y,0),U)
S LRP=$$LRP(+Y)
I LRP=0 G U
S LRJ=X D ALL G P
ALL S Q=$O(^LRD(65,"AI",LRC,LRJ,0)) I Q S A=LRJ,Q=$O(^LRD(65,"AI",LRC,A,0)) Q:'Q W !?3 D I G:$D(LRF) ^LRBLPED1
K ^TMP($J) W !?3 S A(2)="",Z(1)=1,A=LRJ D D G ^LRBLPED1:$D(LRF) I A(2)?1P W $C(7) Q
I LRJ'["E",LRJ=+LRJ,+$O(^LRD(65,"AI",LRJ))=X S A=LRJ_"?" D D
G ^LRBLPED1:$D(LRF) W $C(7) Q
;
H I '$D(^LRD(65,"AI",LRC)) W $C(7),!!,"No units to choose from !",! Q
I X'["??" W !,"ANSWER WITH ",$P(^DD(65,.01,0),U),!,"DO YOU WANT THE ENTIRE ",$P(^LRD(65,0),U)," LIST ? " S %="" D RX^LRU Q:%'=1
S (A,A(2))=0,A(1)=$Y+21 W !?3 F B=0:0 S A=$O(^LRD(65,"AI",LRC,A)) Q:A="" F Q=0:0 S Q=$O(^LRD(65,"AI",LRC,A,Q)) Q:'Q D:$Y>A(1)!'$Y MORE Q:A(2)?1P D I
Q
I I Q[".",Q<LRN K ^LRD(65,"AI",LRC,A,Q) Q
I Q<LRM K ^LRD(65,"AI",LRC,A,Q) Q
S V=$O(^LRD(65,"AI",LRC,A,Q,0)) I $D(^LRD(65,V,4)),$P(^(4),"^")]"" K ^LRD(65,"AI",LRC,A,Q,V) Q
I $D(^LRD(65,V,8)),+^(8) Q
Q:'$D(^LRD(65,V,0)) S LRF=V_"^"_^(0) D OK Q:'$D(LRF)
S Z=Z+1 W:$D(Z(1)) $J(Z,2) W ?7,$P(LRF,"^",2),?20,$J($P(LRF,"^",8),2)," ",$P(LRF,"^",9) S (LRE,Y)=$P(LRF,"^",7) D DT^LRU W ?28,Y
W $J($S(LRB=0:"<1",1:LRB),4)," ",$S(LRB>1:"DAYS",1:"DAY ")," OLD ",$J($P(LRF,"^",12),3) W:'$P(LRF,"^",12)&($P(LRF,"^",12)'=0) " ? " W " ml"
W !?3 Q
;
D K LRF F B=0:0 S A=+$O(^LRD(65,"AI",LRC,A)) Q:$E(A,1,$L(LRJ))'=LRJ F Q=0:0 S Q=$O(^LRD(65,"AI",LRC,A,Q)) Q:'Q!($A(A)>122) D I I $D(LRF) S ^TMP($J,Z)=LRF K LRF I Z#5=0 D C Q:A(2)?1P
D:Z#5&('$D(LRF)) C Q
;
OK S O=0 F O(1)=0:0 S O=$O(^LRD(65,V,2,O)) Q:'O I $D(^LRD(65,"AP",O,V)) Q
I O>0 K LRF Q
S X1=$P(LRF,"^",7),X2=LRA D C^%DTC I X<LRM K LRF Q
S X1=$P(LRF,"^",7),X2=-LRD D C^%DTC S X1=LRM,X2=X D ^%DTC S LRB=X Q
;
MORE R "'^' TO STOP: ",A(2):DTIME I A(2)?1P S A=$C(126) Q
S A(1)=A(1)+21 S:$Y<22 A(1)=$Y+21 W $C(13),$J("",15),$C(13),?3 Q
C I Z=1 S A(2)=1 G F
W $C(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z R ": ",A(2):DTIME I A(2)?1P!'$T S A=$C(126) Q
I A(2)="" W !?3 Q
F I A(2)>0,A(2)<(Z+1) S LRF=^TMP($J,A(2))
S A(2)="^",A=$C(126) Q
END D V^LRU Q
;
SCRN() ; Screen for BLOOD PRODUCT file (#66)
;
N X,PCODE,PEDICODE,ANS
;
S ANS=0
S X=^(0) ; from ^LAB(66,X,0)
S PCODE=$P(X,U,5)
;
I $P(X,U,21) S ANS=1 ; Max Age for Pediatric Product field defined
I $P(X,U,29) D ; ISBT-128
.I '$P(X,U,22) S ANS=0 Q ;No Pediatric Product defined
.I $E(PCODE,($L(PCODE)-1),$L(PCODE))'="00" S ANS=0 Q
.S PEDICODE=$$GET1^DIQ(66,$P(X,U,22),.05)
.; Pediatric Product Code must end in alpha+0
.I $E(PEDICODE,($L(PEDICODE)-1),$L(PEDICODE))'?1A1"0" S ANS=0
Q ANS
;
LRP(DA) ; Find & return Product Code to be used for next child
;
; INPUT: DA = IEN of PARENT UNIT RECORD on File #65
; OUTPUT: LRP = IEN of Child Product Code (file #66) if ISBT-1128
; or IEN of Parent Product Code (file #66) if Codabar
; or 0 if invalid.
;
N LRBLAST,LRBLBP,LRBLSFX,LRP,LRBLPC
;
S B=0
;
Q:'$$GET1^DIQ(65,DA,".04:.29","I") $$GET1^DIQ(65,+DA,".04:.22","I") ; not ISBT-128, return the IEN of
; ; the pediatric type for the product
S LRBLPC=$$GET1^DIQ(65,+DA,".04:.05") ; Parent Product Code
;
S LRBLAST=$O(^LRD(65,+DA,16,""),-1)
I LRBLAST>25 S B=91
S LRBLSFX=$E("ABCDEFGHIJKLMNOPQRSTUVWXYZ",LRBLAST+1)_"0"
S LRBLBP=$E(LRBLPC,1,$L(LRBLPC)-2)_LRBLSFX
S LRP=$O(^LAB(66,"D",LRBLBP,0))
I 'LRP D Q 0
.D EN^DDIOL("Pediatric Preparation cannot proceed with this unit until another","","!!")
.D EN^DDIOL("record is created for this product type in the BLOOD PRODUCT file.","","!")
Q LRP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPED 5949 printed Nov 22, 2024@17:21:56 Page 2
LRBLPED ;AVAMC/REG/CRT - PEDIATRIC UNIT PREPARATION ;7/30/95 15:36 ; 12/18/00 2:19pm
+1 ;;5.2;LAB SERVICE;**72,247,267,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;
+4 ; References to ^DD(65, and ^DD(66, are supported in DBIA3261
+5 ;
+6 QUIT
DO END
SET LR("M")=1
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
SET %DT="T"
SET X="N"
DO ^%DT
SET LRN=Y
SET LRM=$PIECE(Y,".")
WRITE !?15,"Division: ",LRAA(4)
+7 IF LRCAPA
SET X="PEDIATRIC UNIT PREPARATION"
SET X("NOCODES")=1
DO X^LRUWK
if '$DATA(X)
GOTO END
KILL X
+8 SET LR(3)=""
DO BAR^LRBLB
P WRITE !!
SET X=$$READ^LRBLB("Blood component for pediatric prep: ")
if X=""!(X["^")
GOTO END
IF X=" "
WRITE $CHAR(7)," SPACE BAR not allowed."
GOTO P
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
Begin DoDot:1
+2 DO P^LRBLB
End DoDot:1
+3 ; Strip off the data identifiers just in case
IF '$TEST
WRITE $$STRIP^LRBLB(.X)
+4 IF '$DATA(X)
WRITE $CHAR(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",!
GOTO P
+5 SET DIC=66
SET DIC(0)="EQMZ"
SET DIC("S")="I $$SCRN^LRBLPED"
DO ^DIC
KILL DIC
if X["?"
GOTO P
IF Y<1
WRITE $CHAR(7),!,"Either not an entry in BLOOD COMPONENT FILE (#66) or",!,"Must enter MAX AGE FOR PEDIATRIC USE field for the entry in file 66."
GOTO P
+6 SET X=0
SET LRO=+$PIECE(Y(0),U,22)
IF 'LRO!('$DATA(^LAB(66,LRO,0)))
WRITE $CHAR(7),!,$PIECE(^DD(66,.22,0),U)," must be entered for this component",!,"and pediatric product selection must be an entry in the Blood Product file."
SET X=1
+7 IF '$PIECE(Y(0),U,23)
WRITE $CHAR(7),!,$PIECE(^DD(66,.23,0),U)," must be entered for this component"
SET X=1
+8 if X
GOTO P
SET LRC=+Y
FOR A=0:0
SET A=$ORDER(^LAB(66,LRO,9,A))
if 'A
QUIT
SET LRT(A)=""
+9 IF LRCAPA
IF $DATA(LRT)'=11
WRITE $CHAR(7),!!,"Must have WKLD codes entered in Blood Product file for ",$PIECE(^LAB(66,LRO,0),U)
GOTO END
+10 SET LRD=$PIECE(Y(0),U,17)
SET LRZ=$PIECE(^LAB(66,$PIECE(Y(0),U,22),0),U,18)
SET LRP=$PIECE(Y(0),U,22)
SET LRA=-(LRD-$PIECE(Y(0),U,21))
SET LRV=$PIECE(Y(0),U,10)
SET LRV(.4)=LRV*.4\1
SET LRV(.6)=LRV*.6\1
SET LRS=$PIECE(Y(0),U,23)
SET LR(66,.135)=$PIECE(^LAB(66,LRO,0),U,17)
+11 IF 'LRV
WRITE $CHAR(7),!!,"Volume of component must be entered in BLOOD COMPONENT file",!?20,"for ",$PIECE(Y,U,2),"."
GOTO P
U KILL LRF,Z
SET Z=0
WRITE !!
SET X=$$READ^LRBLB("Select UNIT: ")
if X=""!(X[U)
GOTO END
IF X["?"!(X[" ")!(X'?.ANP)
DO H
GOTO U
+1 IF LR
IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
Begin DoDot:1
+2 DO ^LRBLBU
End DoDot:1
+3 ; Strip off the data identifiers just in case
IF '$TEST
WRITE $$STRIP^LRBLB(.X)
+4 if '$DATA(X)
GOTO U
+5 SET DIC=65
SET DIC(0)="EQM"
SET DIC("W")="W "" "",$P(^(0),U)"
SET DIC("S")="I $P(^(0),U,16)=DUZ(2),$P(^(0),U,4)=LRC,$S('$D(^(4)):1,$P(^(4),U)="""":1,1:0)"
DO ^DIC
KILL DIC
if Y<1
GOTO U
SET X=$PIECE(^LRD(65,+Y,0),U)
+6 SET LRP=$$LRP(+Y)
+7 IF LRP=0
GOTO U
+8 SET LRJ=X
DO ALL
GOTO P
ALL SET Q=$ORDER(^LRD(65,"AI",LRC,LRJ,0))
IF Q
SET A=LRJ
SET Q=$ORDER(^LRD(65,"AI",LRC,A,0))
if 'Q
QUIT
WRITE !?3
DO I
if $DATA(LRF)
GOTO ^LRBLPED1
+1 KILL ^TMP($JOB)
WRITE !?3
SET A(2)=""
SET Z(1)=1
SET A=LRJ
DO D
if $DATA(LRF)
GOTO ^LRBLPED1
IF A(2)?1P
WRITE $CHAR(7)
QUIT
+2 IF LRJ'["E"
IF LRJ=+LRJ
IF +$ORDER(^LRD(65,"AI",LRJ))=X
SET A=LRJ_"?"
DO D
+3 if $DATA(LRF)
GOTO ^LRBLPED1
WRITE $CHAR(7)
QUIT
+4 ;
H IF '$DATA(^LRD(65,"AI",LRC))
WRITE $CHAR(7),!!,"No units to choose from !",!
QUIT
+1 IF X'["??"
WRITE !,"ANSWER WITH ",$PIECE(^DD(65,.01,0),U),!,"DO YOU WANT THE ENTIRE ",$PIECE(^LRD(65,0),U)," LIST ? "
SET %=""
DO RX^LRU
if %'=1
QUIT
+2 SET (A,A(2))=0
SET A(1)=$Y+21
WRITE !?3
FOR B=0:0
SET A=$ORDER(^LRD(65,"AI",LRC,A))
if A=""
QUIT
FOR Q=0:0
SET Q=$ORDER(^LRD(65,"AI",LRC,A,Q))
if 'Q
QUIT
if $Y>A(1)!'$Y
DO MORE
if A(2)?1P
QUIT
DO I
+3 QUIT
I IF Q["."
IF Q<LRN
KILL ^LRD(65,"AI",LRC,A,Q)
QUIT
+1 IF Q<LRM
KILL ^LRD(65,"AI",LRC,A,Q)
QUIT
+2 SET V=$ORDER(^LRD(65,"AI",LRC,A,Q,0))
IF $DATA(^LRD(65,V,4))
IF $PIECE(^(4),"^")]""
KILL ^LRD(65,"AI",LRC,A,Q,V)
QUIT
+3 IF $DATA(^LRD(65,V,8))
IF +^(8)
QUIT
+4 if '$DATA(^LRD(65,V,0))
QUIT
SET LRF=V_"^"_^(0)
DO OK
if '$DATA(LRF)
QUIT
+5 SET Z=Z+1
if $DATA(Z(1))
WRITE $JUSTIFY(Z,2)
WRITE ?7,$PIECE(LRF,"^",2),?20,$JUSTIFY($PIECE(LRF,"^",8),2)," ",$PIECE(LRF,"^",9)
SET (LRE,Y)=$PIECE(LRF,"^",7)
DO DT^LRU
WRITE ?28,Y
+6 WRITE $JUSTIFY($SELECT(LRB=0:"<1",1:LRB),4)," ",$SELECT(LRB>1:"DAYS",1:"DAY ")," OLD ",$JUSTIFY($PIECE(LRF,"^",12),3)
if '$PIECE(LRF,"^",12)&($PIECE(LRF,"^",12)'=0)
WRITE " ? "
WRITE " ml"
+7 WRITE !?3
QUIT
+8 ;
D KILL LRF
FOR B=0:0
SET A=+$ORDER(^LRD(65,"AI",LRC,A))
if $EXTRACT(A,1,$LENGTH(LRJ))'=LRJ
QUIT
FOR Q=0:0
SET Q=$ORDER(^LRD(65,"AI",LRC,A,Q))
if 'Q!($ASCII(A)>122)
QUIT
DO I
IF $DATA(LRF)
SET ^TMP($JOB,Z)=LRF
KILL LRF
IF Z#5=0
DO C
if A(2)?1P
QUIT
+1 if Z#5&('$DATA(LRF))
DO C
QUIT
+2 ;
OK SET O=0
FOR O(1)=0:0
SET O=$ORDER(^LRD(65,V,2,O))
if 'O
QUIT
IF $DATA(^LRD(65,"AP",O,V))
QUIT
+1 IF O>0
KILL LRF
QUIT
+2 SET X1=$PIECE(LRF,"^",7)
SET X2=LRA
DO C^%DTC
IF X<LRM
KILL LRF
QUIT
+3 SET X1=$PIECE(LRF,"^",7)
SET X2=-LRD
DO C^%DTC
SET X1=LRM
SET X2=X
DO ^%DTC
SET LRB=X
QUIT
+4 ;
MORE READ "'^' TO STOP: ",A(2):DTIME
IF A(2)?1P
SET A=$CHAR(126)
QUIT
+1 SET A(1)=A(1)+21
if $Y<22
SET A(1)=$Y+21
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13),?3
QUIT
C IF Z=1
SET A(2)=1
GOTO F
+1 WRITE $CHAR(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z
READ ": ",A(2):DTIME
IF A(2)?1P!'$TEST
SET A=$CHAR(126)
QUIT
+2 IF A(2)=""
WRITE !?3
QUIT
F IF A(2)>0
IF A(2)<(Z+1)
SET LRF=^TMP($JOB,A(2))
+1 SET A(2)="^"
SET A=$CHAR(126)
QUIT
END DO V^LRU
QUIT
+1 ;
SCRN() ; Screen for BLOOD PRODUCT file (#66)
+1 ;
+2 NEW X,PCODE,PEDICODE,ANS
+3 ;
+4 SET ANS=0
+5 ; from ^LAB(66,X,0)
SET X=^(0)
+6 SET PCODE=$PIECE(X,U,5)
+7 ;
+8 ; Max Age for Pediatric Product field defined
IF $PIECE(X,U,21)
SET ANS=1
+9 ; ISBT-128
IF $PIECE(X,U,29)
Begin DoDot:1
+10 ;No Pediatric Product defined
IF '$PIECE(X,U,22)
SET ANS=0
QUIT
+11 IF $EXTRACT(PCODE,($LENGTH(PCODE)-1),$LENGTH(PCODE))'="00"
SET ANS=0
QUIT
+12 SET PEDICODE=$$GET1^DIQ(66,$PIECE(X,U,22),.05)
+13 ; Pediatric Product Code must end in alpha+0
+14 IF $EXTRACT(PEDICODE,($LENGTH(PEDICODE)-1),$LENGTH(PEDICODE))'?1A1"0"
SET ANS=0
End DoDot:1
+15 QUIT ANS
+16 ;
LRP(DA) ; Find & return Product Code to be used for next child
+1 ;
+2 ; INPUT: DA = IEN of PARENT UNIT RECORD on File #65
+3 ; OUTPUT: LRP = IEN of Child Product Code (file #66) if ISBT-1128
+4 ; or IEN of Parent Product Code (file #66) if Codabar
+5 ; or 0 if invalid.
+6 ;
+7 NEW LRBLAST,LRBLBP,LRBLSFX,LRP,LRBLPC
+8 ;
+9 SET B=0
+10 ;
+11 ; not ISBT-128, return the IEN of
if '$$GET1^DIQ(65,DA,".04
QUIT $$GET1^DIQ(65,+DA,".04:.22","I")
+12 ; ; the pediatric type for the product
+13 ; Parent Product Code
SET LRBLPC=$$GET1^DIQ(65,+DA,".04:.05")
+14 ;
+15 SET LRBLAST=$ORDER(^LRD(65,+DA,16,""),-1)
+16 IF LRBLAST>25
SET B=91
+17 SET LRBLSFX=$EXTRACT("ABCDEFGHIJKLMNOPQRSTUVWXYZ",LRBLAST+1)_"0"
+18 SET LRBLBP=$EXTRACT(LRBLPC,1,$LENGTH(LRBLPC)-2)_LRBLSFX
+19 SET LRP=$ORDER(^LAB(66,"D",LRBLBP,0))
+20 IF 'LRP
Begin DoDot:1
+21 DO EN^DDIOL("Pediatric Preparation cannot proceed with this unit until another","","!!")
+22 DO EN^DDIOL("record is created for this product type in the BLOOD PRODUCT file.","","!")
End DoDot:1
QUIT 0
+23 QUIT LRP
+24 ;
