LRBLJM1 ;AVAMC/REG/CYM - EDIT POOLED UNIT 10/8/97 22:09 ;
;;5.2;LAB SERVICE**90,247**;;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;
; LRP=POOLED UNIT, LRC=INDIVIDUAL COMPONENT UNIT
; LR("ADJ") flags if component is added or deleted from pool
;
A S LR("ADJ")="A" W ! S DIC="^LRD(65,",DIC(0)="AEQMZ",DIC("A")="Select UNIT TO ADD: ",DIC("S")="I $S('$D(^(4)):1,$P(^(4),U)]"""":0,1:1)&($P(LRW,U)'=$P(^(0),U))&($P(^LAB(66,$P(^(0),U,4),0),U,26)=LRA)"
D ^DIC K DIC Q:Y<1 S DA=+Y
W !!,"Ok to add ",$P(Y(0),U)," to pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
S LRC=DA,G=^LRD(65,LRP,9,0),I=$P(G,U,3) D G ; gets next available modified to/from IEN for Pooled Unit
S LRF=$P(Y(0),"^",4),LRG=$P(Y(0),"^"),^LRD(65,LRP,9,0)=$P(G,"^",1,2)_"^"_I_"^"_($P(G,"^",4)+1),^(I,0)=LRF_"^"_LRG_"^"_1
D T S ^LRD(65,DA,4)="MO"_"^"_LRT_"^"_DUZ S:'$D(^LRD(65,DA,9,0)) ^(0)="^65.091PAI^"_I_"^" S G=^(0),X=DA,J=$P(G,"^",3) S:J']"" J=I S ^LRD(65,DA,9,0)=$P(G,"^",1,2)_"^"_J_"^"_($P(G,"^",4)+1),^(I,0)=$P(LRW,"^",4)_"^"_$P(LRW,"^")_"^"_2
N NODE S NODE=$G(^LRD(65,DA,4)) ;Adds "added unit" disposition fields to audit trail
S O="",X=$P(NODE,U),Z="65,4.1" D EN^LRUD
S O="",X=$P(NODE,U,2),Z="65,4.2" D EN^LRUD
S O="",X=$P(NODE,U,3),Z="65,4.3" D EN^LRUD
; Following line adds modified to/from fields (for COMPONENT unit) to audit trail for new component added to Pool
I J S DA(1)=DA,DA=J D
. S NODE=$G(^LRD(65,DA(1),9,DA,0))
. S O="",X=$P(NODE,U),Z="65.091,.01" D EN^LRUD
. S O="",X=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
. S O="",X=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
S DA=DA(1),DIK="^LRD(65,",DIK(1)="4.1^AC^APS" D EN1^DIK
S X=LRT,DIK="^LRD(65,",DIK(1)="4.2^AB" D EN1^DIK
; Following line adds modified to/from fields (for POOLED unit) to audit trail for the new component added to Pool
S DA=I,DA(1)=LRP,NODE=$G(^LRD(65,DA(1),9,DA,0))
S X=$P(NODE,U),O="",Z="65.091,.01" D EN^LRUD
S X=$P(NODE,U,2),O="",Z="65.091,.02" D EN^LRUD
S X=$P(NODE,U,3),O="",Z="65.091,.03" D EN^LRUD
S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
. N NEWPOOL S NEWPOOL="("_(E+1)_")" ; Updates the pooled divided units field
. I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
. S X=NEWPOOL,Z="65,4.4" D EN^LRUD
D VOL Q
;
G ; get next available IEN for POOLED unit modified to/from multiple
S I=I+1 I $D(^LRD(65,LRP,9,I,0)) G G
Q
;
R S LR("ADJ")="R" W ! S A=0 F E=0:1 S A=$O(^TMP($J,A)) Q:'A!(LR("Q")) S X=^(A) W !,$J(A,3),")",?7,$P(X,"^",3),?25,$P(X,"^",4) D:A#21=0 M^LRU Q:LR("Q")
W !!,"Select UNIT TO REMOVE (1-",E,"): " R X:DTIME Q:X[U!(X="") I +X'=X!(X<1)!(X>E) W $C(7),!,"Must enter a number from 1 to ",E G R
S X=^TMP($J,X),(DA,LRC)=$P(X,U,2),LRI=+X,LRC(3)=$P(X,U,3) W " ",LRC(3)
W !,"Ok to remove ",LRC(3)," from pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
B S DA(1)=LRP,DA=LRI D AUDIT ; Put deleted modified to/from entry from POOLED unit on audit trail
S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
. N NEWPOOL S NEWPOOL="("_(E-1)_")" ; Update the Pooled/Divided units field
. I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
. S X=NEWPOOL,Z="65,4.4" D EN^LRUD
D VOL
S DA=0,DA(1)=LRC F B=0:0 S B=$O(^LRD(65,LRC,9,B)) Q:'B S X=^(B,0) I +X=$P(LRW,"^",4),$P(X,"^",2)=$P(LRW,"^") S DA=B Q
D:DA AUDIT,K Q ; Put modified to/from entry from deleted COMPONENT unit on audit trail, then delete COMPONENT unit's disposition fields.
Q
K S DA=DA(1),LRC=$S($D(^LRD(65,DA,4)):^(4),1:"") Q:$P(LRC,"^")'="MO"
F LR(4.1)=1,2,3 X:$D(^DD(65,4.1,1,LR(4.1),2)) ^(2)
S X=$P(LRC,"^",2) X:$D(^DD(65.4,4.2,1,1,2)) ^(2)
K DA(1) S O="MO",X="",Z="65,4.1" D EN^LRUD S O=$P(LRC,"^",2),X="",Z="65,4.2" D EN^LRUD S O=$P(LRC,"^",3),X="Deleted",Z="65,4.3" D EN^LRUD
K ^LRD(65,DA,4) Q
E S X=^LRD(65,DA(1),9,0) K ^(DA,0) S X(1)=$O(^LRD(65,DA(1),9,0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) Q
;
D W !!,"Ok to delete the ",$P(LRW,"^")," pool " S LRL=0,%=2 D YN^LRU Q:%'=1 F A=0:0 S A=$O(^TMP($J,A)) Q:'A S DA=$P(^(A),"^",2) D L1 Q:LRL
Q:LRL F LRA=0:0 S LRA=$O(^TMP($J,LRA)) Q:'LRA S X=^(LRA),(DA,DA(1),LRC)=$P(X,"^",2),LRI=+X,LRC(3)=$P(X,"^",3) D K S LRC=DA D
. S DA(1)=LRP,DA=LRI
. S NODE=$G(^LRD(65,LRP,9,LRI,0))
. S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
. S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
. S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
. S LRCOMP=0 F S LRCOMP=$O(^LRD(65,LRC,9,LRCOMP)) Q:'LRCOMP S DA(1)=LRC,DA=LRCOMP D
.. S NODE=$G(^LRD(65,LRC,9,LRCOMP,0))
.. S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
.. S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
.. S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
.. S DIK="^LRD(65,"_DA(1)_",9," D ^DIK
; Above block of code places Modified to/from info from POOLED and COMPONENT units onto the audit trail
S DA=LRP D DISP^LRBLAUD1 ; Collect ALL disposition data on a POOLED unit (includes Transfusion Record if present) to be placed on audit trail if necessary
K DA(1) S DA=LRP,Z="65,.01",O=$P(LRW,"^"),X="Deleted" D EN^LRUD K ^LRD(65,DA,4) D DISP1^LRBLAUD1 ; Place disposition data on audit trail if necessary
S DA(1)=LRP I LRDSP]"" S O=LRDSP,X="Deleted",Z="65,4.1" D EN^LRUD
I LRPTR]"",LRREC]"" S DA=LRREC,DIK="^LR(LRPTR,1.6," D ^DIK
S DA=LRP,DIK="^LRD(65," D ^DIK Q
;
T S %DT="T",X="N" D ^%DT S LRT=Y Q
;
L1 I $D(LRLOCK)#2 L -^LRD(65,LRLOCK)
S LRLOCK=DA L +^LRD(65,DA):1
I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING ",$P(^LRD(65,DA),U) S LRL=1
Q
AUDIT ; Puts deleted modified to/from entries onto audit trail
N NODE S NODE=$G(^LRD(65,DA(1),9,DA,0))
S O=$P(NODE,U),X="Deleted",Z="65.091,.01" D EN^LRUD
S O=$P(NODE,U,2),X="Deleted",Z="65.091,.02" D EN^LRUD
S O=$P(NODE,U,3),X="Deleted",Z="65.091,.03" D EN^LRUD
D E
Q
VOL ; Recalculate and updates POOLED unit volume, records change on audit trail
N POOLVOL,UNITVOL,UNIT,NEWVOL
S POOLVOL=$P(^LRD(65,LRP,0),U,11),O=POOLVOL
S UNIT=$P(^LRD(65,LRC,0),U,4)
S UNITVOL=$P(^LAB(66,UNIT,0),U,10)
I LR("ADJ")="R" S NEWVOL=(POOLVOL-UNITVOL)
I LR("ADJ")="A" S NEWVOL=(POOLVOL+UNITVOL)
S $P(^LRD(65,LRP,0),U,11)=NEWVOL
S X=NEWVOL,Z="65,.11" D EN^LRUD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJM1 6201 printed Apr 09, 2024@21:12:49 Page 2
LRBLJM1 ;AVAMC/REG/CYM - EDIT POOLED UNIT 10/8/97 22:09 ;
+1 ;;5.2;LAB SERVICE**90,247**;;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;
+4 ; LRP=POOLED UNIT, LRC=INDIVIDUAL COMPONENT UNIT
+5 ; LR("ADJ") flags if component is added or deleted from pool
+6 ;
A SET LR("ADJ")="A"
WRITE !
SET DIC="^LRD(65,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select UNIT TO ADD: "
SET DIC("S")="I $S('$D(^(4)):1,$P(^(4),U)]"""":0,1:1)&($P(LRW,U)'=$P(^(0),U))&($P(^LAB(66,$P(^(0),U,4),0),U,26)=LRA)"
+1 DO ^DIC
KILL DIC
if Y<1
QUIT
SET DA=+Y
+2 WRITE !!,"Ok to add ",$PIECE(Y(0),U)," to pool "
SET LRL=0
SET %=2
DO YN^LRU
if %'=1
QUIT
DO L1
IF LRL
QUIT
+3 ; gets next available modified to/from IEN for Pooled Unit
SET LRC=DA
SET G=^LRD(65,LRP,9,0)
SET I=$PIECE(G,U,3)
DO G
+4 SET LRF=$PIECE(Y(0),"^",4)
SET LRG=$PIECE(Y(0),"^")
SET ^LRD(65,LRP,9,0)=$PIECE(G,"^",1,2)_"^"_I_"^"_($PIECE(G,"^",4)+1)
SET ^(I,0)=LRF_"^"_LRG_"^"_1
+5 DO T
SET ^LRD(65,DA,4)="MO"_"^"_LRT_"^"_DUZ
if '$DATA(^LRD(65,DA,9,0))
SET ^(0)="^65.091PAI^"_I_"^"
SET G=^(0)
SET X=DA
SET J=$PIECE(G,"^",3)
if J']""
SET J=I
SET ^LRD(65,DA,9,0)=$PIECE(G,"^",1,2)_"^"_J_"^"_($PIECE(G,"^",4)+1)
SET ^(I,0)=$PIECE(LRW,"^",4)_"^"_$PIECE(LRW,"^")_"^"_2
+6 ;Adds "added unit" disposition fields to audit trail
NEW NODE
SET NODE=$GET(^LRD(65,DA,4))
+7 SET O=""
SET X=$PIECE(NODE,U)
SET Z="65,4.1"
DO EN^LRUD
+8 SET O=""
SET X=$PIECE(NODE,U,2)
SET Z="65,4.2"
DO EN^LRUD
+9 SET O=""
SET X=$PIECE(NODE,U,3)
SET Z="65,4.3"
DO EN^LRUD
+10 ; Following line adds modified to/from fields (for COMPONENT unit) to audit trail for new component added to Pool
+11 IF J
SET DA(1)=DA
SET DA=J
Begin DoDot:1
+12 SET NODE=$GET(^LRD(65,DA(1),9,DA,0))
+13 SET O=""
SET X=$PIECE(NODE,U)
SET Z="65.091,.01"
DO EN^LRUD
+14 SET O=""
SET X=$PIECE(NODE,U,2)
SET Z="65.091,.02"
DO EN^LRUD
+15 SET O=""
SET X=$PIECE(NODE,U,3)
SET Z="65.091,.03"
DO EN^LRUD
End DoDot:1
+16 SET DA=DA(1)
SET DIK="^LRD(65,"
SET DIK(1)="4.1^AC^APS"
DO EN1^DIK
+17 SET X=LRT
SET DIK="^LRD(65,"
SET DIK(1)="4.2^AB"
DO EN1^DIK
+18 ; Following line adds modified to/from fields (for POOLED unit) to audit trail for the new component added to Pool
+19 SET DA=I
SET DA(1)=LRP
SET NODE=$GET(^LRD(65,DA(1),9,DA,0))
+20 SET X=$PIECE(NODE,U)
SET O=""
SET Z="65.091,.01"
DO EN^LRUD
+21 SET X=$PIECE(NODE,U,2)
SET O=""
SET Z="65.091,.02"
DO EN^LRUD
+22 SET X=$PIECE(NODE,U,3)
SET O=""
SET Z="65.091,.03"
DO EN^LRUD
+23 SET DA=LRP
SET O=$PIECE($GET(^LRD(65,DA,4)),U,4)
IF O]""
Begin DoDot:1
+24 ; Updates the pooled divided units field
NEW NEWPOOL
SET NEWPOOL="("_(E+1)_")"
+25 IF $DATA(^LRD(65,DA,4))
SET $PIECE(^LRD(65,DA,4),U,4)=NEWPOOL
+26 SET X=NEWPOOL
SET Z="65,4.4"
DO EN^LRUD
End DoDot:1
+27 DO VOL
QUIT
+28 ;
G ; get next available IEN for POOLED unit modified to/from multiple
+1 SET I=I+1
IF $DATA(^LRD(65,LRP,9,I,0))
GOTO G
+2 QUIT
+3 ;
R SET LR("ADJ")="R"
WRITE !
SET A=0
FOR E=0:1
SET A=$ORDER(^TMP($JOB,A))
if 'A!(LR("Q"))
QUIT
SET X=^(A)
WRITE !,$JUSTIFY(A,3),")",?7,$PIECE(X,"^",3),?25,$PIECE(X,"^",4)
if A#21=0
DO M^LRU
if LR("Q")
QUIT
+1 WRITE !!,"Select UNIT TO REMOVE (1-",E,"): "
READ X:DTIME
if X[U!(X="")
QUIT
IF +X'=X!(X<1)!(X>E)
WRITE $CHAR(7),!,"Must enter a number from 1 to ",E
GOTO R
+2 SET X=^TMP($JOB,X)
SET (DA,LRC)=$PIECE(X,U,2)
SET LRI=+X
SET LRC(3)=$PIECE(X,U,3)
WRITE " ",LRC(3)
+3 WRITE !,"Ok to remove ",LRC(3)," from pool "
SET LRL=0
SET %=2
DO YN^LRU
if %'=1
QUIT
DO L1
IF LRL
QUIT
B ; Put deleted modified to/from entry from POOLED unit on audit trail
SET DA(1)=LRP
SET DA=LRI
DO AUDIT
+1 SET DA=LRP
SET O=$PIECE($GET(^LRD(65,DA,4)),U,4)
IF O]""
Begin DoDot:1
+2 ; Update the Pooled/Divided units field
NEW NEWPOOL
SET NEWPOOL="("_(E-1)_")"
+3 IF $DATA(^LRD(65,DA,4))
SET $PIECE(^LRD(65,DA,4),U,4)=NEWPOOL
+4 SET X=NEWPOOL
SET Z="65,4.4"
DO EN^LRUD
End DoDot:1
+5 DO VOL
+6 SET DA=0
SET DA(1)=LRC
FOR B=0:0
SET B=$ORDER(^LRD(65,LRC,9,B))
if 'B
QUIT
SET X=^(B,0)
IF +X=$PIECE(LRW,"^",4)
IF $PIECE(X,"^",2)=$PIECE(LRW,"^")
SET DA=B
QUIT
+7 ; Put modified to/from entry from deleted COMPONENT unit on audit trail, then delete COMPONENT unit's disposition fields.
if DA
DO AUDIT
DO K
QUIT
+8 QUIT
K SET DA=DA(1)
SET LRC=$SELECT($DATA(^LRD(65,DA,4)):^(4),1:"")
if $PIECE(LRC,"^")'="MO"
QUIT
+1 FOR LR(4.1)=1,2,3
if $DATA(^DD(65,4.1,1,LR(4.1),2))
XECUTE ^(2)
+2 SET X=$PIECE(LRC,"^",2)
if $DATA(^DD(65.4,4.2,1,1,2))
XECUTE ^(2)
+3 KILL DA(1)
SET O="MO"
SET X=""
SET Z="65,4.1"
DO EN^LRUD
SET O=$PIECE(LRC,"^",2)
SET X=""
SET Z="65,4.2"
DO EN^LRUD
SET O=$PIECE(LRC,"^",3)
SET X="Deleted"
SET Z="65,4.3"
DO EN^LRUD
+4 KILL ^LRD(65,DA,4)
QUIT
E SET X=^LRD(65,DA(1),9,0)
KILL ^(DA,0)
SET X(1)=$ORDER(^LRD(65,DA(1),9,0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
QUIT
+1 ;
D WRITE !!,"Ok to delete the ",$PIECE(LRW,"^")," pool "
SET LRL=0
SET %=2
DO YN^LRU
if %'=1
QUIT
FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A
QUIT
SET DA=$PIECE(^(A),"^",2)
DO L1
if LRL
QUIT
+1 if LRL
QUIT
FOR LRA=0:0
SET LRA=$ORDER(^TMP($JOB,LRA))
if 'LRA
QUIT
SET X=^(LRA)
SET (DA,DA(1),LRC)=$PIECE(X,"^",2)
SET LRI=+X
SET LRC(3)=$PIECE(X,"^",3)
DO K
SET LRC=DA
Begin DoDot:1
+2 SET DA(1)=LRP
SET DA=LRI
+3 SET NODE=$GET(^LRD(65,LRP,9,LRI,0))
+4 SET X="Deleted"
SET O=$PIECE(NODE,U)
SET Z="65.091,.01"
DO EN^LRUD
+5 SET X="Deleted"
SET O=$PIECE(NODE,U,2)
SET Z="65.091,.02"
DO EN^LRUD
+6 SET X="Deleted"
SET O=$PIECE(NODE,U,3)
SET Z="65.091,.03"
DO EN^LRUD
+7 SET LRCOMP=0
FOR
SET LRCOMP=$ORDER(^LRD(65,LRC,9,LRCOMP))
if 'LRCOMP
QUIT
SET DA(1)=LRC
SET DA=LRCOMP
Begin DoDot:2
+8 SET NODE=$GET(^LRD(65,LRC,9,LRCOMP,0))
+9 SET X="Deleted"
SET O=$PIECE(NODE,U)
SET Z="65.091,.01"
DO EN^LRUD
+10 SET X="Deleted"
SET O=$PIECE(NODE,U,2)
SET Z="65.091,.02"
DO EN^LRUD
+11 SET X="Deleted"
SET O=$PIECE(NODE,U,3)
SET Z="65.091,.03"
DO EN^LRUD
+12 SET DIK="^LRD(65,"_DA(1)_",9,"
DO ^DIK
End DoDot:2
End DoDot:1
+13 ; Above block of code places Modified to/from info from POOLED and COMPONENT units onto the audit trail
+14 ; Collect ALL disposition data on a POOLED unit (includes Transfusion Record if present) to be placed on audit trail if necessary
SET DA=LRP
DO DISP^LRBLAUD1
+15 ; Place disposition data on audit trail if necessary
KILL DA(1)
SET DA=LRP
SET Z="65,.01"
SET O=$PIECE(LRW,"^")
SET X="Deleted"
DO EN^LRUD
KILL ^LRD(65,DA,4)
DO DISP1^LRBLAUD1
+16 SET DA(1)=LRP
IF LRDSP]""
SET O=LRDSP
SET X="Deleted"
SET Z="65,4.1"
DO EN^LRUD
+17 IF LRPTR]""
IF LRREC]""
SET DA=LRREC
SET DIK="^LR(LRPTR,1.6,"
DO ^DIK
+18 SET DA=LRP
SET DIK="^LRD(65,"
DO ^DIK
QUIT
+19 ;
T SET %DT="T"
SET X="N"
DO ^%DT
SET LRT=Y
QUIT
+1 ;
L1 IF $DATA(LRLOCK)#2
LOCK -^LRD(65,LRLOCK)
+1 SET LRLOCK=DA
LOCK +^LRD(65,DA):1
+2 IF '$TEST
WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING ",$PIECE(^LRD(65,DA),U)
SET LRL=1
+3 QUIT
AUDIT ; Puts deleted modified to/from entries onto audit trail
+1 NEW NODE
SET NODE=$GET(^LRD(65,DA(1),9,DA,0))
+2 SET O=$PIECE(NODE,U)
SET X="Deleted"
SET Z="65.091,.01"
DO EN^LRUD
+3 SET O=$PIECE(NODE,U,2)
SET X="Deleted"
SET Z="65.091,.02"
DO EN^LRUD
+4 SET O=$PIECE(NODE,U,3)
SET X="Deleted"
SET Z="65.091,.03"
DO EN^LRUD
+5 DO E
+6 QUIT
VOL ; Recalculate and updates POOLED unit volume, records change on audit trail
+1 NEW POOLVOL,UNITVOL,UNIT,NEWVOL
+2 SET POOLVOL=$PIECE(^LRD(65,LRP,0),U,11)
SET O=POOLVOL
+3 SET UNIT=$PIECE(^LRD(65,LRC,0),U,4)
+4 SET UNITVOL=$PIECE(^LAB(66,UNIT,0),U,10)
+5 IF LR("ADJ")="R"
SET NEWVOL=(POOLVOL-UNITVOL)
+6 IF LR("ADJ")="A"
SET NEWVOL=(POOLVOL+UNITVOL)
+7 SET $PIECE(^LRD(65,LRP,0),U,11)=NEWVOL
+8 SET X=NEWVOL
SET Z="65,.11"
DO EN^LRUD
+9 QUIT
