LRBLCMV ;AVAMC/REG - UNIT PHENOTYPE BY ABO/RH ;9/13/89 19:30 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END W !!?20,"CMV ANTIBODY tested units" S:'$D(DTIME) DTIME=60 S C(9)="POSNEG"
SEL W !!,"Select CMV ANTIBODY: NEG// " R X:DTIME G:X[U!'$T END S:X="" X="NEG"
I X'?1"N".U&(X'?1"P".U)!($L(X)>3)!(C(9)'[X) W $C(7),!,"Enter 'POS' for CMV ANTIBODY POSITIVE units",!,"Enter 'NEG' for CMV ANTIBODY NEGATIVE units." G SEL
S X(1)=$S($A(X)=80:"POS",1:"NEG") W $E(X(1),$L(X)+1,3)
S LRV=$S(X="NEG":0,1:1)
S DIC="^LAB(66,",DIC(0)="AEQM",DIC("A")="Select BLOOD COMPONENT: " D ^DIC K DIC G:X=""!(X[U) END S C=+Y,C(1)=$P(Y,U,2)
ABO R !,"Select ABO group: ",C(7):DTIME Q:C(7)["^"!(C(7)="") I C(7)'="A"&(C(7)'="B")&(C(7)'="O")&(C(7)'="AB") W $C(7),!,"Enter A, B, AB or O" G ABO
RH R !,"Select Rh type: ",X:DTIME Q:X=""!(X["^") I X'?1"N".U&(X'?1"P".U)!($L(X)>3)!(C(9)'[X) W $C(7)," Enter 'NEG' or 'POS'" G RH
S C(8)=$S($A(X)=80:"POS",1:"NEG") W $E(C(8),$L(X)+1,3)
S ZTRTN="QUE^LRBLCMV" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU S X="N",%DT="T",Z=0 D ^%DT S N=Y,H=$P(Y,".") D D^LRU S Z(1)=Y D H S LR("F")=1
S A=0 F B=0:1 S A=$O(^LRD(65,"AI",C,A)) Q:A=""!(LR("Q")) S Q=$O(^LRD(65,"AI",C,A,0)) Q:'Q D I
W:'Z !!,"No CMV ANTIBODY ",$S(LRV=0:"NEG",1:"POS")," ",C(7)," ",C(8)," ",C(1),"." D END,END^LRUTL Q
;
I I Q[".",Q<N K ^LRD(65,"AI",C,A,Q) Q
I Q<H K ^LRD(65,"AI",C,A,Q) Q
K F,J S V=+$O(^LRD(65,"AI",C,A,Q,0)) Q:'$D(^LRD(65,V,0)) S F=^(0) Q:$P(F,"^",15)'=LRV
Q:$P(F,"^",7)'=C(7)!($P(F,"^",8)'=C(8))
S Z=Z+1 D:$Y>(IOSL-6) H Q:LR("Q") W !,$J(Z,3),")",?5,$P(F,"^"),?20 S Y=$P(F,"^",6) D DT^LRU W Y
W !,LR("%") Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"LABORATORY SERVICE",!,C(1)," ",C(7)," ",C(8)," CMV ",$S(LRV:"POS",1:"NEG")," units"
W !?5,"Unit",?20,"Exp date",?40,!,LR("%") Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLCMV 1955 printed Apr 09, 2024@21:17:43 Page 2
LRBLCMV ;AVAMC/REG - UNIT PHENOTYPE BY ABO/RH ;9/13/89 19:30 ;
+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
WRITE !!?20,"CMV ANTIBODY tested units"
if '$DATA(DTIME)
SET DTIME=60
SET C(9)="POSNEG"
SEL WRITE !!,"Select CMV ANTIBODY: NEG// "
READ X:DTIME
if X[U!'$TEST
GOTO END
if X=""
SET X="NEG"
+1 IF X'?1"N".U&(X'?1"P".U)!($LENGTH(X)>3)!(C(9)'[X)
WRITE $CHAR(7),!,"Enter 'POS' for CMV ANTIBODY POSITIVE units",!,"Enter 'NEG' for CMV ANTIBODY NEGATIVE units."
GOTO SEL
+2 SET X(1)=$SELECT($ASCII(X)=80:"POS",1:"NEG")
WRITE $EXTRACT(X(1),$LENGTH(X)+1,3)
+3 SET LRV=$SELECT(X="NEG":0,1:1)
+4 SET DIC="^LAB(66,"
SET DIC(0)="AEQM"
SET DIC("A")="Select BLOOD COMPONENT: "
DO ^DIC
KILL DIC
if X=""!(X[U)
GOTO END
SET C=+Y
SET C(1)=$PIECE(Y,U,2)
ABO READ !,"Select ABO group: ",C(7):DTIME
if C(7)["^"!(C(7)="")
QUIT
IF C(7)'="A"&(C(7)'="B")&(C(7)'="O")&(C(7)'="AB")
WRITE $CHAR(7),!,"Enter A, B, AB or O"
GOTO ABO
RH READ !,"Select Rh type: ",X:DTIME
if X=""!(X["^")
QUIT
IF X'?1"N".U&(X'?1"P".U)!($LENGTH(X)>3)!(C(9)'[X)
WRITE $CHAR(7)," Enter 'NEG' or 'POS'"
GOTO RH
+1 SET C(8)=$SELECT($ASCII(X)=80:"POS",1:"NEG")
WRITE $EXTRACT(C(8),$LENGTH(X)+1,3)
+2 SET ZTRTN="QUE^LRBLCMV"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
SET X="N"
SET %DT="T"
SET Z=0
DO ^%DT
SET N=Y
SET H=$PIECE(Y,".")
DO D^LRU
SET Z(1)=Y
DO H
SET LR("F")=1
+1 SET A=0
FOR B=0:1
SET A=$ORDER(^LRD(65,"AI",C,A))
if A=""!(LR("Q"))
QUIT
SET Q=$ORDER(^LRD(65,"AI",C,A,0))
if 'Q
QUIT
DO I
+2 if 'Z
WRITE !!,"No CMV ANTIBODY ",$SELECT(LRV=0:"NEG",1:"POS")," ",C(7)," ",C(8)," ",C(1),"."
DO END
DO END^LRUTL
QUIT
+3 ;
I IF Q["."
IF Q<N
KILL ^LRD(65,"AI",C,A,Q)
QUIT
+1 IF Q<H
KILL ^LRD(65,"AI",C,A,Q)
QUIT
+2 KILL F,J
SET V=+$ORDER(^LRD(65,"AI",C,A,Q,0))
if '$DATA(^LRD(65,V,0))
QUIT
SET F=^(0)
if $PIECE(F,"^",15)'=LRV
QUIT
+3 if $PIECE(F,"^",7)'=C(7)!($PIECE(F,"^",8)'=C(8))
QUIT
+4 SET Z=Z+1
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,$JUSTIFY(Z,3),")",?5,$PIECE(F,"^"),?20
SET Y=$PIECE(F,"^",6)
DO DT^LRU
WRITE Y
+5 WRITE !,LR("%")
QUIT
+6 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"LABORATORY SERVICE",!,C(1)," ",C(7)," ",C(8)," CMV ",$SELECT(LRV:"POS",1:"NEG")," units"
+2 WRITE !?5,"Unit",?20,"Exp date",?40,!,LR("%")
QUIT
END DO V^LRU
QUIT
