- LRBLPCS ;AVAMC/REG - COMPONENT SELECTION FOR PATIENTS ;8/4/95 06:32 ;
- ;;5.2;LAB SERVICE;**1,72,247,267,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D V^LRU,CK^LRBLPUS
- G:Y=-1 END
- I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" G END
- W !?20,LRAA(4),!!?15,"Selection of blood components for a patient"
- S LRJ=1
- W !,"Display instructions for component selected "
- S %=2 D YN^LRU G:%<1 END S:%=1 LRO=1
- P W ! K DIC D ^LRDPA
- K DIC,DIE,DR
- W ! G:LRDFN=-1 END D EN1 G P
- ;
- EN1 Q:'$D(LRP)
- D ^LRBLPA Q:$D(Q("Q"))!(LRLLOC["DIED")
- W LRP," ",SSN(1),?42,$J(LRPABO,2),?45,LRPRH
- D EN^LRBLPUS
- S A=0 F B=1:1 S A=$O(^LRD(65,"AP",LRDFN,A)) Q:'A D N
- I $D(LRQ),B=1 W !,"No units currently assigned/xmatched"
- W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,1.8,A)) Q:'A S X=^(A,0) W:'B !,"Component(s) requested",?24,"Units",?30,"Request date/time",?48,"Wanted date/time",?65,"Requestor",?77,"By" D L
- OP K LRR
- S LRCPT=0
- W !!,"Is patient Pre-op " S %="" D YN^LRU I %<1 W $C(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time " S %=1 D YN^LRU G:%=1 OP Q
- S LRV=$S(%=2:0,1:1),LRV(1)=$S(LRV=1:8,1:6)
- D:LRV ^LRBLPCSS
- S DIE=63,DA=LRDFN,DR="[LRBLPCS]"
- W ! D ^DIE K DIE,DR
- D:$D(LRK) EN^LRBLPCS1
- K LRK,S,C Q
- ;
- EN3 F A=0:0 S A=$O(^LAB(66,C,LRV(1),A)) Q:'A S X=^(A,0),E=$P(X,"^",2),F=+X,C(C,F,E)=$P(X,"^",3) I '$D(S(F,E)) D G
- K I(0) F A=0:0 S A=$O(C(C,A)) Q:'A F B=0:0 S B=$O(C(C,A,B)) Q:'B D A
- K:$D(I(0)) Q
- I $D(Q) K Q W !?5,$C(7)," Request still OK " S %=2 D YN^LRU S:%=1 LRR=1 I %'=1 S Y=0 D DEL
- S:$D(LRR) LRK(C)="" Q
- G S X=$S($D(^LAB(60,F,0)):^(0),1:F)
- I $P(X,"^",5)'["CH" W $C(7),!,"No DATA NAME in file 60 for ",$P(X,"^") Q
- S G=$P(X,";",2),H=+$P(X,";",3),Z=$S($D(^LAB(60,F,1,E,0)):$P(^(0),"^",7),1:""),I(0)=$P(X,"^")
- F B=0:0 S B=$O(^LR(LRDFN,"CH",B)) Q:'B S W=^(B,0),S=$P(W,"^",5) I S=E,$D(^(G)),$L(^(G)) S X=^(G) D H Q
- S:'$D(S(F,E)) S(F,E)="^"_I(0) Q
- H N LRDATE S LRDATE=$$FMTE^XLFDT(+W,"5F")
- S LRDATE=$TR(LRDATE," ",0)
- S LRDATE=$TR(LRDATE,"@"," ")
- S S(F,E)=$P(X,"^",H)_"^"_I(0)_"^"_LRDATE_"^"_Z_"^"_$P(^LAB(61,E,0),"^")
- Q
- A Q:'$D(S(A,B))
- I $P(S(A,B),"^")="" W !?10,"No ",$P(S(A,B),"^",2)," results " S Q=1 Q
- I +S(A,B),@(+$P(S(A,B),"^")_C(C,A,B)) W !?10,$P(S(A,B),"^",3)," Last ",$P(S(A,B),"^",2),": ",$P(S(A,B),"^")," ",$P(S(A,B),"^",4)," ",$P(S(A,B),"^",5) S Q=1 Q
- S I(0)=1 Q
- EN2 K ^UTILITY($J)
- S DIWR=IOM-5,DIWL=5,DIWF="W"
- S A=0 F K=0:1 S A=$O(^LAB(66,C,7,A)) Q:'A S X=^(A,0) D ^DIWP
- D:K ^DIWW Q
- ;
- L S Y=+X
- I '$D(^LAB(66,Y,0)) K ^LR(LRDFN,1.8,Y) S Y=^LR(LRDFN,1.8,0),^(0)=$P(Y,"^",1,2)_"^^"_($P(Y,"^",4)-1) Q
- W !,$E($P(^LAB(66,+X,0),"^"),1,23),?24,$J($P(X,"^",4),3),?30 S Y=$P(X,"^",3) D M W Y,?48 S Y=$P(X,"^",5) D M W Y,?65,$P(X,"^",9) S Y=$P(X,"^",8) W ?77,$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^",2),1:Y) Q
- M Q:'Y D DD^LRX
- Q
- ;
- N W:B=1 !,"Unit assigned/xmatched:",?49,"Exp date",?67,"Location"
- I '$D(^LRD(65,A,0)) K ^LRD(65,"AP",LRDFN,A) Q
- S X=^LRD(65,A,0),L=$O(^(3,0)) S:'L L="Blood Bank" I L S L=$P(^(L,0),"^",4)
- S M=^LAB(66,$P(X,"^",4),0)
- W !,$J(B,2),")",?5,$P(X,"^"),?20,$E($P(M,"^"),1,21),?42,$J($P(X,"^",7),2),?45,$P(X,"^",8),?49 S Y=$P(X,"^",6) D DD^LRX S:L<0 L="Blood bank" W Y,?67,L Q
- ;
- DEL I $O(^LR(LRDFN,1.8,C,1,0)) S ^LR(LRDFN,1.8,C,0)=$P(^LR(LRDFN,1.8,C,0),"^") K ^LR(LRDFN,1.8,C,2) Q
- K ^LR(LRDFN,1.8,C) S X=^LR(LRDFN,1.8,0),X(2)=$O(^(0)),X(1)=$P(X,"^",4),^(0)="^63.084PA^"_X(2)_"^"_$S(X(1)<2:"",1:X(1)-1) Q
- END D V^LRU Q
- EN K LRO S IOM=$S('$D(IOM):80,IOM:IOM,1:80)
- W !,"FOR TRANSFUSION REQUESTS: Display instructions for components " S %=2 D YN^LRU Q:%<1 S:%=1 LRO=1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPCS 3721 printed Feb 18, 2025@23:37:37 Page 2
- LRBLPCS ;AVAMC/REG - COMPONENT SELECTION FOR PATIENTS ;8/4/95 06:32 ;
- +1 ;;5.2;LAB SERVICE;**1,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 QUIT
- DO V^LRU
- DO CK^LRBLPUS
- +4 if Y=-1
- GOTO END
- +5 IF LRSS'="BB"
- WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"
- GOTO END
- +6 WRITE !?20,LRAA(4),!!?15,"Selection of blood components for a patient"
- +7 SET LRJ=1
- +8 WRITE !,"Display instructions for component selected "
- +9 SET %=2
- DO YN^LRU
- if %<1
- GOTO END
- if %=1
- SET LRO=1
- P WRITE !
- KILL DIC
- DO ^LRDPA
- +1 KILL DIC,DIE,DR
- +2 WRITE !
- if LRDFN=-1
- GOTO END
- DO EN1
- GOTO P
- +3 ;
- EN1 if '$DATA(LRP)
- QUIT
- +1 DO ^LRBLPA
- if $DATA(Q("Q"))!(LRLLOC["DIED")
- QUIT
- +2 WRITE LRP," ",SSN(1),?42,$JUSTIFY(LRPABO,2),?45,LRPRH
- +3 DO EN^LRBLPUS
- +4 SET A=0
- FOR B=1:1
- SET A=$ORDER(^LRD(65,"AP",LRDFN,A))
- if 'A
- QUIT
- DO N
- +5 IF $DATA(LRQ)
- IF B=1
- WRITE !,"No units currently assigned/xmatched"
- +6 WRITE !
- SET A=0
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,1.8,A))
- if 'A
- QUIT
- SET X=^(A,0)
- if 'B
- WRITE !,"Component(s) requested",?24,"Units",?30,"Request date/time",?48,"Wanted date/time",?65,"Requestor",?77,"By"
- DO L
- OP KILL LRR
- +1 SET LRCPT=0
- +2 WRITE !!,"Is patient Pre-op "
- SET %=""
- DO YN^LRU
- IF %<1
- WRITE $CHAR(7),!,"You must answer 'YES' or 'NO' to enter component request.",!,"Do you want to enter component request at this time "
- SET %=1
- DO YN^LRU
- if %=1
- GOTO OP
- QUIT
- +3 SET LRV=$SELECT(%=2:0,1:1)
- SET LRV(1)=$SELECT(LRV=1:8,1:6)
- +4 if LRV
- DO ^LRBLPCSS
- +5 SET DIE=63
- SET DA=LRDFN
- SET DR="[LRBLPCS]"
- +6 WRITE !
- DO ^DIE
- KILL DIE,DR
- +7 if $DATA(LRK)
- DO EN^LRBLPCS1
- +8 KILL LRK,S,C
- QUIT
- +9 ;
- EN3 FOR A=0:0
- SET A=$ORDER(^LAB(66,C,LRV(1),A))
- if 'A
- QUIT
- SET X=^(A,0)
- SET E=$PIECE(X,"^",2)
- SET F=+X
- SET C(C,F,E)=$PIECE(X,"^",3)
- IF '$DATA(S(F,E))
- DO G
- +1 KILL I(0)
- FOR A=0:0
- SET A=$ORDER(C(C,A))
- if 'A
- QUIT
- FOR B=0:0
- SET B=$ORDER(C(C,A,B))
- if 'B
- QUIT
- DO A
- +2 if $DATA(I(0))
- KILL Q
- +3 IF $DATA(Q)
- KILL Q
- WRITE !?5,$CHAR(7)," Request still OK "
- SET %=2
- DO YN^LRU
- if %=1
- SET LRR=1
- IF %'=1
- SET Y=0
- DO DEL
- +4 if $DATA(LRR)
- SET LRK(C)=""
- QUIT
- G SET X=$SELECT($DATA(^LAB(60,F,0)):^(0),1:F)
- +1 IF $PIECE(X,"^",5)'["CH"
- WRITE $CHAR(7),!,"No DATA NAME in file 60 for ",$PIECE(X,"^")
- QUIT
- +2 SET G=$PIECE(X,";",2)
- SET H=+$PIECE(X,";",3)
- SET Z=$SELECT($DATA(^LAB(60,F,1,E,0)):$PIECE(^(0),"^",7),1:"")
- SET I(0)=$PIECE(X,"^")
- +3 FOR B=0:0
- SET B=$ORDER(^LR(LRDFN,"CH",B))
- if 'B
- QUIT
- SET W=^(B,0)
- SET S=$PIECE(W,"^",5)
- IF S=E
- IF $DATA(^(G))
- IF $LENGTH(^(G))
- SET X=^(G)
- DO H
- QUIT
- +4 if '$DATA(S(F,E))
- SET S(F,E)="^"_I(0)
- QUIT
- H NEW LRDATE
- SET LRDATE=$$FMTE^XLFDT(+W,"5F")
- +1 SET LRDATE=$TRANSLATE(LRDATE," ",0)
- +2 SET LRDATE=$TRANSLATE(LRDATE,"@"," ")
- +3 SET S(F,E)=$PIECE(X,"^",H)_"^"_I(0)_"^"_LRDATE_"^"_Z_"^"_$PIECE(^LAB(61,E,0),"^")
- +4 QUIT
- A if '$DATA(S(A,B))
- QUIT
- +1 IF $PIECE(S(A,B),"^")=""
- WRITE !?10,"No ",$PIECE(S(A,B),"^",2)," results "
- SET Q=1
- QUIT
- +2 IF +S(A,B)
- IF @(+$PIECE(S(A,B),"^")_C(C,A,B))
- WRITE !?10,$PIECE(S(A,B),"^",3)," Last ",$PIECE(S(A,B),"^",2),": ",$PIECE(S(A,B),"^")," ",$PIECE(S(A,B),"^",4)," ",$PIECE(S(A,B),"^",5)
- SET Q=1
- QUIT
- +3 SET I(0)=1
- QUIT
- EN2 KILL ^UTILITY($JOB)
- +1 SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- +2 SET A=0
- FOR K=0:1
- SET A=$ORDER(^LAB(66,C,7,A))
- if 'A
- QUIT
- SET X=^(A,0)
- DO ^DIWP
- +3 if K
- DO ^DIWW
- QUIT
- +4 ;
- L SET Y=+X
- +1 IF '$DATA(^LAB(66,Y,0))
- KILL ^LR(LRDFN,1.8,Y)
- SET Y=^LR(LRDFN,1.8,0)
- SET ^(0)=$PIECE(Y,"^",1,2)_"^^"_($PIECE(Y,"^",4)-1)
- QUIT
- +2 WRITE !,$EXTRACT($PIECE(^LAB(66,+X,0),"^"),1,23),?24,$JUSTIFY($PIECE(X,"^",4),3),?30
- SET Y=$PIECE(X,"^",3)
- DO M
- WRITE Y,?48
- SET Y=$PIECE(X,"^",5)
- DO M
- WRITE Y,?65,$PIECE(X,"^",9)
- SET Y=$PIECE(X,"^",8)
- WRITE ?77,$SELECT(Y="":Y,$DATA(^VA(200,Y,0)):$PIECE(^(0),"^",2),1:Y)
- QUIT
- M if 'Y
- QUIT
- DO DD^LRX
- +1 QUIT
- +2 ;
- N if B=1
- WRITE !,"Unit assigned/xmatched:",?49,"Exp date",?67,"Location"
- +1 IF '$DATA(^LRD(65,A,0))
- KILL ^LRD(65,"AP",LRDFN,A)
- QUIT
- +2 SET X=^LRD(65,A,0)
- SET L=$ORDER(^(3,0))
- if 'L
- SET L="Blood Bank"
- IF L
- SET L=$PIECE(^(L,0),"^",4)
- +3 SET M=^LAB(66,$PIECE(X,"^",4),0)
- +4 WRITE !,$JUSTIFY(B,2),")",?5,$PIECE(X,"^"),?20,$EXTRACT($PIECE(M,"^"),1,21),?42,$JUSTIFY($PIECE(X,"^",7),2),?45,$PIECE(X,"^",8),?49
- SET Y=$PIECE(X,"^",6)
- DO DD^LRX
- if L<0
- SET L="Blood bank"
- WRITE Y,?67,L
- QUIT
- +5 ;
- DEL IF $ORDER(^LR(LRDFN,1.8,C,1,0))
- SET ^LR(LRDFN,1.8,C,0)=$PIECE(^LR(LRDFN,1.8,C,0),"^")
- KILL ^LR(LRDFN,1.8,C,2)
- QUIT
- +1 KILL ^LR(LRDFN,1.8,C)
- SET X=^LR(LRDFN,1.8,0)
- SET X(2)=$ORDER(^(0))
- SET X(1)=$PIECE(X,"^",4)
- SET ^(0)="^63.084PA^"_X(2)_"^"_$SELECT(X(1)<2:"",1:X(1)-1)
- QUIT
- END DO V^LRU
- QUIT
- EN KILL LRO
- SET IOM=$SELECT('$DATA(IOM):80,IOM:IOM,1:80)
- +1 WRITE !,"FOR TRANSFUSION REQUESTS: Display instructions for components "
- SET %=2
- DO YN^LRU
- if %<1
- QUIT
- if %=1
- SET LRO=1
- QUIT