- LRBLDPH ;AVAMC/REG - DONOR PHENOTYPING ;3/9/94 12:51
- ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- Q D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END S IOP="HOME" D ^%ZIS,L^LRU I LRCAPA S X="DONOR PHENOTYPING",X("NOCODES")=1 D X^LRUWK G:'$D(X) END
- D S (DIC,DIE)="^LRE(",DIC(0)="AEQM",D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") W ! D MIX^DIC1 K DIC G:Y<1 END D REST K LR("CK") G D
- REST S (DA,LRQ)=+Y D CK^LRU Q:$D(LR("CK")) S Y=$O(^LRE(DA,5,0)) I 'Y W $C(7),!,"Must have donation date to enter phenotyping." Q
- W ! S DIC="^LRE(LRQ,5,",DIC(0)="AEQM",DIC("A")="Select donation date phenotyping specimen taken: ",DIC("B")=+^LRE(DA,5,Y,0) D ^DIC K DIC Q:Y<1 S LRI=+Y
- D P S DA=LRQ,DIE="^LRE(",DR="[LRBLDAG]" D ^DIE D FRE^LRU D:LRCAPA WK
- S DA(1)=LRQ F LRM=0:0 S LRM=$O(LRM(LRM)) Q:'LRM F M=0:0 S M=$O(LRM(LRM,M)) Q:'M I '$D(^LRE(LRQ,LRM,M)) S O=M,X="deleted",Z=LRM(LRM,M)_",.01" D EN^LRUD
- K M,LRM,O Q
- ;
- P I '$O(^LRE(LRQ,1.1,0)),'$O(^LRE(LRQ,1.2,0)) Q
- W !!?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%"),!,"Donor Phenotype Record:"
- S E=1,(F(1),G)="" F B=0:0 S B=$O(^LRE(LRQ,1.1,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(^LRE(LRQ,1.2,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 ! Q
- ;
- WK D DT^LRBLU K LRG ;enter workload
- S:'$D(^LRE(LRQ,5,LRI,99,0)) ^(0)="^65.599PA^^" I '$D(^(LRT,0)) S ^(0)=LRT,X=^LRE(LRQ,5,LRI,99,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
- S:'$D(^LRE(LRQ,5,LRI,99,LRT,1,0)) ^(0)="^65.5991DA^^" I '$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,0)) S ^(0)=LRK_"^"_DUZ,X=^LRE(LRQ,5,LRI,99,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_LRK_"^"_($P(X,"^",4)+1)
- F A=1.1,1.2,1.3,1.4 F B=0:0 S B=$O(^LRE(LRQ,A,B)) Q:'B I '$D(LRM(A,B)) F C=0:0 S C=$O(^LAB(61.3,B,9,C)) Q:'C D STF
- S:$D(LRG) ^LRE("AA",LRQ,LRI,LRT,LRK)=$P(^LRE(LRQ,5,LRI,0),"^",4) I '$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0)) K ^LRE(LRQ,5,LRI,99,LRT,1,LRK) S X=^LRE(LRQ,5,LRI,99,LRT,1,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
- Q
- STF S LRG=1 I $D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,C,0)) S X=$P(^(0),"^",2) S:'X X=1 S X=X+1,$P(^(0),"^",2,3)=X_"^"_0 Q
- S:'$D(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0)) ^(0)="^65.59911PA^^" S X=^(0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1),^(C,0)=C_"^"_1 Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDPH 2609 printed Mar 13, 2025@21:15:05 Page 2
- LRBLDPH ;AVAMC/REG - DONOR PHENOTYPING ;3/9/94 12:51
- +1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 QUIT
- DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- if Y=-1
- GOTO END
- SET IOP="HOME"
- DO ^%ZIS
- DO L^LRU
- IF LRCAPA
- SET X="DONOR PHENOTYPING"
- SET X("NOCODES")=1
- DO X^LRUWK
- if '$DATA(X)
- GOTO END
- D SET (DIC,DIE)="^LRE("
- SET DIC(0)="AEQM"
- SET D="B^C^"_$SELECT("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D")
- WRITE !
- DO MIX^DIC1
- KILL DIC
- if Y<1
- GOTO END
- DO REST
- KILL LR("CK")
- GOTO D
- REST SET (DA,LRQ)=+Y
- DO CK^LRU
- if $DATA(LR("CK"))
- QUIT
- SET Y=$ORDER(^LRE(DA,5,0))
- IF 'Y
- WRITE $CHAR(7),!,"Must have donation date to enter phenotyping."
- QUIT
- +1 WRITE !
- SET DIC="^LRE(LRQ,5,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select donation date phenotyping specimen taken: "
- SET DIC("B")=+^LRE(DA,5,Y,0)
- DO ^DIC
- KILL DIC
- if Y<1
- QUIT
- SET LRI=+Y
- +2 DO P
- SET DA=LRQ
- SET DIE="^LRE("
- SET DR="[LRBLDAG]"
- DO ^DIE
- DO FRE^LRU
- if LRCAPA
- DO WK
- +3 SET DA(1)=LRQ
- FOR LRM=0:0
- SET LRM=$ORDER(LRM(LRM))
- if 'LRM
- QUIT
- FOR M=0:0
- SET M=$ORDER(LRM(LRM,M))
- if 'M
- QUIT
- IF '$DATA(^LRE(LRQ,LRM,M))
- SET O=M
- SET X="deleted"
- SET Z=LRM(LRM,M)_",.01"
- DO EN^LRUD
- +4 KILL M,LRM,O
- QUIT
- +5 ;
- P IF '$ORDER(^LRE(LRQ,1.1,0))
- IF '$ORDER(^LRE(LRQ,1.2,0))
- QUIT
- +1 WRITE !!?40,"Antigen(s) present",?60,"| Antigen(s) absent",!,LR("%"),!,"Donor Phenotype Record:"
- +2 SET E=1
- SET (F(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LRE(LRQ,1.1,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=""
- +3 SET K=E
- SET E=1
- SET (J(1),G)=""
- FOR B=0:0
- SET B=$ORDER(^LRE(LRQ,1.2,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=""
- +4 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)
- +5 WRITE !
- QUIT
- +6 ;
- WK ;enter workload
- DO DT^LRBLU
- KILL LRG
- +1 if '$DATA(^LRE(LRQ,5,LRI,99,0))
- SET ^(0)="^65.599PA^^"
- IF '$DATA(^(LRT,0))
- SET ^(0)=LRT
- SET X=^LRE(LRQ,5,LRI,99,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
- +2 if '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,0))
- SET ^(0)="^65.5991DA^^"
- IF '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,0))
- SET ^(0)=LRK_"^"_DUZ
- SET X=^LRE(LRQ,5,LRI,99,LRT,1,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRK_"^"_($PIECE(X,"^",4)+1)
- +3 FOR A=1.1,1.2,1.3,1.4
- FOR B=0:0
- SET B=$ORDER(^LRE(LRQ,A,B))
- if 'B
- QUIT
- IF '$DATA(LRM(A,B))
- FOR C=0:0
- SET C=$ORDER(^LAB(61.3,B,9,C))
- if 'C
- QUIT
- DO STF
- +4 if $DATA(LRG)
- SET ^LRE("AA",LRQ,LRI,LRT,LRK)=$PIECE(^LRE(LRQ,5,LRI,0),"^",4)
- IF '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0))
- KILL ^LRE(LRQ,5,LRI,99,LRT,1,LRK)
- SET X=^LRE(LRQ,5,LRI,99,LRT,1,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- +5 QUIT
- STF SET LRG=1
- IF $DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,C,0))
- SET X=$PIECE(^(0),"^",2)
- if 'X
- SET X=1
- SET X=X+1
- SET $PIECE(^(0),"^",2,3)=X_"^"_0
- QUIT
- +1 if '$DATA(^LRE(LRQ,5,LRI,99,LRT,1,LRK,1,0))
- SET ^(0)="^65.59911PA^^"
- SET X=^(0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)
- SET ^(C,0)=C_"^"_1
- QUIT
- +2 ;
- END DO V^LRU
- QUIT
