- LRBLPED ; IHS/DIR/AAB - PEDIATRIC UNIT PREPARATION 7/30/95 15:36 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- 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 R !!,"Blood component for pediatric prep: ",X:DTIME 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 P^LRBLB 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 $P(^(0),U,21)" 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 R !!,"Select UNIT: ",X:DTIME 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 ^LRBLBU 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 LRJ=X D ALL G U
- 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
- LRBLPED ; IHS/DIR/AAB - PEDIATRIC UNIT PREPARATION 7/30/95 15:36 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 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)
- +4 IF LRCAPA
- SET X="PEDIATRIC UNIT PREPARATION"
- SET X("NOCODES")=1
- DO X^LRUWK
- IF '$DATA(X)
- GOTO END
- KILL X
- +5 SET LR(3)=""
- DO BAR^LRBLB
- P READ !!,"Blood component for pediatric prep: ",X:DTIME
- 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)
- DO P^LRBLB
- IF '$DATA(X)
- WRITE $CHAR(7),!,"Code not entered in BLOOD PRODUCT file or not product label.",!
- GOTO P
- +2 SET DIC=66
- SET DIC(0)="EQMZ"
- SET DIC("S")="I $P(^(0),U,21)"
- 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
- +3 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
- +4 IF '$PIECE(Y(0),U,23)
- WRITE $CHAR(7),!,$PIECE(^DD(66,.23,0),U)," must be entered for this component"
- SET X=1
- +5 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)=""
- +6 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
- +7 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)
- +8 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
- READ !!,"Select UNIT: ",X:DTIME
- 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)
- DO ^LRBLBU
- IF '$DATA(X)
- GOTO U
- +2 SET DIC=65
- SET DIC(0)="EQM"
- SET DIC("W")="W "" "",$P(^(0),U)"
- SET PED_source.html#xD">DIC("S")="I $PEPED_source.html#xD">D_source.html#xP">PEPED_source.html#xD">D_source.html#xPEPED_source.html#xD">D_source.html#xP">P">PEPED_source.html#xD">D_source.html#xP">P(^(0),U,16)=PED_source.html#xD">DUZ(2),$PEPED_source.html#xD">D_source.html#xP">PEPED_source.html#xD">D_source.html#xPEPED_source.html#xD">D_source.html#xP">P">PEPED_source.html#xD">D_source.html#xP">P(^(0),U,4)=LRC,$S('$PED_source.html#xD">D(^(4)):1,$PEPED_source.html#xD">D_source.html#xP">PEPED_source.html#xD">D_source.html#xPEPED_source.html#xD">D_source.html#xP">P">PEPED_source.html#xD">D_source.html#xP">P(^(4),U)="""":1,1:0)"
- DO ^DIC
- KILL DIC
- IF Y<1
- GOTO U
- SET X=$PIECE(^LRD(65,+Y,0),U)
- +3 SET LRJ=X
- DO ALL
- GOTO U
- 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
