- LRBLPUS1 ;AVAMC/REG/CYM - PATIENT UNIT SELECTION ;11/12/96 21:05 ; 11/30/00 4:21pm
- ;;5.2;LAB SERVICE;**72,139,247,267**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ;References to ^DIC(4 in this routine are covered by DBIA 2508
- K A,LRB(1),F,Z S Z=0,X="N",%DT="T" D ^%DT S N=Y,H=$P(Y,".") W !! S X=$$READ^LRBLB("Select UNIT: ")
- Q:X=""!(X[U) I X["?"!(X=" ") D H G LRBLPUS1
- I LR,$E(X,1,$L(LR(2)))=LR(2) D
- .D ^LRBLBU
- E W $$STRIP^LRBLB(.X) ; Strip off the data identifiers just in case
- Q:'$D(X)
- S DIC=65,DIC(0)="EQM",DIC("W")="W "" "",$P(^(0),U)",DIC("S")="I $P(^(0),U,16)=DUZ(2),$P(^(0),U,4)=C,$S('$D(^(4)):1,$P(^(4),U)="""":1,1:0)" D ^DIC K DIC S X=$P(Y,U,2)
- I Y<1 W $C(7)," Enter a valid unit",!!,"You can only select units from your division [",LRAA(4),"]",!,"even though units from other divisions may be displayed." G LRBLPUS1
- S Y=+Y L +^LRD(65,Y):2 I '$T W !!,$C(7),"This unit currently unavailable. Please try another ",!! G ^LRBLPUS1
- D ALL G LRBLPUS1
- ALL S LRB(1)=1,Q=$O(^LRD(65,"AI",C,X,0)) I Q S A=X,Q=$O(^LRD(65,"AI",C,A,0)) Q:'Q W !?3 D I G:$D(F) ^LRBLPUS2
- K ^TMP($J) W !?3 S A(2)="",Z(1)=1,A=X D D G ^LRBLPUS2:$D(F) I A(2)?1P W $C(7) Q
- I X'["E",X=+X,+$O(^LRD(65,"AI",X))=X S A=X_"?" D D
- G ^LRBLPUS2:$D(F) W $C(7) Q
- ;
- H I '$D(^LRD(65,"AI",C)) W $C(7),!!,"No units to choose from !",! Q
- I X'["??" W !,"ANSWER WITH UNIT ID",!,"DO YOU WANT THE ENTIRE ",LRAA(4)," ",$P(^LRD(65,0),U)," LIST ? " S %="" D RX^LRU Q:%'=1
- S LR("M")=DUZ(2) I $P($G(^LAB(69.9,1,8.1,DUZ(2),0)),U,6) W !!,"DISPLAY AVAILABLE UNITS FROM OTHER DIVISIONS AS WELL" S %=2 D YN^LRU Q:%<1 S:%=1 LR("M")=""
- S (A,A(2))=0,A(1)=$Y+21 W !?3 F B=0:0 S A=$O(^LRD(65,"AI",C,A)) Q:A="" F Q=0:0 S Q=$O(^LRD(65,"AI",C,A,Q)) Q:'Q D:$Y>A(1)!'$Y MORE Q:A(2)?1P 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
- S V=$O(^LRD(65,"AI",C,A,Q,0)) I $D(^LRD(65,+V,4)),$P(^(4),"^")]"" K ^LRD(65,"AI",C,A,Q,V) Q
- I LR("M") Q:$P($G(^LRD(65,V,0)),"^",16)'=DUZ(2)
- I $D(^LRD(65,V,8)),+^(8) S Y=^(8) Q:+Y&(LRDFN'=+Y) W $S($P(Y,"^",3)="A":"aut",$P(Y,"^",3)="D":"dir",1:"")
- S F=V_"^"_^LRD(65,V,0) I C(19),$P(F,"^",9)="POS",$D(R(LRB)) W:$D(LRB(1)) $C(7),!,$P(F,"^",2)," is Rh positive and the patient has ANTI-D antibodies." K F Q
- I C(7)+C(8) S I(7)=$P(F,"^",8),I(8)=$P(F,"^",9) D OK Q:'$D(F)
- S Z=Z+1 W:$D(Z(1)) $J(Z,2) W ?7,$P(F,"^",2),?20,$J($P(F,"^",8),2)," ",$P(F,"^",9) S Y=$P(F,"^",7) D DT^LRU W ?28,Y S Y=$P(F,"^",12) I Y,Y<LRV W "(",Y,"ml)"
- S Y=+$P(F,"^",17) I Y'=DUZ(2) W ?45,$P($G(^DIC(4,Y,0)),U)
- I C(9)=1,$D(R) S O=0 F O(1)=0:1 S O=$O(^LRD(65,V,70,O)) Q:'O W:'O(1) !?48,"Antigen(s) ABSENT:" W !?48,$P(^LAB(61.3,O,0),"^")
- W !?3 Q
- ;
- D K F F B=0:0 S A=$O(^LRD(65,"AI",C,A)) Q:$E(A,1,$L(X))'=X F Q=0:0 S Q=$O(^LRD(65,"AI",C,A,Q)) Q:'Q!($A(A)>122) D I I $D(F) S ^TMP($J,Z)=F K F I Z#5=0 D C Q:A(2)?1P
- D:Z#5&('$D(F)) C Q
- ;
- OK I C(7)=1,I(7)'=LRPABO K F Q
- I C(8)=1,I(8)'=LRPRH K F Q
- I C(7)=1,C(8)=1 G CK
- I C(7) D @($S(C(9)'=2:LRPABO,1:LRPABO_"P")) Q:'$D(F)
- I C(8),LRPRH="NEG"&(I(8)="POS") K F Q
- CK S O=0 I $D(LRK) F O=0:0 S O=$O(^LRD(65,V,2,O)) Q:'O I $D(^LRD(65,"AP",O,V)) Q
- I O>0 K F Q
- I C(9)=1,$D(R) S O=0 F O(1)=0:1 S O=$O(^LRD(65,V,60,O)) Q:'O I $D(R(O)) K F Q
- Q
- O K:"AB"[I(7) F Q
- A K:I(7)["B" F Q
- B K:I(7)["A" F Q
- AB Q
- OP Q
- AP K:I(7)="B"!(I(7)="O") F Q
- BP K:I(7)="A"!(I(7)="O") F Q
- ABP K:I(7)'="AB" F Q
- ;
- MORE R "'^' TO STOP: ",A(2):DTIME I A(2)?1P S A=$C(126) Q
- S A(1)=A(1)+21 S:$Y<22 A(1)=$Y+21 W $C(13),$J("",15),$C(13),?3 Q
- C I Z=1 S A(2)=1 G F
- W $C(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z R ": ",A(2):DTIME I A(2)?1P!'$T S A=$C(126) Q
- I A(2)="" W !?3 Q
- F I A(2)>0,A(2)<(Z+1) S F=^TMP($J,A(2))
- S A(2)="^",A=$C(126) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPUS1 3783 printed Mar 13, 2025@21:16:26 Page 2
- LRBLPUS1 ;AVAMC/REG/CYM - PATIENT UNIT SELECTION ;11/12/96 21:05 ; 11/30/00 4:21pm
- +1 ;;5.2;LAB SERVICE;**72,139,247,267**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ;References to ^DIC(4 in this routine are covered by DBIA 2508
- +4 KILL A,LRB(1),F,Z
- SET Z=0
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET N=Y
- SET H=$PIECE(Y,".")
- WRITE !!
- SET X=$$READ^LRBLB("Select UNIT: ")
- +5 if X=""!(X[U)
- QUIT
- IF X["?"!(X=" ")
- DO H
- GOTO LRBLPUS1
- +6 IF LR
- IF $EXTRACT(X,1,$LENGTH(LR(2)))=LR(2)
- Begin DoDot:1
- +7 DO ^LRBLBU
- End DoDot:1
- +8 ; Strip off the data identifiers just in case
- IF '$TEST
- WRITE $$STRIP^LRBLB(.X)
- +9 if '$DATA(X)
- QUIT
- +10 SET DIC=65
- SET DIC(0)="EQM"
- SET DIC("W")="W "" "",$P(^(0),U)"
- SET DIC("S")="I $P(^(0),U,16)=DUZ(2),$P(^(0),U,4)=C,$S('$D(^(4)):1,$P(^(4),U)="""":1,1:0)"
- DO ^DIC
- KILL DIC
- SET X=$PIECE(Y,U,2)
- +11 IF Y<1
- WRITE $CHAR(7)," Enter a valid unit",!!,"You can only select units from your division [",LRAA(4),"]",!,"even though units from other divisions may be displayed."
- GOTO LRBLPUS1
- +12 SET Y=+Y
- LOCK +^LRD(65,Y):2
- IF '$TEST
- WRITE !!,$CHAR(7),"This unit currently unavailable. Please try another ",!!
- GOTO ^LRBLPUS1
- +13 DO ALL
- GOTO LRBLPUS1
- ALL SET LRB(1)=1
- SET Q=$ORDER(^LRD(65,"AI",C,X,0))
- IF Q
- SET A=X
- SET Q=$ORDER(^LRD(65,"AI",C,A,0))
- if 'Q
- QUIT
- WRITE !?3
- DO I
- if $DATA(F)
- GOTO ^LRBLPUS2
- +1 KILL ^TMP($JOB)
- WRITE !?3
- SET A(2)=""
- SET Z(1)=1
- SET A=X
- DO D
- if $DATA(F)
- GOTO ^LRBLPUS2
- IF A(2)?1P
- WRITE $CHAR(7)
- QUIT
- +2 IF X'["E"
- IF X=+X
- IF +$ORDER(^LRD(65,"AI",X))=X
- SET A=X_"?"
- DO D
- +3 if $DATA(F)
- GOTO ^LRBLPUS2
- WRITE $CHAR(7)
- QUIT
- +4 ;
- H IF '$DATA(^LRD(65,"AI",C))
- WRITE $CHAR(7),!!,"No units to choose from !",!
- QUIT
- +1 IF X'["??"
- WRITE !,"ANSWER WITH UNIT ID",!,"DO YOU WANT THE ENTIRE ",LRAA(4)," ",$PIECE(^LRD(65,0),U)," LIST ? "
- SET %=""
- DO RX^LRU
- if %'=1
- QUIT
- +2 SET LR("M")=DUZ(2)
- IF $PIECE($GET(^LAB(69.9,1,8.1,DUZ(2),0)),U,6)
- WRITE !!,"DISPLAY AVAILABLE UNITS FROM OTHER DIVISIONS AS WELL"
- SET %=2
- DO YN^LRU
- if %<1
- QUIT
- if %=1
- SET LR("M")=""
- +3 SET (A,A(2))=0
- SET A(1)=$Y+21
- WRITE !?3
- FOR B=0:0
- SET A=$ORDER(^LRD(65,"AI",C,A))
- if A=""
- QUIT
- FOR Q=0:0
- SET Q=$ORDER(^LRD(65,"AI",C,A,Q))
- if 'Q
- QUIT
- if $Y>A(1)!'$Y
- DO MORE
- if A(2)?1P
- QUIT
- DO I
- +4 QUIT
- +5 ;
- 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 SET V=$ORDER(^LRD(65,"AI",C,A,Q,0))
- IF $DATA(^LRD(65,+V,4))
- IF $PIECE(^(4),"^")]""
- KILL ^LRD(65,"AI",C,A,Q,V)
- QUIT
- +3 IF LR("M")
- if $PIECE($GET(^LRD(65,V,0)),"^",16)'=DUZ(2)
- QUIT
- +4 IF $DATA(^LRD(65,V,8))
- IF +^(8)
- SET Y=^(8)
- if +Y&(LRDFN'=+Y)
- QUIT
- WRITE $SELECT($PIECE(Y,"^",3)="A":"aut",$PIECE(Y,"^",3)="D":"dir",1:"")
- +5 SET F=V_"^"_^LRD(65,V,0)
- IF C(19)
- IF $PIECE(F,"^",9)="POS"
- IF $DATA(R(LRB))
- if $DATA(LRB(1))
- WRITE $CHAR(7),!,$PIECE(F,"^",2)," is Rh positive and the patient has ANTI-D antibodies."
- KILL F
- QUIT
- +6 IF C(7)+C(8)
- SET I(7)=$PIECE(F,"^",8)
- SET I(8)=$PIECE(F,"^",9)
- DO OK
- if '$DATA(F)
- QUIT
- +7 SET Z=Z+1
- if $DATA(Z(1))
- WRITE $JUSTIFY(Z,2)
- WRITE ?7,$PIECE(F,"^",2),?20,$JUSTIFY($PIECE(F,"^",8),2)," ",$PIECE(F,"^",9)
- SET Y=$PIECE(F,"^",7)
- DO DT^LRU
- WRITE ?28,Y
- SET Y=$PIECE(F,"^",12)
- IF Y
- IF Y<LRV
- WRITE "(",Y,"ml)"
- +8 SET Y=+$PIECE(F,"^",17)
- IF Y'=DUZ(2)
- WRITE ?45,$PIECE($GET(^DIC(4,Y,0)),U)
- +9 IF C(9)=1
- IF $DATA(R)
- SET O=0
- FOR O(1)=0:1
- SET O=$ORDER(^LRD(65,V,70,O))
- if 'O
- QUIT
- if 'O(1)
- WRITE !?48,"Antigen(s) ABSENT:"
- WRITE !?48,$PIECE(^LAB(61.3,O,0),"^")
- +10 WRITE !?3
- QUIT
- +11 ;
- D KILL F
- FOR B=0:0
- SET A=$ORDER(^LRD(65,"AI",C,A))
- if $EXTRACT(A,1,$LENGTH(X))'=X
- QUIT
- FOR Q=0:0
- SET Q=$ORDER(^LRD(65,"AI",C,A,Q))
- if 'Q!($ASCII(A)>122)
- QUIT
- DO I
- IF $DATA(F)
- SET ^TMP($JOB,Z)=F
- KILL F
- IF Z#5=0
- DO C
- if A(2)?1P
- QUIT
- +1 if Z#5&('$DATA(F))
- DO C
- QUIT
- +2 ;
- OK IF C(7)=1
- IF I(7)'=LRPABO
- KILL F
- QUIT
- +1 IF C(8)=1
- IF I(8)'=LRPRH
- KILL F
- QUIT
- +2 IF C(7)=1
- IF C(8)=1
- GOTO CK
- +3 IF C(7)
- DO @($SELECT(C(9)'=2:LRPABO,1:LRPABO_"P"))
- if '$DATA(F)
- QUIT
- +4 IF C(8)
- IF LRPRH="NEG"&(I(8)="POS")
- KILL F
- QUIT
- CK SET O=0
- IF $DATA(LRK)
- FOR O=0:0
- SET O=$ORDER(^LRD(65,V,2,O))
- if 'O
- QUIT
- IF $DATA(^LRD(65,"AP",O,V))
- QUIT
- +1 IF O>0
- KILL F
- QUIT
- +2 IF C(9)=1
- IF $DATA(R)
- SET O=0
- FOR O(1)=0:1
- SET O=$ORDER(^LRD(65,V,60,O))
- if 'O
- QUIT
- IF $DATA(R(O))
- KILL F
- QUIT
- +3 QUIT
- O if "AB"[I(7)
- KILL F
- QUIT
- A if I(7)["B"
- KILL F
- QUIT
- B if I(7)["A"
- KILL F
- QUIT
- AB QUIT
- OP QUIT
- AP if I(7)="B"!(I(7)="O")
- KILL F
- QUIT
- BP if I(7)="A"!(I(7)="O")
- KILL F
- QUIT
- ABP if I(7)'="AB"
- KILL F
- QUIT
- +1 ;
- MORE READ "'^' TO STOP: ",A(2):DTIME
- IF A(2)?1P
- SET A=$CHAR(126)
- QUIT
- +1 SET A(1)=A(1)+21
- if $Y<22
- SET A(1)=$Y+21
- WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13),?3
- QUIT
- C IF Z=1
- SET A(2)=1
- GOTO F
- +1 WRITE $CHAR(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z
- READ ": ",A(2):DTIME
- IF A(2)?1P!'$TEST
- SET A=$CHAR(126)
- QUIT
- +2 IF A(2)=""
- WRITE !?3
- QUIT
- F IF A(2)>0
- IF A(2)<(Z+1)
- SET F=^TMP($JOB,A(2))
- +1 SET A(2)="^"
- SET A=$CHAR(126)
- QUIT
