source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLJM1.m@ 1306

Last change on this file since 1306 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1LRBLJM1 ;AVAMC/REG/CYM - EDIT POOLED UNIT 10/8/97 22:09 ;
2 ;;5.2;LAB SERVICE**90,247**;;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 ;
5 ; LRP=POOLED UNIT, LRC=INDIVIDUAL COMPONENT UNIT
6 ; LR("ADJ") flags if component is added or deleted from pool
7 ;
8A 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)"
9 D ^DIC K DIC Q:Y<1 S DA=+Y
10 W !!,"Ok to add ",$P(Y(0),U)," to pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
11 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
12 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
13 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
14 N NODE S NODE=$G(^LRD(65,DA,4)) ;Adds "added unit" disposition fields to audit trail
15 S O="",X=$P(NODE,U),Z="65,4.1" D EN^LRUD
16 S O="",X=$P(NODE,U,2),Z="65,4.2" D EN^LRUD
17 S O="",X=$P(NODE,U,3),Z="65,4.3" D EN^LRUD
18 ; Following line adds modified to/from fields (for COMPONENT unit) to audit trail for new component added to Pool
19 I J S DA(1)=DA,DA=J D
20 . S NODE=$G(^LRD(65,DA(1),9,DA,0))
21 . S O="",X=$P(NODE,U),Z="65.091,.01" D EN^LRUD
22 . S O="",X=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
23 . S O="",X=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
24 S DA=DA(1),DIK="^LRD(65,",DIK(1)="4.1^AC^APS" D EN1^DIK
25 S X=LRT,DIK="^LRD(65,",DIK(1)="4.2^AB" D EN1^DIK
26 ; Following line adds modified to/from fields (for POOLED unit) to audit trail for the new component added to Pool
27 S DA=I,DA(1)=LRP,NODE=$G(^LRD(65,DA(1),9,DA,0))
28 S X=$P(NODE,U),O="",Z="65.091,.01" D EN^LRUD
29 S X=$P(NODE,U,2),O="",Z="65.091,.02" D EN^LRUD
30 S X=$P(NODE,U,3),O="",Z="65.091,.03" D EN^LRUD
31 S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
32 . N NEWPOOL S NEWPOOL="("_(E+1)_")" ; Updates the pooled divided units field
33 . I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
34 . S X=NEWPOOL,Z="65,4.4" D EN^LRUD
35 D VOL Q
36 ;
37G ; get next available IEN for POOLED unit modified to/from multiple
38 S I=I+1 I $D(^LRD(65,LRP,9,I,0)) G G
39 Q
40 ;
41R 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")
42 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
43 S X=^TMP($J,X),(DA,LRC)=$P(X,U,2),LRI=+X,LRC(3)=$P(X,U,3) W " ",LRC(3)
44 W !,"Ok to remove ",LRC(3)," from pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
45B S DA(1)=LRP,DA=LRI D AUDIT ; Put deleted modified to/from entry from POOLED unit on audit trail
46 S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
47 . N NEWPOOL S NEWPOOL="("_(E-1)_")" ; Update the Pooled/Divided units field
48 . I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
49 . S X=NEWPOOL,Z="65,4.4" D EN^LRUD
50 D VOL
51 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
52 D:DA AUDIT,K Q ; Put modified to/from entry from deleted COMPONENT unit on audit trail, then delete COMPONENT unit's disposition fields.
53 Q
54K S DA=DA(1),LRC=$S($D(^LRD(65,DA,4)):^(4),1:"") Q:$P(LRC,"^")'="MO"
55 F LR(4.1)=1,2,3 X:$D(^DD(65,4.1,1,LR(4.1),2)) ^(2)
56 S X=$P(LRC,"^",2) X:$D(^DD(65.4,4.2,1,1,2)) ^(2)
57 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
58 K ^LRD(65,DA,4) Q
59E 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
60 ;
61D 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
62 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
63 . S DA(1)=LRP,DA=LRI
64 . S NODE=$G(^LRD(65,LRP,9,LRI,0))
65 . S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
66 . S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
67 . S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
68 . S LRCOMP=0 F S LRCOMP=$O(^LRD(65,LRC,9,LRCOMP)) Q:'LRCOMP S DA(1)=LRC,DA=LRCOMP D
69 .. S NODE=$G(^LRD(65,LRC,9,LRCOMP,0))
70 .. S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
71 .. S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
72 .. S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
73 .. S DIK="^LRD(65,"_DA(1)_",9," D ^DIK
74 ; Above block of code places Modified to/from info from POOLED and COMPONENT units onto the audit trail
75 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
76 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
77 S DA(1)=LRP I LRDSP]"" S O=LRDSP,X="Deleted",Z="65,4.1" D EN^LRUD
78 I LRPTR]"",LRREC]"" S DA=LRREC,DIK="^LR(LRPTR,1.6," D ^DIK
79 S DA=LRP,DIK="^LRD(65," D ^DIK Q
80 ;
81T S %DT="T",X="N" D ^%DT S LRT=Y Q
82 ;
83L1 I $D(LRLOCK)#2 L -^LRD(65,LRLOCK)
84 S LRLOCK=DA L +^LRD(65,DA):1
85 I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING ",$P(^LRD(65,DA),U) S LRL=1
86 Q
87AUDIT ; Puts deleted modified to/from entries onto audit trail
88 N NODE S NODE=$G(^LRD(65,DA(1),9,DA,0))
89 S O=$P(NODE,U),X="Deleted",Z="65.091,.01" D EN^LRUD
90 S O=$P(NODE,U,2),X="Deleted",Z="65.091,.02" D EN^LRUD
91 S O=$P(NODE,U,3),X="Deleted",Z="65.091,.03" D EN^LRUD
92 D E
93 Q
94VOL ; Recalculate and updates POOLED unit volume, records change on audit trail
95 N POOLVOL,UNITVOL,UNIT,NEWVOL
96 S POOLVOL=$P(^LRD(65,LRP,0),U,11),O=POOLVOL
97 S UNIT=$P(^LRD(65,LRC,0),U,4)
98 S UNITVOL=$P(^LAB(66,UNIT,0),U,10)
99 I LR("ADJ")="R" S NEWVOL=(POOLVOL-UNITVOL)
100 I LR("ADJ")="A" S NEWVOL=(POOLVOL+UNITVOL)
101 S $P(^LRD(65,LRP,0),U,11)=NEWVOL
102 S X=NEWVOL,Z="65,.11" D EN^LRUD
103 Q
Note: See TracBrowser for help on using the repository browser.