- LRBLJL ; IHS/DIR/AAB - UNIT RELOCATION 7/7/97 08:32 ; [ 05/28/98 2:04 PM ]
- ;;5.2;LR;**1002,1003**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**16,72,79,90**;Sep 27, 1994
- D END,S^LRBLW,CK^LRBLPUS G:Y=-1 END D A^LRBLJL1 G:Y=-1 END S LRB=$O(^LAB(61.3,"C",50710,0)) I 'LRB D EN1^LRBLU
- W !!?30,"Relocation of units",!!?30,LRAA(4) I LRCAPA S X="UNIT RELOCATION" D X^LRUWK G:'$D(X) END
- P W ! K LRG,DIC,DIE,DR,DA,C,LRW,V,R,LRV,^TMP($J) D ^LRDPA G:LRDFN=-1 END S LRBL=$S(LRPFN=2:DFN,1:"") D R G P
- R D EN^LRBLPUS F X=1:1:4 S LRW(X)=""
- D ^LRBLJL1 I F=0 W $C(7),!!,"No units available for release",!,"Use appropriate options to assign or modify" Q
- I $D(LRG(1)) W $C(7),!!?3,"( # unsatisfactory unit)" K LRG(1)
- I $D(V) W $C(7),!!?3,"( *Expired unit )" K V
- I F=1 S LRV=1 D DIE Q
- M W !,"Select (1-",F,"): " R X:DTIME Q:X=""!(X[U) I X["?" W !,"Enter number(s) from 1 to ",F,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units" G M
- I X="ALL" S LR("ALL")=1 D ALL Q
- I X?.E1CA.E!($L(X)>200) W $C(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed" G M
- I '+X W $C(7),!,"START with a NUMBER !!",! G M
- S LRQ=X F LRA=0:0 S LRZ=0,LRV=+LRQ,LRQ=$E(LRQ,$L(LRV)+2,$L(LRQ)) D:LRV A Q:'$L(LRQ)
- Q
- A Q:'$D(^TMP($J,LRV)) S A=LRV,LRX=^(A) W !,A,")" D W^LRBLJL1,DIE
- Q
- F S DA=9999999-LRW(1) S:'$D(^LRD(65,LRX,3,0)) ^(0)="^65.03DA^^" I '$D(^(DA,0)) S ^LRD(65,LRX,3,DA,0)=LRW(1),X=^LRD(65,LRX,3,0),^(0)="^65.03DA^"_DA_"^"_($P(X,"^",4)+1)
- Q
- ALL ; This subroutine detects if a previous Inspection was
- ; Unsatisfactory, then calls up another subroutine to give
- ; a warning message. It also evaluates each individual unit
- ; within a group selected to be sure that all required testing
- ; is complete and compatible with the patient.
- S (LRZ,LR("STOP"))=0
- F LRC=0:0 S LRC=$O(^TMP($J,LRC)) Q:LRC'>0 Q:LR("STOP")=2 D
- . S LRE=^TMP($J,LRC),LRX=+LRE,(LRZ(LRX),LRR(LRX))=0,L=$P(LRE,U,14) D:"Blood BankBLOOD BANK"[L C
- . I $P(LRE,U,11)="U" W $C(7),!,"Unit unsatisfactory, cannot release." S LRZ(LRX)=1 Q
- . Q:LRZ(LRX)
- . I 'LR("STOP") D T Q
- . I LR("STOP") D
- .. I $D(LRG(LRX)) D PRE Q
- .. S LRK=LRW(1) D F,G S ^LRD(65,LRX,3,DA,0)=LRW(1)_"^"_LRW(2)_"^"_DUZ_"^"_LRW(3)_"^"_LRW(4)_"^"_LRP_"^"_LRBL,^LRD(65,"AL",LRW(1),LRX)=""
- Q
- DIE S LRE=^TMP($J,LRV),LRX=+LRE,(LRZ(LRX),LRR(LRX))=0 K ^TMP($J,LRV),Y,LR("CK") I "Blood BankBLOOD BANK"[L D C Q:LRZ(LRX)
- I $P(LRE,"^",11)="U" W $C(7),!,"Unit unsatisfactory, cannot release." S LRR(LRX)=1 Q
- T R !!,"DATE/TIME UNIT RELOCATION: NOW//",X:DTIME I '$T!(X[U) S LRR(LRX)=1 Q
- S:X="" X="N" S %DT="ETX",%DT(0)="-N" D ^%DT K %DT S LRW(1)=Y I Y<1!(Y'[".") W $C(7),!?5,"TIME and DATE must be entered, future time not allowed." G T
- I Y<$P(LRE,U,12) W $C(7),!!,"Relocation time must be after DATE/TIME unit assigned " S Y=$P(LRE,U,12) D DT^LRU W "(",Y,")" S LRR(LRX)=1 Q
- D F S DIE="^LRD(65,LRX,3," D CK^LRU Q:$D(LR("CK")) S DA(1)=LRX,X=$P(LRE,"^",6),LRW(5)=$S("Blood BankBLOOD BANK"[X:1,1:0) S:'LRW(5) LRW(3)=LR(44)
- S DR=".03////^S X=DUZ;.02;S LRW(2)=X;D:X=""U"" I^LRBLJL;S:LRW(2)=""U""&(LRW(5)) Y=0;I 'LRW(5)&(LRW(2)=""U"") D S^LRBLJL;.04;S LRW(3)=X;.05;S LRW(4)=X;.06///^S X=LRP;.07////^S X=LRBL" D ^DIE D FRE^LRU
- I $D(LR("ALL")) S LR("STOP")=1 ; Only enter relocation data once if "ALL"
- I $D(Y)!(LRW(2)="U"&(LRW(5))) D W,CLNP K Y S LR("STOP")=2 Q ; If incomplete answers given during relocation, gives warning message and deletes current relocation.
- I $D(LRG(LRX)) D PRE,CLNP Q ; If a previous Unsatisfactory Inspection, gives warning message and deletes current relocation.
- S ^LRD(65,"AL",LRW(1),LRX)="",LRK=LRW(1) D G
- Q
- PRE ; Warning message if a unit has had a previous Unsatisfactory Inspection
- N UNIT S UNIT=$P(^LRD(65,LRX,0),U)
- W $C(7),!!,UNIT," has had a previous Unsatisfactory inspection and cannot be relocated.",!!,"Relocation entry <DELETED>",! Q
- CLNP ; When indicated, current relocation episode is deleted.
- S DA(1)=LRX,DIK="^LRD(65,"_DA(1)_",3," D ^DIK S LRZ(LRX)=1 Q
- C I $D(R),$P(LRE,"^",8)=1,$P(LRE,"^",10)'=1 W ! F Z=0:0 S Z=$O(R(Z)) Q:'Z I Z'=LRB,'$D(^LRD(65,LRX,70,Z,0)) W !,$P(^LAB(61.3,Z,0),"^"),$E("..............",$X,14),?15,"RBC ANTIGEN" S LRZ(LRX)=1
- I LRZ(LRX) W $C(7),!,"Above antigen(s) not entered in RBC ANTIGEN ABSENT field"
- D:$P(LRE,"^",9)=1 D W:LRZ(LRX) !?3,"for ",$P(LRE,"^",2),?28,"*** UNIT NOT RELOCATED ***",! Q
- D S X=$S($D(^LRD(65,+LRE,10)):$P(^(10),"^"),1:"") S:X="ND" X="" I X="" S LRZ(LRX)=1 W $C(7),!,"ABO not rechecked"
- I X]"",X'=$P($P(LRE,"^",4)," ") S LRZ(LRX)=1 W $C(7),!,"ABO recheck different from ABO GROUP"
- S X=$S($D(^LRD(65,+LRE,11)):$P(^(11),"^"),1:"") S:X="ND" X="" I $P($P(LRE,U,4)," ",2)="NEG",X="" S LRZ(LRX)=1 W $C(7),!,"Rh NEG unit not rechecked"
- I X]"",X'=$P($P(LRE,U,4)," ",2) W $C(7),!!?6,"Rh recheck (",X,") different from Rh TYPE (",$P($P(LRE,U,4)," ",2),")" W !?6,"Are you sure you want to relocate unit " S %=2 D YN^LRU S:%'=1 LRZ(LRX)=1
- Q
- G W !,$P(LRE,"^",2)," relocated" D:LRCAPA ^LRBLW K Y Q
- I W $C(7)," Are you sure " S %=2 D YN^LRU S:%'=1 Y=.02 Q
- S W !?15,$C(7),"***Unsatisfactory unit(s) returned to BLOOD BANK***",! S $P(^LRD(65,LRX,3,DA,0),"^",4)="BLOOD BANK",Y=.05 Q
- W W $C(7),!!,"No units with incomplete answers or units to be sent from the blood bank",!,"with unsatisfactory inspections can be relocated. Relocation entry <DELETED>",! Q
- END D V^LRU Q
- LRBLJL ; IHS/DIR/AAB - UNIT RELOCATION 7/7/97 08:32 ; [ 05/28/98 2:04 PM ]
- +1 ;;5.2;LR;**1002,1003**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**16,72,79,90**;Sep 27, 1994
- +3 DO END
- DO S^LRBLW
- DO CK^LRBLPUS
- IF Y=-1
- GOTO END
- DO A^LRBLJL1
- IF Y=-1
- GOTO END
- SET LRB=$ORDER(^LAB(61.3,"C",50710,0))
- IF 'LRB
- DO EN1^LRBLU
- +4 WRITE !!?30,"Relocation of units",!!?30,LRAA(4)
- IF LRCAPA
- SET X="UNIT RELOCATION"
- DO X^LRUWK
- IF '$DATA(X)
- GOTO END
- P WRITE !
- KILL LRG,DIC,DIE,DR,DA,C,LRW,V,R,LRV,^TMP($JOB)
- DO ^LRDPA
- IF LRDFN=-1
- GOTO END
- SET LRBL=$SELECT(LRPFN=2:DFN,1:"")
- DO R
- GOTO P
- R DO EN^LRBLPUS
- FOR X=1:1:4
- SET LRW(X)=""
- +1 DO ^LRBLJL1
- IF F=0
- WRITE $CHAR(7),!!,"No units available for release",!,"Use appropriate options to assign or modify"
- QUIT
- +2 IF $DATA(LRG(1))
- WRITE $CHAR(7),!!?3,"( # unsatisfactory unit)"
- KILL LRG(1)
- +3 IF $DATA(V)
- WRITE $CHAR(7),!!?3,"( *Expired unit )"
- KILL V
- +4 IF F=1
- SET LRV=1
- DO DIE
- QUIT
- M WRITE !,"Select (1-",F,"): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X["?"
- WRITE !,"Enter number(s) from 1 to ",F,!,"For 2 or more selections separate each with a ',' (ex. 1,3,4)",!,"Enter 'ALL' for all units"
- GOTO M
- +1 IF X="ALL"
- SET LR("ALL")=1
- DO ALL
- QUIT
- +2 IF X?.E1CA.E!($LENGTH(X)>200)
- WRITE $CHAR(7),!,"No CONTROL CHARACTERS, LETTERS or more than 200 characters allowed"
- GOTO M
- +3 IF '+X
- WRITE $CHAR(7),!,"START with a NUMBER !!",!
- GOTO M
- +4 SET LRQ=X
- FOR LRA=0:0
- SET LRZ=0
- SET LRV=+LRQ
- SET LRQ=$EXTRACT(LRQ,$LENGTH(LRV)+2,$LENGTH(LRQ))
- IF LRV
- DO A
- IF '$LENGTH(LRQ)
- QUIT
- +5 QUIT
- A IF '$DATA(^TMP($JOB,LRV))
- QUIT
- SET A=LRV
- SET LRX=^(A)
- WRITE !,A,")"
- DO W^LRBLJL1
- DO DIE
- +1 QUIT
- F SET DA=9999999-LRW(1)
- IF '$DATA(^LRD(65,LRX,3,0))
- SET ^(0)="^65.03DA^^"
- IF '$DATA(^(DA,0))
- SET ^LRD(65,LRX,3,DA,0)=LRW(1)
- SET X=^LRD(65,LRX,3,0)
- SET ^(0)="^65.03DA^"_DA_"^"_($PIECE(X,"^",4)+1)
- +1 QUIT
- ALL ; This subroutine detects if a previous Inspection was
- +1 ; Unsatisfactory, then calls up another subroutine to give
- +2 ; a warning message. It also evaluates each individual unit
- +3 ; within a group selected to be sure that all required testing
- +4 ; is complete and compatible with the patient.
- +5 SET (LRZ,LR("STOP"))=0
- +6 FOR LRC=0:0
- SET LRC=$ORDER(^TMP($JOB,LRC))
- IF LRC'>0
- QUIT
- IF LR("STOP")=2
- QUIT
- Begin DoDot:1
- +7 SET LRE=^TMP($JOB,LRC)
- SET LRX=+LRE
- SET (LRZ(LRX),LRR(LRX))=0
- SET L=$PIECE(LRE,U,14)
- IF "Blood BankBLOOD BANK"[L
- DO C
- +8 IF $PIECE(LRE,U,11)="U"
- WRITE $CHAR(7),!,"Unit unsatisfactory, cannot release."
- SET LRZ(LRX)=1
- QUIT
- +9 IF LRZ(LRX)
- QUIT
- +10 IF 'LR("STOP")
- DO T
- QUIT
- +11 IF LR("STOP")
- Begin DoDot:2
- +12 IF $DATA(LRG(LRX))
- DO PRE
- QUIT
- +13 SET LRK=LRW(1)
- DO F
- DO G
- SET ^LRD(65,LRX,3,DA,0)=LRW(1)_"^"_LRW(2)_"^"_DUZ_"^"_LRW(3)_"^"_LRW(4)_"^"_LRP_"^"_LRBL
- SET ^LRD(65,"AL",LRW(1),LRX)=""
- End DoDot:2
- End DoDot:1
- +14 QUIT
- DIE SET LRE=^TMP($JOB,LRV)
- SET LRX=+LRE
- SET (LRZ(LRX),LRR(LRX))=0
- KILL ^TMP($JOB,LRV),Y,LR("CK")
- IF "Blood BankBLOOD BANK"[L
- DO C
- IF LRZ(LRX)
- QUIT
- +1 IF $PIECE(LRE,"^",11)="U"
- WRITE $CHAR(7),!,"Unit unsatisfactory, cannot release."
- SET LRR(LRX)=1
- QUIT
- T READ !!,"DATE/TIME UNIT RELOCATION: NOW//",X:DTIME
- IF '$TEST!(X[U)
- SET LRR(LRX)=1
- QUIT
- +1 IF X=""
- SET X="N"
- SET %DT="ETX"
- SET %DT(0)="-N"
- DO ^%DT
- KILL %DT
- SET LRW(1)=Y
- IF Y<1!(Y'[".")
- WRITE $CHAR(7),!?5,"TIME and DATE must be entered, future time not allowed."
- GOTO T
- +2 IF Y<$PIECE(LRE,U,12)
- WRITE $CHAR(7),!!,"Relocation time must be after DATE/TIME unit assigned "
- SET Y=$PIECE(LRE,U,12)
- DO DT^LRU
- WRITE "(",Y,")"
- SET LRR(LRX)=1
- QUIT
- +3 DO F
- SET DIE="^LRD(65,LRX,3,"
- DO CK^LRU
- IF $DATA(LR("CK"))
- QUIT
- SET DA(1)=LRX
- SET X=$PIECE(LRE,"^",6)
- SET LRW(5)=$SELECT("Blood BankBLOOD BANK"[X:1,1:0)
- IF 'LRW(5)
- SET LRW(3)=LR(44)
- +4 SET DR=".03////^S X=DUZ;.02;S LRW(2)=X;D:X=""U"" I^LRBLJL;S:LRW(2)=""U""&(LRW(5)) Y=0;I 'LRW(5)&(LRW(2)=""U"") D S^LRBLJL;.04;S LRW(3)=X;.05;S LRW(4)=X;.06///^S X=LRP;.07////^S X=LRBL"
- DO ^DIE
- DO FRE^LRU
- +5 ; Only enter relocation data once if "ALL"
- IF $DATA(LR("ALL"))
- SET LR("STOP")=1
- +6 ; If incomplete answers given during relocation, gives warning message and deletes current relocation.
- IF $DATA(Y)!(LRW(2)="U"&(LRW(5)))
- DO W
- DO CLNP
- KILL Y
- SET LR("STOP")=2
- QUIT
- +7 ; If a previous Unsatisfactory Inspection, gives warning message and deletes current relocation.
- IF $DATA(LRG(LRX))
- DO PRE
- DO CLNP
- QUIT
- +8 SET ^LRD(65,"AL",LRW(1),LRX)=""
- SET LRK=LRW(1)
- DO G
- +9 QUIT
- PRE ; Warning message if a unit has had a previous Unsatisfactory Inspection
- +1 NEW UNIT
- SET UNIT=$PIECE(^LRD(65,LRX,0),U)
- +2 WRITE $CHAR(7),!!,UNIT," has had a previous Unsatisfactory inspection and cannot be relocated.",!!,"Relocation entry <DELETED>",!
- QUIT
- CLNP ; When indicated, current relocation episode is deleted.
- +1 SET DA(1)=LRX
- SET DIK="^LRD(65,"_DA(1)_",3,"
- DO ^DIK
- SET LRZ(LRX)=1
- QUIT
- C IF $DATA(R)
- IF $PIECE(LRE,"^",8)=1
- IF $PIECE(LRE,"^",10)'=1
- WRITE !
- FOR Z=0:0
- SET Z=$ORDER(R(Z))
- IF 'Z
- QUIT
- IF Z'=LRB
- IF '$DATA(^LRD(65,LRX,70,Z,0))
- WRITE !,$PIECE(^LAB(61.3,Z,0),"^"),$EXTRACT("..............",$X,14),?15,"RBC ANTIGEN"
- SET LRZ(LRX)=1
- +1 IF LRZ(LRX)
- WRITE $CHAR(7),!,"Above antigen(s) not entered in RBC ANTIGEN ABSENT field"
- +2 IF $PIECE(LRE,"^",9)=1
- DO D
- IF LRZ(LRX)
- WRITE !?3,"for ",$PIECE(LRE,"^",2),?28,"*** UNIT NOT RELOCATED ***",!
- QUIT
- D SET X=$SELECT($DATA(^LRD(65,+LRE,10)):$PIECE(^(10),"^"),1:"")
- IF X="ND"
- SET X=""
- IF X=""
- SET LRZ(LRX)=1
- WRITE $CHAR(7),!,"ABO not rechecked"
- +1 IF X]""
- IF X'=$PIECE($PIECE(LRE,"^",4)," ")
- SET LRZ(LRX)=1
- WRITE $CHAR(7),!,"ABO recheck different from ABO GROUP"
- +2 SET X=$SELECT($DATA(^LRD(65,+LRE,11)):$PIECE(^(11),"^"),1:"")
- IF X="ND"
- SET X=""
- IF $PIECE($PIECE(LRE,U,4)," ",2)="NEG"
- IF X=""
- SET LRZ(LRX)=1
- WRITE $CHAR(7),!,"Rh NEG unit not rechecked"
- +3 IF X]""
- IF X'=$PIECE($PIECE(LRE,U,4)," ",2)
- WRITE $CHAR(7),!!?6,"Rh recheck (",X,") different from Rh TYPE (",$PIECE($PIECE(LRE,U,4)," ",2),")"
- WRITE !?6,"Are you sure you want to relocate unit "
- SET %=2
- DO YN^LRU
- IF %'=1
- SET LRZ(LRX)=1
- +4 QUIT
- G WRITE !,$PIECE(LRE,"^",2)," relocated"
- IF LRCAPA
- DO ^LRBLW
- KILL Y
- QUIT
- I WRITE $CHAR(7)," Are you sure "
- SET %=2
- DO YN^LRU
- IF %'=1
- SET Y=.02
- QUIT
- S WRITE !?15,$CHAR(7),"***Unsatisfactory unit(s) returned to BLOOD BANK***",!
- SET $PIECE(^LRD(65,LRX,3,DA,0),"^",4)="BLOOD BANK"
- SET Y=.05
- QUIT
- W WRITE $CHAR(7),!!,"No units with incomplete answers or units to be sent from the blood bank",!,"with unsatisfactory inspections can be relocated. Relocation entry <DELETED>",!
- QUIT
- END DO V^LRU
- QUIT
