Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRBLJM1

LRBLJM1.m

Go to the documentation of this file.
  1. LRBLJM1 ;AVAMC/REG/CYM - EDIT POOLED UNIT 10/8/97 22:09 ;
  1. ;;5.2;LAB SERVICE**90,247**;;Sep 27, 1994
  1. ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
  1. ;
  1. ; LRP=POOLED UNIT, LRC=INDIVIDUAL COMPONENT UNIT
  1. ; LR("ADJ") flags if component is added or deleted from pool
  1. ;
  1. 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)"
  1. D ^DIC K DIC Q:Y<1 S DA=+Y
  1. W !!,"Ok to add ",$P(Y(0),U)," to pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
  1. 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
  1. 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
  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
  1. N NODE S NODE=$G(^LRD(65,DA,4)) ;Adds "added unit" disposition fields to audit trail
  1. S O="",X=$P(NODE,U),Z="65,4.1" D EN^LRUD
  1. S O="",X=$P(NODE,U,2),Z="65,4.2" D EN^LRUD
  1. S O="",X=$P(NODE,U,3),Z="65,4.3" D EN^LRUD
  1. ; Following line adds modified to/from fields (for COMPONENT unit) to audit trail for new component added to Pool
  1. I J S DA(1)=DA,DA=J D
  1. . S NODE=$G(^LRD(65,DA(1),9,DA,0))
  1. . S O="",X=$P(NODE,U),Z="65.091,.01" D EN^LRUD
  1. . S O="",X=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
  1. . S O="",X=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
  1. S DA=DA(1),DIK="^LRD(65,",DIK(1)="4.1^AC^APS" D EN1^DIK
  1. S X=LRT,DIK="^LRD(65,",DIK(1)="4.2^AB" D EN1^DIK
  1. ; Following line adds modified to/from fields (for POOLED unit) to audit trail for the new component added to Pool
  1. S DA=I,DA(1)=LRP,NODE=$G(^LRD(65,DA(1),9,DA,0))
  1. S X=$P(NODE,U),O="",Z="65.091,.01" D EN^LRUD
  1. S X=$P(NODE,U,2),O="",Z="65.091,.02" D EN^LRUD
  1. S X=$P(NODE,U,3),O="",Z="65.091,.03" D EN^LRUD
  1. S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
  1. . N NEWPOOL S NEWPOOL="("_(E+1)_")" ; Updates the pooled divided units field
  1. . I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
  1. . S X=NEWPOOL,Z="65,4.4" D EN^LRUD
  1. D VOL Q
  1. ;
  1. G ; get next available IEN for POOLED unit modified to/from multiple
  1. S I=I+1 I $D(^LRD(65,LRP,9,I,0)) G G
  1. Q
  1. ;
  1. 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")
  1. 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
  1. S X=^TMP($J,X),(DA,LRC)=$P(X,U,2),LRI=+X,LRC(3)=$P(X,U,3) W " ",LRC(3)
  1. W !,"Ok to remove ",LRC(3)," from pool " S LRL=0,%=2 D YN^LRU Q:%'=1 D L1 I LRL Q
  1. B S DA(1)=LRP,DA=LRI D AUDIT ; Put deleted modified to/from entry from POOLED unit on audit trail
  1. S DA=LRP S O=$P($G(^LRD(65,DA,4)),U,4) I O]"" D
  1. . N NEWPOOL S NEWPOOL="("_(E-1)_")" ; Update the Pooled/Divided units field
  1. . I $D(^LRD(65,DA,4)) S $P(^LRD(65,DA,4),U,4)=NEWPOOL
  1. . S X=NEWPOOL,Z="65,4.4" D EN^LRUD
  1. D VOL
  1. 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
  1. D:DA AUDIT,K Q ; Put modified to/from entry from deleted COMPONENT unit on audit trail, then delete COMPONENT unit's disposition fields.
  1. Q
  1. K S DA=DA(1),LRC=$S($D(^LRD(65,DA,4)):^(4),1:"") Q:$P(LRC,"^")'="MO"
  1. F LR(4.1)=1,2,3 X:$D(^DD(65,4.1,1,LR(4.1),2)) ^(2)
  1. S X=$P(LRC,"^",2) X:$D(^DD(65.4,4.2,1,1,2)) ^(2)
  1. 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
  1. K ^LRD(65,DA,4) Q
  1. 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
  1. ;
  1. 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
  1. 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
  1. . S DA(1)=LRP,DA=LRI
  1. . S NODE=$G(^LRD(65,LRP,9,LRI,0))
  1. . S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
  1. . S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
  1. . S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
  1. . S LRCOMP=0 F S LRCOMP=$O(^LRD(65,LRC,9,LRCOMP)) Q:'LRCOMP S DA(1)=LRC,DA=LRCOMP D
  1. .. S NODE=$G(^LRD(65,LRC,9,LRCOMP,0))
  1. .. S X="Deleted",O=$P(NODE,U),Z="65.091,.01" D EN^LRUD
  1. .. S X="Deleted",O=$P(NODE,U,2),Z="65.091,.02" D EN^LRUD
  1. .. S X="Deleted",O=$P(NODE,U,3),Z="65.091,.03" D EN^LRUD
  1. .. S DIK="^LRD(65,"_DA(1)_",9," D ^DIK
  1. ; Above block of code places Modified to/from info from POOLED and COMPONENT units onto the audit trail
  1. 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
  1. 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
  1. S DA(1)=LRP I LRDSP]"" S O=LRDSP,X="Deleted",Z="65,4.1" D EN^LRUD
  1. I LRPTR]"",LRREC]"" S DA=LRREC,DIK="^LR(LRPTR,1.6," D ^DIK
  1. S DA=LRP,DIK="^LRD(65," D ^DIK Q
  1. ;
  1. T S %DT="T",X="N" D ^%DT S LRT=Y Q
  1. ;
  1. L1 I $D(LRLOCK)#2 L -^LRD(65,LRLOCK)
  1. S LRLOCK=DA L +^LRD(65,DA):1
  1. I '$T W !,$C(7),"ANOTHER TERMINAL IS EDITING ",$P(^LRD(65,DA),U) S LRL=1
  1. Q
  1. AUDIT ; Puts deleted modified to/from entries onto audit trail
  1. N NODE S NODE=$G(^LRD(65,DA(1),9,DA,0))
  1. S O=$P(NODE,U),X="Deleted",Z="65.091,.01" D EN^LRUD
  1. S O=$P(NODE,U,2),X="Deleted",Z="65.091,.02" D EN^LRUD
  1. S O=$P(NODE,U,3),X="Deleted",Z="65.091,.03" D EN^LRUD
  1. D E
  1. Q
  1. VOL ; Recalculate and updates POOLED unit volume, records change on audit trail
  1. N POOLVOL,UNITVOL,UNIT,NEWVOL
  1. S POOLVOL=$P(^LRD(65,LRP,0),U,11),O=POOLVOL
  1. S UNIT=$P(^LRD(65,LRC,0),U,4)
  1. S UNITVOL=$P(^LAB(66,UNIT,0),U,10)
  1. I LR("ADJ")="R" S NEWVOL=(POOLVOL-UNITVOL)
  1. I LR("ADJ")="A" S NEWVOL=(POOLVOL+UNITVOL)
  1. S $P(^LRD(65,LRP,0),U,11)=NEWVOL
  1. S X=NEWVOL,Z="65,.11" D EN^LRUD
  1. Q