- LRBLJPH ; IHS/DIR/FJE - UNIT PHENOTYPE BY ABO/RH 2/18/93 09:26 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END W !!,"Phenotyped units" S C(9)="POSNEG"
- 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 G:X=""!(X["^") END 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^LRBLJPH" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D L^LRU,S^LRU S Z=0,X="N",%DT="T" D ^%DT S N=Y,H=$P(Y,".") D D^LRU S Z(1)=Y D H S LR("F")=1
- F X=0:0 S X=$O(^LAB(66,X)) Q:'X S Y=^(X,0) I $P(Y,"^",19) S LRC(X)=""
- F C=0:0 S C=$O(LRC(C)) Q:'C!(LR("Q")) D A
- W:'Z !!,"No phenotyped ",C(7)," ",C(8)," units available !" D END,END^LRUTL Q
- ;
- A S (A,LRE)=0 F LRB=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
- 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,"^",7)'=C(7)!($P(F,"^",8)'=C(8))
- I '$O(^LRD(65,V,60,0)),'$O(^LRD(65,V,70,0)) Q
- S LRE=LRE+1 W:LRE=1 !!,$P(^LAB(66,C,0),U),":" S Z=Z+1 D:$Y>(IOSL-6) H1 Q:LR("Q") W !,$J(Z,3),")" W ?5,$P(F,"^"),?20 S Y=$P(F,"^",6) D D^LRU W Y
- F LRDFN=0:0 S LRDFN=$O(^LRD(65,V,2,LRDFN)) Q:'LRDFN!(LR("Q")) I $D(^LRD(65,"AP",LRDFN,V)) D P W !,"Assigned:",$P(X,"^")
- S E=1,(F(1),G)="" F B=0:0 S B=$O(^LRD(65,V,60,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),F(E)=F(E)_I_" ",G=G+1 I $L(F(E))>19 S F(E)=$P(F(E)," ",1,G-1),E=E+1,F(E)=I_" ",G=""
- S K=E,E=1,(J(1),G)="" F B=0:0 S B=$O(^LRD(65,V,70,B)) Q:'B S I=$P(^LAB(61.3,B,0),"^"),J(E)=J(E)_I_" ",G=G+1 I $L(J(E))>18 S J(E)=$P(J(E)," ",1,G-1),E=E+1,J(E)=I_" ",G=""
- S:E>K K=E F E=1:1:K W:E>1 ! W:$D(F(E)) ?40,$J(F(E),19) W:$D(J(E)) ?60,"|",$J(J(E),18)
- W !,LR("%") Q
- ;
- P S X=^LR(LRDFN,0),Y=$P(X,"^",3),X=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)") Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"LABORATORY SERVICE",?40,C(7)," ",C(8)," Phenotyped units"
- W !,"Count",?6,"Unit ID",?20,"Exp date",?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%") Q
- H1 D H Q:LR("Q") W !!,$P(^LAB(66,C,0),U) Q
- END D V^LRU Q
- LRBLJPH ; IHS/DIR/FJE - UNIT PHENOTYPE BY ABO/RH 2/18/93 09:26 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- WRITE !!,"Phenotyped units"
- SET C(9)="POSNEG"
- 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["^")
- GOTO END
- 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^LRBLJPH"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO L^LRU
- DO S^LRU
- SET Z=0
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET N=Y
- SET H=$PIECE(Y,".")
- DO D^LRU
- SET Z(1)=Y
- DO H
- SET LR("F")=1
- +1 FOR X=0:0
- SET X=$ORDER(^LAB(66,X))
- IF 'X
- QUIT
- SET Y=^(X,0)
- IF $PIECE(Y,"^",19)
- SET LRC(X)=""
- +2 FOR C=0:0
- SET C=$ORDER(LRC(C))
- IF 'C!(LR("Q"))
- QUIT
- DO A
- +3 IF 'Z
- WRITE !!,"No phenotyped ",C(7)," ",C(8)," units available !"
- DO END
- DO END^LRUTL
- QUIT
- +4 ;
- A SET (A,LRE)=0
- FOR LRB=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
- +1 QUIT
- 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)
- +3 IF $PIECE(F,"^",7)'=C(7)!($PIECE(F,"^",8)'=C(8))
- QUIT
- +4 IF '$ORDER(^LRD(65,V,60,0))
- IF '$ORDER(^LRD(65,V,70,0))
- QUIT
- +5 SET LRE=LRE+1
- IF LRE=1
- WRITE !!,$PIECE(^LAB(66,C,0),U),":"
- SET Z=Z+1
- IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- WRITE !,$JUSTIFY(Z,3),")"
- WRITE ?5,$PIECE(F,"^"),?20
- SET Y=$PIECE(F,"^",6)
- DO D^LRU
- WRITE Y
- +6 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LRD(65,V,2,LRDFN))
- IF 'LRDFN!(LR("Q"))
- QUIT
- IF $DATA(^LRD(65,"AP",LRDFN,V))
- DO P
- WRITE !,"Assigned:",$PIECE(X,"^")
- +7 SET E=1
- SET (F(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LRD(65,V,60,B))
- IF 'B
- QUIT
- SET I=$PIECE(^LAB(61.3,B,0),"^")
- SET F(E)=F(E)_I_" "
- SET G=G+1
- IF $LENGTH(F(E))>19
- SET F(E)=$PIECE(F(E)," ",1,G-1)
- SET E=E+1
- SET F(E)=I_" "
- SET G=""
- +8 SET K=E
- SET E=1
- SET (J(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LRD(65,V,70,B))
- IF 'B
- QUIT
- SET I=$PIECE(^LAB(61.3,B,0),"^")
- SET J(E)=J(E)_I_" "
- SET G=G+1
- IF $LENGTH(J(E))>18
- SET J(E)=$PIECE(J(E)," ",1,G-1)
- SET E=E+1
- SET J(E)=I_" "
- SET G=""
- +9 IF E>K
- SET K=E
- FOR E=1:1:K
- IF E>1
- WRITE !
- IF $DATA(F(E))
- WRITE ?40,$JUSTIFY(F(E),19)
- IF $DATA(J(E))
- WRITE ?60,"|",$JUSTIFY(J(E),18)
- +10 WRITE !,LR("%")
- QUIT
- +11 ;
- P SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET X=^DIC($PIECE(X,"^",2),0,"GL")
- SET X=@(X_Y_",0)")
- QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"LABORATORY SERVICE",?40,C(7)," ",C(8)," Phenotyped units"
- +2 WRITE !,"Count",?6,"Unit ID",?20,"Exp date",?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%")
- QUIT
- H1 DO H
- IF LR("Q")
- QUIT
- WRITE !!,$PIECE(^LAB(66,C,0),U)
- QUIT
- END DO V^LRU
- QUIT
