104 lines
6.0 KiB
Mathematica
104 lines
6.0 KiB
Mathematica
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
|