LRUD ;AVAMC/REG - STUFF DATA CHANGES ;3/10/95 14:39 ;
;;5.2;LAB SERVICE;**35,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
N S F("Z")=1
S Z(2)="",N=$S($D(DUZ):DUZ,1:"") I N S Z(2)=$P(^VA(200,N,0),"^")
S Z(3)=$S(A:F(A),1:F(0)),Z(3)=$P(^DD(Z(3),Z(7),0),"^")
S %DT="T",X="N" D ^%DT S Z(10)=Y,Z(1)=Y
S Z(4)=Z(5),Z(6)=Z D SET S Z(5)=Z(4) Q
SET S X=@("^DD("_Z(6)_",0)"),Z(3)=$P(X,"^"),X(1)=$P(X,"^",2) I X(1)'["F"&(X(1)'["N") D @($S(X(1)["P":"P",X(1)["S":"S",X(1)["D":"D",1:"V"))
I $D(@("^DD("_Z(6)_",2.1)")) S Y=Z(4) X ^(2.1) S Z(4)=Y
Q
D I F("Z") S Y=O D D^LRU S O=$S(Y[1700:"",1:Y)
S Y=Z(4) D D^LRU S Z(4)=$S(Y[1700:"",1:Y) Q
P S X(1)="^"_$P(X,"^",3) I F("Z"),O,$D(@(X(1)_O_",0)")) S O=$P(^(0),"^")
S:Z(4) Z(4)=$P(@(X(1)_Z(4)_",0)"),U,1) Q
S S X(1)=$P(X,"^",3) I F("Z") S:O]"" O=O_":",O=$P($P(X(1),O,2),";",1)
S:Z(4)]"" Z(4)=Z(4)_":",Z(4)=$P($P(X(1),Z(4),2),";",1) Q
V Q
EN ;
Q:'$D(LRAA) S (Z(0),Z(5))=X,Z(7)=$P(Z,",",2) K A,B,F,X,Y S X("U")=+Z,F("Z")=0
F A=0:1 S B=$S($D(^DD(X("U"),0,"UP")):^("UP"),1:0) Q:'B S X=$O(^DD(B,"SB",X("U"),0)),X(A)=""""_$P($P(^DD(B,X,0),"^",4),";",1)_"""",X("U")=B
S B=0 F X=0:0 S X=$O(DA(X)) Q:'X S B=X S:$D(X(X)) F(A-X,"S")=X(X)
I A S Y(B)=DA,Y(0)=DA(B),F(A,"S")=X(0),B(1)=B-1 F X=1:1:B(1) S Y(X)=DA(B-X)
I 'A S Y(0)=$S(B:DA(B),1:DA)
D T,N L +^LRO(69.2,LRAA) I '$D(^LRO(69.2,LRAA,0)) S Z(6)=$P(^LRO(68,LRAA,0),"^",11),^(0)=LRAA_"^"_Z(6),^LRO(69.2,"B",LRAA,LRAA)="",^LRO(69.2,"C",Z(6),LRAA)="",X=^LRO(69.2,0),^(0)=$P(X,"^",1,2)_"^"_LRAA_"^"_($P(X,"^",4)+1)
S:'$D(^LRO(69.2,LRAA,999,0)) ^(0)="^69.299DA^^" S X=^(0),^(0)=$P(X,"^",1,2)_"^"_Z(10)_"^"_($P(X,"^",4)+1)
E I $D(^LRO(69.2,LRAA,999,Z(10),0)) S Z(10)=Z(10)+.00001 G E
I Z(0)="Deleted",Z(5)="" S Z(5)=Z(0)
S ^LRO(69.2,LRAA,999,Z(10),0)=Z(1)_"^"_Z(2)_"^"_Z(3)_"^"_O_"^"_Z(5)_"^"_F(0,"N")_"^"_F(0,"E")_"^"_F(0,"I") L -^LRO(69.2,LRAA)
S X=0 F A=0:1 S X=$O(F(X)) Q:'X S ^LRO(69.2,LRAA,999,Z(10),1,X,0)=F(X,"N")_"^"_$S($D(F(X,"E")):F(X,"E"),1:"")_"^"_F(X)
S:A ^LRO(69.2,LRAA,999,Z(10),1,0)="^69.37A^"_A_"^"_A I $D(LRSS),$D(L(LRSS)) D @(LRSS_"^LRUD1")
K A,B,F,O,X,Y S Y="^",X=Z(0) K Z Q
;
T I 'A S F(0)=+Z,F(0,"N")=$O(^DD(+Z,0,"NM",0)),X=^DIC(+Z,0,"GL"),Z(4)=$P(@(X_Y(0)_",0)"),"^"),Z(6)=+Z_",.01" D SET D:+Z=63 F S F(0,"E")=Z(4),F(0,"I")=Y(0) Q
S (X("U"),F(A))=+Z,A=A-1
F B=A:-1:0 S F(B)=$S($D(^DD(X("U"),0,"UP")):^("UP"),1:""),X("U")=F(B),F(B+1,"N")=$O(^("NM",0)) D:'B TT
S V=V(0) F X=0:0 S X=$O(F(X)) Q:'X!('$D(Y(X))) S V(X)=V_F(X,"S")_","_Y(X)_",",V=V(X)
S A=A+1 F B=1:1:A I $D(V(B)),$D(Y(B)) S Z(4)=$S($D(@(V(B)_"0)")):$P(@(V(B)_"0)"),"^"),1:""),Z(6)=F(B)_",.01" D SET S F(B,"E")=Z(4)
Q
TT S F(0,"N")=$O(^DD(X("U"),0,"NM",0)),F(0,"I")=Y(0),(X,F(0,"S"))=^DIC(F(0),0,"GL"),V(0)=F(0,"S")_Y(0)_",",Z(4)=$P(@(V(0)_"0)"),"^"),Z(6)=F(0)_",.01" D SET D:F(0)=63 F S F(0,"E")=Z(4) Q
F S X=^LR(Z(4),0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),Z(4)=$P(@(X_Y_",0)"),"^") Q
A ;from [LRBLSCREEN] file 63
K L W !,$C(7),"Is present testing OK " S %=2 D YN^LRU S LR("YN")=% S:%=1 L("BB")=1 D EN Q
;;Z=FILE,FIELD
;;Z(1)=DATA CHANGE DATE
;;Z(2)=PERSON CHANGING DATA
;;Z(3)=DATA ELEMENT
;;Z(4)=ENTRY IN FILE
;;O OLD INFORMATION
;;Z(5) NEW INFORMATION
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUD 3271 printed Jan 18, 2025@03:22:06 Page 2
LRUD ;AVAMC/REG - STUFF DATA CHANGES ;3/10/95 14:39 ;
+1 ;;5.2;LAB SERVICE;**35,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
N SET F("Z")=1
+1 SET Z(2)=""
SET N=$SELECT($DATA(DUZ):DUZ,1:"")
IF N
SET Z(2)=$PIECE(^VA(200,N,0),"^")
+2 SET Z(3)=$SELECT(A:F(A),1:F(0))
SET Z(3)=$PIECE(^DD(Z(3),Z(7),0),"^")
+3 SET %DT="T"
SET X="N"
DO ^%DT
SET Z(10)=Y
SET Z(1)=Y
+4 SET Z(4)=Z(5)
SET Z(6)=Z
DO SET
SET Z(5)=Z(4)
QUIT
SET SET X=@("^DD("_Z(6)_",0)")
SET Z(3)=$PIECE(X,"^")
SET X(1)=$PIECE(X,"^",2)
IF X(1)'["F"&(X(1)'["N")
DO @($SELECT(X(1)["P":"P",X(1)["S":"S",X(1)["D":"D",1:"V"))
+1 IF $DATA(@("^DD("_Z(6)_",2.1)"))
SET Y=Z(4)
XECUTE ^(2.1)
SET Z(4)=Y
+2 QUIT
D IF F("Z")
SET Y=O
DO D^LRU
SET O=$SELECT(Y[1700:"",1:Y)
+1 SET Y=Z(4)
DO D^LRU
SET Z(4)=$SELECT(Y[1700:"",1:Y)
QUIT
P SET X(1)="^"_$PIECE(X,"^",3)
IF F("Z")
IF O
IF $DATA(@(X(1)_O_",0)"))
SET O=$PIECE(^(0),"^")
+1 if Z(4)
SET Z(4)=$PIECE(@(X(1)_Z(4)_",0)"),U,1)
QUIT
S SET X(1)=$PIECE(X,"^",3)
IF F("Z")
if O]""
SET O=O_":"
SET O=$PIECE($PIECE(X(1),O,2),";",1)
+1 if Z(4)]""
SET Z(4)=Z(4)_":"
SET Z(4)=$PIECE($PIECE(X(1),Z(4),2),";",1)
QUIT
V QUIT
EN ;
+1 if '$DATA(LRAA)
QUIT
SET (Z(0),Z(5))=X
SET Z(7)=$PIECE(Z,",",2)
KILL A,B,F,X,Y
SET X("U")=+Z
SET F("Z")=0
+2 FOR A=0:1
SET B=$SELECT($DATA(^DD(X("U"),0,"UP")):^("UP"),1:0)
if 'B
QUIT
SET X=$ORDER(^DD(B,"SB",X("U"),0))
SET X(A)=""""_$PIECE($PIECE(^DD(B,X,0),"^",4),";",1)_""""
SET X("U")=B
+3 SET B=0
FOR X=0:0
SET X=$ORDER(DA(X))
if 'X
QUIT
SET B=X
if $DATA(X(X))
SET F(A-X,"S")=X(X)
+4 IF A
SET Y(B)=DA
SET Y(0)=DA(B)
SET F(A,"S")=X(0)
SET B(1)=B-1
FOR X=1:1:B(1)
SET Y(X)=DA(B-X)
+5 IF 'A
SET Y(0)=$SELECT(B:DA(B),1:DA)
+6 DO T
DO N
LOCK +^LRO(69.2,LRAA)
IF '$DATA(^LRO(69.2,LRAA,0))
SET Z(6)=$PIECE(^LRO(68,LRAA,0),"^",11)
SET ^(0)=LRAA_"^"_Z(6)
SET ^LRO(69.2,"B",LRAA,LRAA)=""
SET ^LRO(69.2,"C",Z(6),LRAA)=""
SET X=^LRO(69.2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAA_"^"_($PIECE(X,"^",4)+1)
+7 if '$DATA(^LRO(69.2,LRAA,999,0))
SET ^(0)="^69.299DA^^"
SET X=^(0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_Z(10)_"^"_($PIECE(X,"^",4)+1)
E IF $DATA(^LRO(69.2,LRAA,999,Z(10),0))
SET Z(10)=Z(10)+.00001
GOTO E
+1 IF Z(0)="Deleted"
IF Z(5)=""
SET Z(5)=Z(0)
+2 SET ^LRO(69.2,LRAA,999,Z(10),0)=Z(1)_"^"_Z(2)_"^"_Z(3)_"^"_O_"^"_Z(5)_"^"_F(0,"N")_"^"_F(0,"E")_"^"_F(0,"I")
LOCK -^LRO(69.2,LRAA)
+3 SET X=0
FOR A=0:1
SET X=$ORDER(F(X))
if 'X
QUIT
SET ^LRO(69.2,LRAA,999,Z(10),1,X,0)=F(X,"N")_"^"_$SELECT($DATA(F(X,"E")):F(X,"E"),1:"")_"^"_F(X)
+4 if A
SET ^LRO(69.2,LRAA,999,Z(10),1,0)="^69.37A^"_A_"^"_A
IF $DATA(LRSS)
IF $DATA(L(LRSS))
DO @(LRSS_"^LRUD1")
+5 KILL A,B,F,O,X,Y
SET Y="^"
SET X=Z(0)
KILL Z
QUIT
+6 ;
T IF 'A
SET F(0)=+Z
SET F(0,"N")=$ORDER(^DD(+Z,0,"NM",0))
SET X=^DIC(+Z,0,"GL")
SET Z(4)=$PIECE(@(X_Y(0)_",0)"),"^")
SET Z(6)=+Z_",.01"
DO SET
if +Z=63
DO F
SET F(0,"E")=Z(4)
SET F(0,"I")=Y(0)
QUIT
+1 SET (X("U"),F(A))=+Z
SET A=A-1
+2 FOR B=A:-1:0
SET F(B)=$SELECT($DATA(^DD(X("U"),0,"UP")):^("UP"),1:"")
SET X("U")=F(B)
SET F(B+1,"N")=$ORDER(^("NM",0))
if 'B
DO TT
+3 SET V=V(0)
FOR X=0:0
SET X=$ORDER(F(X))
if 'X!('$DATA(Y(X)))
QUIT
SET V(X)=V_F(X,"S")_","_Y(X)_","
SET V=V(X)
+4 SET A=A+1
FOR B=1:1:A
IF $DATA(V(B))
IF $DATA(Y(B))
SET Z(4)=$SELECT($DATA(@(V(B)_"0)")):$PIECE(@(V(B)_"0)"),"^"),1:"")
SET Z(6)=F(B)_",.01"
DO SET
SET F(B,"E")=Z(4)
+5 QUIT
TT SET F(0,"N")=$ORDER(^DD(X("U"),0,"NM",0))
SET F(0,"I")=Y(0)
SET (X,F(0,"S"))=^DIC(F(0),0,"GL")
SET V(0)=F(0,"S")_Y(0)_","
SET Z(4)=$PIECE(@(V(0)_"0)"),"^")
SET Z(6)=F(0)_",.01"
DO SET
if F(0)=63
DO F
SET F(0,"E")=Z(4)
QUIT
F SET X=^LR(Z(4),0)
SET Y=$PIECE(X,"^",3)
SET X=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET Z(4)=$PIECE(@(X_Y_",0)"),"^")
QUIT
A ;from [LRBLSCREEN] file 63
+1 KILL L
WRITE !,$CHAR(7),"Is present testing OK "
SET %=2
DO YN^LRU
SET LR("YN")=%
if %=1
SET L("BB")=1
DO EN
QUIT
+2 ;;Z=FILE,FIELD
+3 ;;Z(1)=DATA CHANGE DATE
+4 ;;Z(2)=PERSON CHANGING DATA
+5 ;;Z(3)=DATA ELEMENT
+6 ;;Z(4)=ENTRY IN FILE
+7 ;;O OLD INFORMATION
+8 ;;Z(5) NEW INFORMATION
