- LRBLPD ;AVAMC/REG - BB PT INFO ;2/18/93 09:42 ;
- ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END I LRSS'="BB" W $C(7),!!,"MUST BE BLOOD BANK" G END
- S LRQ=1 D ^LRUL I '$O(^LRO(69.2,LRAA,7,DUZ,1,0)) D R^LRUL G END
- S X=$P(^DD(66,.26,0),U,3),LRF(1)="RBC",LRG(1)="1^RBC",C=1 F A=7:1 S B=$P(X,";",A) Q:B="" S C=C+1,LRG(C)=A_"^"_$P(B,":",2),LRF(A)=$P(B,":",2)
- W !,"List all blood components " S %=1 D YN^LRU G:%<1 END S LRE=$S(%=1:1,1:0) I 'LRE D ASK G:'LRF END
- W !,"List only total number of units for each component " S %=2 D YN^LRU G:%<1 END S LRJ=$S(%=1:1,1:0)
- D B^LRU G:Y<0 END S LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT
- K DIC,DIE,DR S ZTRTN="QUE^LRBLPD" D BEG^LRUTL D:POP R^LRUL G:POP!($D(ZTSK)) END
- QUE U IO D L^LRU,S^LRU
- S DIWL=5,DIWR=IOM-5,DIWF="W",LRC(1.7)="RBC Antibody present:",LRC(1)="RBC Antigen present :",LRC(1.5)="RBC Antigen absent :"
- S LRP=0 F LRP(1)=0:0 S LRP=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) D LOOP
- D EN^LRUL,END^LRUTL,END Q
- LOOP K ^TMP($J) S LRQ=0,SSN=$P(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0),"^",10),X=^LR(LRDFN,0),LRPABO=$P(X,"^",5),LRPRH=$P(X,"^",6),LRDPF=$P(X,U,2) D H S LR("F")=1
- S LRI=LRLDT F B=1:1 S LRI=$O(^LR(LRDFN,1.6,LRI)) Q:'LRI!(LRI>LRSDT) D SET
- S A=0 F B=1:1 S A=$O(^TMP($J,A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") W ! S LRT=0 D N Q:LR("Q") W:LRT !,"Total ",$S($D(LRF(A)):LRF(A),1:"?"),": ",LRT
- Q:LR("Q") I B=1 W !,"No transfused units" W:'LRE " for ",LRF(LRF) W " on record for specified period.",!
- W !! K ^TMP($J) S A=0 F B=0:1 S A=$O(^LR(LRDFN,3,A)) Q:'A!(LR("Q")) S LRX=^(A,0) D:$Y>(IOSL-6) H Q:LR("Q") S X=LRX D ^DIWP
- D:B ^DIWW W ! F C=1.7,1,1.5 Q:LR("Q") W ! S A=0 F B=0:1 S A=$O(^LR(LRDFN,C,A)) Q:'A!(LR("Q")) W:'B LRC(C) W:B ! W ?21,$P(^LAB(61.3,A,0),"^") D:$Y>(IOSL-6) H Q:LR("Q")
- Q
- ;
- SET S X=^LR(LRDFN,1.6,LRI,0),Z=+$P(X,"^",2),Z=$S($D(^LAB(66,Z,0)):^(0),1:""),Y=+$P(Z,"^",19),Z=+$P(Z,"^",26),Z=$S(Y:1,'Z:"?",1:Z) I 'LRE,LRF'=Z Q
- S ^TMP($J,Z,B)=LRI_"^"_X Q
- ;
- ASK S (A,LRF)=0 F B=0:0 S B=$O(LRG(B)) Q:'B W !?13,$J(B,2),?18,$P(LRG(B),"^",2) S A=A+1
- W !!,"Select (1-",A,"): " R X:DTIME Q:X=""!(X[U) I +X'=X!(X<1)!(X>A) W $C(7),!!,"Select a NUMBER from 1 to ",A G ASK
- S LRF=+LRG(X) W ?18,$P(LRG(X),"^",2) Q
- ;
- N F C=0:0 S C=$O(^TMP($J,A,C)) Q:'C!(LR("Q")) S X=^(C),LRI=+X,Y=$P(X,U,2) D D^LRU,O Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
- Q
- O S X(1)=+$P(X,U,3),X(7)=$P(X,U,8),X(10)=$P(X,U,11),M=$S($D(^LAB(66,X(1),0)):$E($P(^(0),U),1,30),1:"component not known"),LRT=LRT+$S(X(7):X(7),1:1)
- Q:LRJ W !,$P(X,"^",4),?18,$E($P(M,"^"),1,30) I X(7)!(X(10)) W ?45,"(",X(7),"/",X(10),")"
- W ?54,$P(X,"^",6)_" "_$P(X,"^",7),?60,Y
- F F=1,2 F E=0:0 S E=$O(^LR(LRDFN,1.6,LRI,F,E)) Q:'E!(LR("Q")) W !?6,^(E,0) D:$Y>(IOSL-6) H Q:LR("Q")
- Q
- ;
- END D V^LRU Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"TRANSFUSION SERVICE/BLOOD BANK REPORT from ",LRSTR," to ",LRLST,!,"PATIENT: ",LRP," ",SSN," ",$J(LRPABO,2)," ",LRPRH
- W:'LRJ !,"Unit Transfused",?18,"Component",?36,"(# of Units/ml )",?60,"Date/Time Completed" W:LRJ !,"Components Transfused" W !,LR("%")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPD 3301 printed Mar 13, 2025@21:16:07 Page 2
- LRBLPD ;AVAMC/REG - BB PT INFO ;2/18/93 09:42 ;
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- IF LRSS'="BB"
- WRITE $CHAR(7),!!,"MUST BE BLOOD BANK"
- GOTO END
- +4 SET LRQ=1
- DO ^LRUL
- IF '$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
- DO R^LRUL
- GOTO END
- +5 SET X=$PIECE(^DD(66,.26,0),U,3)
- SET LRF(1)="RBC"
- SET LRG(1)="1^RBC"
- SET C=1
- FOR A=7:1
- SET B=$PIECE(X,";",A)
- if B=""
- QUIT
- SET C=C+1
- SET LRG(C)=A_"^"_$PIECE(B,":",2)
- SET LRF(A)=$PIECE(B,":",2)
- +6 WRITE !,"List all blood components "
- SET %=1
- DO YN^LRU
- if %<1
- GOTO END
- SET LRE=$SELECT(%=1:1,1:0)
- IF 'LRE
- DO ASK
- if 'LRF
- GOTO END
- +7 WRITE !,"List only total number of units for each component "
- SET %=2
- DO YN^LRU
- if %<1
- GOTO END
- SET LRJ=$SELECT(%=1:1,1:0)
- +8 DO B^LRU
- if Y<0
- GOTO END
- SET LRLDT=9999998-LRLDT
- SET LRSDT=9999999-LRSDT
- +9 KILL DIC,DIE,DR
- SET ZTRTN="QUE^LRBLPD"
- DO BEG^LRUTL
- if POP
- DO R^LRUL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO L^LRU
- DO S^LRU
- +1 SET DIWL=5
- SET DIWR=IOM-5
- SET DIWF="W"
- SET LRC(1.7)="RBC Antibody present:"
- SET LRC(1)="RBC Antigen present :"
- SET LRC(1.5)="RBC Antigen absent :"
- +2 SET LRP=0
- FOR LRP(1)=0:0
- SET LRP=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP))
- if LRP=""!(LR("Q"))
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",LRP,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- DO LOOP
- +3 DO EN^LRUL
- DO END^LRUTL
- DO END
- QUIT
- LOOP KILL ^TMP($JOB)
- SET LRQ=0
- SET SSN=$PIECE(^LRO(69.2,LRAA,7,DUZ,1,LRDFN,0),"^",10)
- SET X=^LR(LRDFN,0)
- SET LRPABO=$PIECE(X,"^",5)
- SET LRPRH=$PIECE(X,"^",6)
- SET LRDPF=$PIECE(X,U,2)
- DO H
- SET LR("F")=1
- +1 SET LRI=LRLDT
- FOR B=1:1
- SET LRI=$ORDER(^LR(LRDFN,1.6,LRI))
- if 'LRI!(LRI>LRSDT)
- QUIT
- DO SET
- +2 SET A=0
- FOR B=1:1
- SET A=$ORDER(^TMP($JOB,A))
- if A=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !
- SET LRT=0
- DO N
- if LR("Q")
- QUIT
- if LRT
- WRITE !,"Total ",$SELECT($DATA(LRF(A)):LRF(A),1:"?"),": ",LRT
- +3 if LR("Q")
- QUIT
- IF B=1
- WRITE !,"No transfused units"
- if 'LRE
- WRITE " for ",LRF(LRF)
- WRITE " on record for specified period.",!
- +4 WRITE !!
- KILL ^TMP($JOB)
- SET A=0
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,3,A))
- if 'A!(LR("Q"))
- QUIT
- SET LRX=^(A,0)
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- SET X=LRX
- DO ^DIWP
- +5 if B
- DO ^DIWW
- WRITE !
- FOR C=1.7,1,1.5
- if LR("Q")
- QUIT
- WRITE !
- SET A=0
- FOR B=0:1
- SET A=$ORDER(^LR(LRDFN,C,A))
- if 'A!(LR("Q"))
- QUIT
- if 'B
- WRITE LRC(C)
- if B
- WRITE !
- WRITE ?21,$PIECE(^LAB(61.3,A,0),"^")
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- +6 QUIT
- +7 ;
- SET SET X=^LR(LRDFN,1.6,LRI,0)
- SET Z=+$PIECE(X,"^",2)
- SET Z=$SELECT($DATA(^LAB(66,Z,0)):^(0),1:"")
- SET Y=+$PIECE(Z,"^",19)
- SET Z=+$PIECE(Z,"^",26)
- SET Z=$SELECT(Y:1,'Z:"?",1:Z)
- IF 'LRE
- IF LRF'=Z
- QUIT
- +1 SET ^TMP($JOB,Z,B)=LRI_"^"_X
- QUIT
- +2 ;
- ASK SET (A,LRF)=0
- FOR B=0:0
- SET B=$ORDER(LRG(B))
- if 'B
- QUIT
- WRITE !?13,$JUSTIFY(B,2),?18,$PIECE(LRG(B),"^",2)
- SET A=A+1
- +1 WRITE !!,"Select (1-",A,"): "
- READ X:DTIME
- if X=""!(X[U)
- QUIT
- IF +X'=X!(X<1)!(X>A)
- WRITE $CHAR(7),!!,"Select a NUMBER from 1 to ",A
- GOTO ASK
- +2 SET LRF=+LRG(X)
- WRITE ?18,$PIECE(LRG(X),"^",2)
- QUIT
- +3 ;
- N FOR C=0:0
- SET C=$ORDER(^TMP($JOB,A,C))
- if 'C!(LR("Q"))
- QUIT
- SET X=^(C)
- SET LRI=+X
- SET Y=$PIECE(X,U,2)
- DO D^LRU
- DO O
- if LR("Q")
- QUIT
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- +1 QUIT
- O SET X(1)=+$PIECE(X,U,3)
- SET X(7)=$PIECE(X,U,8)
- SET X(10)=$PIECE(X,U,11)
- SET M=$SELECT($DATA(^LAB(66,X(1),0)):$EXTRACT($PIECE(^(0),U),1,30),1:"component not known")
- SET LRT=LRT+$SELECT(X(7):X(7),1:1)
- +1 if LRJ
- QUIT
- WRITE !,$PIECE(X,"^",4),?18,$EXTRACT($PIECE(M,"^"),1,30)
- IF X(7)!(X(10))
- WRITE ?45,"(",X(7),"/",X(10),")"
- +2 WRITE ?54,$PIECE(X,"^",6)_" "_$PIECE(X,"^",7),?60,Y
- +3 FOR F=1,2
- FOR E=0:0
- SET E=$ORDER(^LR(LRDFN,1.6,LRI,F,E))
- if 'E!(LR("Q"))
- QUIT
- WRITE !?6,^(E,0)
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- +4 QUIT
- +5 ;
- END DO V^LRU
- QUIT
- +1 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"TRANSFUSION SERVICE/BLOOD BANK REPORT from ",LRSTR," to ",LRLST,!,"PATIENT: ",LRP," ",SSN," ",$JUSTIFY(LRPABO,2)," ",LRPRH
- +2 if 'LRJ
- WRITE !,"Unit Transfused",?18,"Component",?36,"(# of Units/ml )",?60,"Date/Time Completed"
- if LRJ
- WRITE !,"Components Transfused"
- WRITE !,LR("%")
- +3 QUIT
