- LRBLJDM ;AVAMC/REG/CYM - MULTIPLE COMP PREP, INVENTORY ;5/21/97 14:56 ; 12/7/00 7:12am
- ;;5.2;LAB SERVICE;**90,247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- S X=^LAB(66,LRV,0),LRP(LRV)=$P(X,"^")_"^"_$P(X,"^",10)_"^"_$P(X,"^",11)_"^"_$P(X,"^",18),LRZ=$P(X,"^",19)
- C S DIC="^LAB(66,LRE(4),3,",DIC(0)="AEQMZ" D ^DIC K DIC I Y>0 S (X,Y)=+Y,X=^LAB(66,X,0),LRP(Y)=$P(X,"^")_"^"_$P(X,"^",10)_"^"_$P(X,"^",11)_"^"_$P(X,"^",18) D:'$P(^LAB(66,LRE(4),3,Y,0),"^",2) ONLY D:$D(LRP(Y)) CK G C
- G:'$D(LRP) OUT S S=0 W !,"You have selected the following component(s): " S X=0 F X(1)=0:1 S X=$O(LRP(X)) Q:'X W !,$P(LRP(X),"^"),?40,"vol(ml):",$J($P(LRP(X),"^",2),5) S S=S+$P(LRP(X),"^",2)
- W !?48,"-----",!?34,"Total vol(ml):",$J(S,5) I S>LRM W !!,$C(7),"Total volume of components greater than unit. SELECTIONS DELETED TRY AGAIN !",!! K LRP S LRZ=0 G C
- W !?5,"All OK " S %=1 D YN^LRU I %'=1 W " SELECTIONS DELETED TRY AGAIN",! K LRP G C
- S LRE(1)=$P(LRE,"^"),LRV(10)=LRV(10)/X(1) I LRV(10)["." S LRV(10)=$P(LRV(10),".")_"."_$E($P(LRV(10),".",2),1,2)
- F LRH=0:0 S LRH=$O(LRP(LRH)) Q:'LRH S LRV=LRH,LRV(1)=$P(LRP(LRH),"^"),LRM=$P(LRP(LRH),"^",2),LRO(1)=$P(LRP(LRH),"^",3),LRD=$P(LRP(LRH),"^",4) D:LRO(1) F D:LRO(1)="" T D S
- Q
- ONLY W !!,$C(7),"Component selected must be the ONLY ONE for this unit.",!," Selection ",$P(LRP(Y),"^")," canceled !",! K LRP(Y) Q
- CK I LRZ,$P(X,"^",19) W $C(7),!!,"Cannot select more than one red blood cell product.",!,"Selection ",$P(LRP(Y),"^")," canceled !",! K LRP(Y) Q
- S:'LRZ LRZ=$P(X,"^",19) Q
- ;
- T S Y=$P(LRE,"^",6) D D^LRU S LRO(1)=Y Q
- ;
- F ;from LRBLJD
- S T(2)="."_$P(LRO(1),".",2)*1440,LRO(1)=$P(LRO(1),".") S X="N",%DT="T" D ^%DT S X=Y,Y=Y_"000",T(3)=$E(Y,9,10)*60+$E(Y,11,12) D H^%DTC S T(5)=T(3)+T(2),%H=%H+LRO(1)+(T(5)\1440),T(5)=T(5)#1440\1
- D D^LRUT I LRO(9)<2 S T(3)=T(5)\60,T(3)=$E("00",1,2-$L(T(3)))_T(3),T(4)=T(5)#60,T(4)=$E("00",1,2-$L(T(4)))_T(4),T(4)=T(3)_T(4) S:+T(4) X=X_"."_T(4)
- S Y=$P(X,"."),X=$P(X,".",2) D D^LRU S LRO(1)=$S(X:Y_"@"_X,1:Y) Q
- ;
- S ;from LRBLJD
- S LRE(1)=$P(LRE,"^")_LRV(11) S:'$D(^LRD(65,LRX,9,0)) ^(0)="^65.091PAI^^" S X=^(0),C=$P(X,"^",4)+1,^(0)=$P(X,"^",1,2)_"^"_C_"^"_C,^(C,0)=LRV_"^"_LRE(1)_"^"_2
- D:C>1 SET D ^LRBLJDA Q:'LRCAPA F A=0:0 S A=$O(^LAB(66,LRV,9,A)) Q:'A S LRT(A)=""
- D ^LRBLW K LRT S LRT=LRW("MO") Q
- SET S C=0 F A=0:0 S A=$O(^LRD(65,LRX,9,A)) Q:'A S:$P(^(A,0),"^",3)=2 C=C+1
- S $P(^LRD(65,LRX,4),"^",4)="("_C_")" Q
- ;
- D I LRCAPA,'$O(^LAB(66,LRV,9,0)) W $C(7),!,!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$P(^LAB(66,LRV,0),U)," to divide unit.",! D OUT Q
- R !,"Enter number of aliquots (1-5): ",A:DTIME I A=""!(A[U) D OUT Q
- S A=+A I A>5!(A<1) W !!,"Answer must be 1,2,3,4, or 5",! G D
- ; Insert logic for ISBT128 units so that splitting follows ISBT128 naming conventions
- G:$$ISBTSPLT(LRX,A) D
- S LR("C")=A,LRM=LRM\A,LRV(10)=LRV(10)/A S:LRV(10)["." LRV(10)=$P(LRV(10),".")_"."_$E($P(LRV(10),".",2),1,2)
- I $$ISISBT($P(LRE,U,4)) D
- .N LRBLPCOD,CNT
- .S LRBLPCOD=$$GET1^DIQ(66,$P(LRE,U,4),.05)
- .S LRV(11)=""
- .S I=0 F CNT=0:1 S I=$O(^LRD(65,LRX,16,I)) Q:'I ; Count pre-existing child units
- .F B=1:1:LR("C") S $E(LRBLPCOD,($L(LRBLPCOD)-1))=$C(64+CNT+B),LRV=$$FIND1^DIC(66,,,LRBLPCOD,"D"),LRV(1)=$$GET1^DIQ(66,LRV,.01) D S
- I '$$ISISBT($P(LRE,U,4)) F B=1:1:LR("C") S LRV(11)=$C(64+B) D S
- Q
- ;
- OUT D K^LRBLJD Q
- ;
- ISISBT(PROD) ; This function should only be called within this routine
- ; This function is a boolean of whether a product type is ISBT128 (true) or Codabar (false)
- Q $$GET1^DIQ(66,PROD,.29,"I")
- ;
- ISBTSPLT(UIEN,NUM) ; This function should only be called from within this routine
- ; This function checks for an appropriate number of split units for ISBT128 product types
- ; UIEN Unit Internal Entry Number
- ; PROD is the product code
- ; NUM is the number of aliquots requested by the user
- N ANS ; This is the flag that determines whether the function fails the check
- N I,CHK,CODE,PROD,CNT
- I '$G(UIEN)!('$G(NUM)) Q 1 ; No go if parent unit or number is not indicated
- S PROD=$P(^LRD(65,UIEN,0),"^",4)
- S (ANS,I)=0
- I $$ISISBT(PROD) D Q ANS
- .S CODE=$$GET1^DIQ(66,PROD,.05),CHK=0
- .I $E(CODE,($L(CODE)-1),$L(CODE))'="00" D Q ; Only parent units with '00' at the end of the end of the
- ..; ; product code can be split
- ..S ANS=1
- ..W !,"This ISBT128 unit cannot be split because the product"
- ..W !,"code does not end in '00'.",*7
- .;
- .F CNT=0:1 S I=$O(^LRD(65,UIEN,16,I)) Q:'I ; Get a count of any child units already created and add them in
- .; ; in the search below
- .F I=1:1:NUM S $E(CODE,($L(CODE)-1))=$C(64+CNT+I) Q:'$$FIND1^DIC(66,,,CODE,"D") S CHK=CHK+1
- .I CHK'=NUM D
- ..S ANS=1
- ..W !,(NUM-CHK)," MORE DIVIDED BLOOD PRODUCT ENTR"_$S((NUM-CHK)>1:"IES",1:"Y")_" MUST BE CREATED BEFORE THE PRODUCT"
- ..W !,"TYPE YOU HAVE SELECTED CAN BE SPLIT INTO "_NUM_" UNIT"_$S(NUM>1:"S.",1:"."),*7
- Q ANS
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJDM 5051 printed Mar 13, 2025@21:15:29 Page 2
- LRBLJDM ;AVAMC/REG/CYM - MULTIPLE COMP PREP, INVENTORY ;5/21/97 14:56 ; 12/7/00 7:12am
- +1 ;;5.2;LAB SERVICE;**90,247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 SET X=^LAB(66,LRV,0)
- SET LRP(LRV)=$PIECE(X,"^")_"^"_$PIECE(X,"^",10)_"^"_$PIECE(X,"^",11)_"^"_$PIECE(X,"^",18)
- SET LRZ=$PIECE(X,"^",19)
- C SET DIC="^LAB(66,LRE(4),3,"
- SET DIC(0)="AEQMZ"
- DO ^DIC
- KILL DIC
- IF Y>0
- SET (X,Y)=+Y
- SET X=^LAB(66,X,0)
- SET LRP(Y)=$PIECE(X,"^")_"^"_$PIECE(X,"^",10)_"^"_$PIECE(X,"^",11)_"^"_$PIECE(X,"^",18)
- if '$PIECE(^LAB(66,LRE(4),3,Y,0),"^",2)
- DO ONLY
- if $DATA(LRP(Y))
- DO CK
- GOTO C
- +1 if '$DATA(LRP)
- GOTO OUT
- SET S=0
- WRITE !,"You have selected the following component(s): "
- SET X=0
- FOR X(1)=0:1
- SET X=$ORDER(LRP(X))
- if 'X
- QUIT
- WRITE !,$PIECE(LRP(X),"^"),?40,"vol(ml):",$JUSTIFY($PIECE(LRP(X),"^",2),5)
- SET S=S+$PIECE(LRP(X),"^",2)
- +2 WRITE !?48,"-----",!?34,"Total vol(ml):",$JUSTIFY(S,5)
- IF S>LRM
- WRITE !!,$CHAR(7),"Total volume of components greater than unit. SELECTIONS DELETED TRY AGAIN !",!!
- KILL LRP
- SET LRZ=0
- GOTO C
- +3 WRITE !?5,"All OK "
- SET %=1
- DO YN^LRU
- IF %'=1
- WRITE " SELECTIONS DELETED TRY AGAIN",!
- KILL LRP
- GOTO C
- +4 SET LRE(1)=$PIECE(LRE,"^")
- SET LRV(10)=LRV(10)/X(1)
- IF LRV(10)["."
- SET LRV(10)=$PIECE(LRV(10),".")_"."_$EXTRACT($PIECE(LRV(10),".",2),1,2)
- +5 FOR LRH=0:0
- SET LRH=$ORDER(LRP(LRH))
- if 'LRH
- QUIT
- SET LRV=LRH
- SET LRV(1)=$PIECE(LRP(LRH),"^")
- SET LRM=$PIECE(LRP(LRH),"^",2)
- SET LRO(1)=$PIECE(LRP(LRH),"^",3)
- SET LRD=$PIECE(LRP(LRH),"^",4)
- if LRO(1)
- DO F
- if LRO(1)=""
- DO T
- DO S
- +6 QUIT
- ONLY WRITE !!,$CHAR(7),"Component selected must be the ONLY ONE for this unit.",!," Selection ",$PIECE(LRP(Y),"^")," canceled !",!
- KILL LRP(Y)
- QUIT
- CK IF LRZ
- IF $PIECE(X,"^",19)
- WRITE $CHAR(7),!!,"Cannot select more than one red blood cell product.",!,"Selection ",$PIECE(LRP(Y),"^")," canceled !",!
- KILL LRP(Y)
- QUIT
- +1 if 'LRZ
- SET LRZ=$PIECE(X,"^",19)
- QUIT
- +2 ;
- T SET Y=$PIECE(LRE,"^",6)
- DO D^LRU
- SET LRO(1)=Y
- QUIT
- +1 ;
- F ;from LRBLJD
- +1 SET T(2)="."_$PIECE(LRO(1),".",2)*1440
- SET LRO(1)=$PIECE(LRO(1),".")
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET X=Y
- SET Y=Y_"000"
- SET T(3)=$EXTRACT(Y,9,10)*60+$EXTRACT(Y,11,12)
- DO H^%DTC
- SET T(5)=T(3)+T(2)
- SET %H=%H+LRO(1)+(T(5)\1440)
- SET T(5)=T(5)#1440\1
- +2 DO D^LRUT
- IF LRO(9)<2
- SET T(3)=T(5)\60
- SET T(3)=$EXTRACT("00",1,2-$LENGTH(T(3)))_T(3)
- SET T(4)=T(5)#60
- SET T(4)=$EXTRACT("00",1,2-$LENGTH(T(4)))_T(4)
- SET T(4)=T(3)_T(4)
- if +T(4)
- SET X=X_"."_T(4)
- +3 SET Y=$PIECE(X,".")
- SET X=$PIECE(X,".",2)
- DO D^LRU
- SET LRO(1)=$SELECT(X:Y_"@"_X,1:Y)
- QUIT
- +4 ;
- S ;from LRBLJD
- +1 SET LRE(1)=$PIECE(LRE,"^")_LRV(11)
- if '$DATA(^LRD(65,LRX,9,0))
- SET ^(0)="^65.091PAI^^"
- SET X=^(0)
- SET C=$PIECE(X,"^",4)+1
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_C
- SET ^(C,0)=LRV_"^"_LRE(1)_"^"_2
- +2 if C>1
- DO SET
- DO ^LRBLJDA
- if 'LRCAPA
- QUIT
- FOR A=0:0
- SET A=$ORDER(^LAB(66,LRV,9,A))
- if 'A
- QUIT
- SET LRT(A)=""
- +3 DO ^LRBLW
- KILL LRT
- SET LRT=LRW("MO")
- QUIT
- SET SET C=0
- FOR A=0:0
- SET A=$ORDER(^LRD(65,LRX,9,A))
- if 'A
- QUIT
- if $PIECE(^(A,0),"^",3)=2
- SET C=C+1
- +1 SET $PIECE(^LRD(65,LRX,4),"^",4)="("_C_")"
- QUIT
- +2 ;
- D IF LRCAPA
- IF '$ORDER(^LAB(66,LRV,9,0))
- WRITE $CHAR(7),!,!!,"Must enter WKLD CODES in BLOOD PRODUCT FILE (#66)",!,"for ",$PIECE(^LAB(66,LRV,0),U)," to divide unit.",!
- DO OUT
- QUIT
- +1 READ !,"Enter number of aliquots (1-5): ",A:DTIME
- IF A=""!(A[U)
- DO OUT
- QUIT
- +2 SET A=+A
- IF A>5!(A<1)
- WRITE !!,"Answer must be 1,2,3,4, or 5",!
- GOTO D
- +3 ; Insert logic for ISBT128 units so that splitting follows ISBT128 naming conventions
- +4 if $$ISBTSPLT(LRX,A)
- GOTO D
- +5 SET LR("C")=A
- SET LRM=LRM\A
- SET LRV(10)=LRV(10)/A
- if LRV(10)["."
- SET LRV(10)=$PIECE(LRV(10),".")_"."_$EXTRACT($PIECE(LRV(10),".",2),1,2)
- +6 IF $$ISISBT($PIECE(LRE,U,4))
- Begin DoDot:1
- +7 NEW LRBLPCOD,CNT
- +8 SET LRBLPCOD=$$GET1^DIQ(66,$PIECE(LRE,U,4),.05)
- +9 SET LRV(11)=""
- +10 ; Count pre-existing child units
- SET I=0
- FOR CNT=0:1
- SET I=$ORDER(^LRD(65,LRX,16,I))
- if 'I
- QUIT
- +11 FOR B=1:1:LR("C")
- SET $EXTRACT(LRBLPCOD,($LENGTH(LRBLPCOD)-1))=$CHAR(64+CNT+B)
- SET LRV=$$FIND1^DIC(66,,,LRBLPCOD,"D")
- SET LRV(1)=$$GET1^DIQ(66,LRV,.01)
- DO S
- End DoDot:1
- +12 IF '$$ISISBT($PIECE(LRE,U,4))
- FOR B=1:1:LR("C")
- SET LRV(11)=$CHAR(64+B)
- DO S
- +13 QUIT
- +14 ;
- OUT DO K^LRBLJD
- QUIT
- +1 ;
- ISISBT(PROD) ; This function should only be called within this routine
- +1 ; This function is a boolean of whether a product type is ISBT128 (true) or Codabar (false)
- +2 QUIT $$GET1^DIQ(66,PROD,.29,"I")
- +3 ;
- ISBTSPLT(UIEN,NUM) ; This function should only be called from within this routine
- +1 ; This function checks for an appropriate number of split units for ISBT128 product types
- +2 ; UIEN Unit Internal Entry Number
- +3 ; PROD is the product code
- +4 ; NUM is the number of aliquots requested by the user
- +5 ; This is the flag that determines whether the function fails the check
- NEW ANS
- +6 NEW I,CHK,CODE,PROD,CNT
- +7 ; No go if parent unit or number is not indicated
- IF '$GET(UIEN)!('$GET(NUM))
- QUIT 1
- +8 SET PROD=$PIECE(^LRD(65,UIEN,0),"^",4)
- +9 SET (ANS,I)=0
- +10 IF $$ISISBT(PROD)
- Begin DoDot:1
- +11 SET CODE=$$GET1^DIQ(66,PROD,.05)
- SET CHK=0
- +12 ; Only parent units with '00' at the end of the end of the
- IF $EXTRACT(CODE,($LENGTH(CODE)-1),$LENGTH(CODE))'="00"
- Begin DoDot:2
- +13 ; ; product code can be split
- +14 SET ANS=1
- +15 WRITE !,"This ISBT128 unit cannot be split because the product"
- +16 WRITE !,"code does not end in '00'.",*7
- End DoDot:2
- QUIT
- +17 ;
- +18 ; Get a count of any child units already created and add them in
- FOR CNT=0:1
- SET I=$ORDER(^LRD(65,UIEN,16,I))
- if 'I
- QUIT
- +19 ; ; in the search below
- +20 FOR I=1:1:NUM
- SET $EXTRACT(CODE,($LENGTH(CODE)-1))=$CHAR(64+CNT+I)
- if '$$FIND1^DIC(66,,,CODE,"D")
- QUIT
- SET CHK=CHK+1
- +21 IF CHK'=NUM
- Begin DoDot:2
- +22 SET ANS=1
- +23 WRITE !,(NUM-CHK)," MORE DIVIDED BLOOD PRODUCT ENTR"_$SELECT((NUM-CHK)>1:"IES",1:"Y")_" MUST BE CREATED BEFORE THE PRODUCT"
- +24 WRITE !,"TYPE YOU HAVE SELECTED CAN BE SPLIT INTO "_NUM_" UNIT"_$SELECT(NUM>1:"S.",1:"."),*7
- End DoDot:2
- End DoDot:1
- QUIT ANS
- +25 QUIT ANS
