- DICATTA ;SFISC/YJK - DD AUDIT ; Aug 09, 2022@08:20:56
- ;;22.2;VA FileMan;**23**;Jan 05, 2016;Build 2
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- ;
- SV ;From DICATT & DICATTD
- F %=1:1 S A0=$P($$I,",",%) Q:A0="" I $D(^DD(A,+Y,A0)) S ^UTILITY("DDA",$J,A,+Y,A0)=^(A0)
- K %,A0 Q
- ;
- ;
- ;
- ;
- AUDT ;
- N OLD,NEW
- S B0=DDA(1) I DDA="E" D B G QQ
- S A0="LABEL^.01" I DDA["D" S OLD=$P(^UTILITY("DDA",$J,B0,DA,0),U)
- E S NEW=$P(^DD(B0,DA,0),U)
- D ADD(.OLD,.NEW) G QQ
- ;
- B S A0="",A1=^UTILITY("DDA",$J,B0,DA,0),A2=^DD(B0,DA,0)
- S A3=1,A5="LABEL^TYPE^TYPE",B3=".01^.25^.25"
- F %=1:1:3 I $P(A1,U,%)'=$P(A2,U,%) S $P(A0,",",A3)=$P(A5,U,%),$P(A4,",",A3)=$P(B3,U,%),$P(B1,"^",A3)=$P(A1,U,%),$P(B2,"^",A3)=$P(A2,U,%),A3=A3+1
- I $P(A1,U,5,99)'=$P(A2,U,5,99) S $P(A0,",",A3)="INPUT TRANSFORM",$P(B1,"^",A3)=$P(A1,U,5,99),$P(B2,"^",A3)=$P(A2,U,5,99),$P(A4,",",A3)=.5
- I A0]"" S A0=A0_"^"_A4,A1=B1,A2=B2 D ADD(A1,A2)
- K B3,A1,A2,A3,A4,A5 D B1($$I)
- Q
- ;
- ;
- I() Q "0,.1,3,4,8,8.5,9,9.1,10,AUDIT,AX"
- ;
- ;
- ;
- B1(B1) F B2=2:1 S %=$P(B1,",",B2) Q:%="" S:$D(^UTILITY("DDA",$J,B0,DA,%)) A1=^(%) S:$D(^DD(B0,DA,%)) A2=^(%) I $D(A1)!$D(A2) S %=$S(%="AUDIT":1.1,%="AX":1.2,1:%),A0=$S($D(^DD(0,%,0)):$P(^(0),U,1),1:"")_"^"_% D P
- Q
- ;
- ;
- DDAUDITQ(FILE) ;ALWAYS DO DD AUDIT
- Q 1
- ;F Q:'$G(^DD(FILE,0,"UP")) S FILE=^("UP")
- ;Q $G(^DD(FILE,0,"DDA"))="Y"
- ;
- ;
- ;
- UPDATED(FILE,FIELD) ;
- I $D(^DD(FILE,FIELD,0)) S ^("DT")=DT
- S ^DD(FILE,0,"DT")=DT
- F Q:'$G(^DD(FILE,0,"UP")) S FILE=^("UP") ;find the file level, this won't work if KIDS installs a new multiple
- S ^DD(FILE,0,"DT")=DT
- I $D(^DIC(FILE,0)) S $P(^DIC(FILE,"%MSC"),U)=$$NOWINT^DIUTL ;p23 verify we are at the file level
- Q
- ;
- ;
- P ;From ^DIAUTL & B1 above
- I $D(A1),'$D(A2) S DDA="D" D ADD(A1) K A1 Q
- I '$D(A1),$D(A2) S DDA="N" D ADD(,A2) K A2 Q
- I A1'=A2 S DDA="E" D ADD(A1,A2)
- K A1,A2 Q
- ;
- ;
- ;
- AUDIT(FILE,FIELD,OLD,NEW,ATTRIB) ;AUDIT the DATA DICTIONARY
- Q:OLD=NEW
- N DA,DDA,A0,B0,J
- S (J(0),B0)=FILE
- S DA=FIELD,DDA="E",A0=$TR(ATTRIB,"^")_"^" I ATTRIB]"" S A0=A0_$O(^DD(0,"B",ATTRIB,0))
- D ADD^DICATTA(OLD,NEW)
- Q
- ;
- ;
- ADD(OLD,NEW) ;NEED 'B0' (FILE #), 'DA'(FIELD #), 'OLD' and 'NEW' values, and A0="LENGTH^.23" or whatever. %D is return variable. If it is not there, we are not auditing.
- D UPDATED(B0,DA) ;I '$$DDAUDITQ(B0) K %D Q
- N B3,%T
- I '$D(^DDA(B0,0)) S %=$P(^DIC(J(0),0),U),^DDA(B0,0)=$S(B0=J(0):%,1:%_" ("_$P(^DD(B0,0),U,1)_")")_" DD AUDIT^.6I"
- F B3=$P(^(0),U,3):1 I '$D(^(B3)) L +^DDA(B0,B3):0 Q:$T
- S $P(^(0),U,3,4)=B3_U_($P(^(0),U,4)+1),^(B3,0)=DA L -^DDA(B0,B3)
- S %T=$$NOWINT^DIUTL,^DDA(B0,"D",%T,B3)="",^DDA(B0,"E",DUZ,B3)="",^DDA(B0,"B",DA,B3)="",^DDA(B0,B3,0)=DA_U_DDA_U_%T_U_DUZ_U_A0_U_B0
- S:$G(OLD)]"" ^(1)=OLD S:$G(NEW)]"" ^(2)=NEW
- S %D=B3 Q ;RETURNS %D
- ;
- ;
- IT ;From DIU3, DIU31, DICATT2
- S B0=DI,DDA="E" D ADD(A1,A2) G QQ
- ;
- IT1 ;From DIU31
- S B0=DI D B1(",3,4,12.1") G QQ
- ;
- XS ;From DICE
- I $P(^DD(J(N),DA,1,DQ,0),U,3)["TRIG"!($P(^(0),U,3)["BULL") S DDA="TE" Q:'$D(^(3)) S ^UTILITY("DDA",$J,J(N),DA,3)=^(3) Q
- S %=0 F B1=1:1 S %=$O(^DD(J(N),DA,1,DQ,%)) Q:+%'>0 S ^UTILITY("DDA",$J,J(N),DA,B1)=^(%)
- K B1,% Q
- ;
- XA ;From DICE, DICE0, DIKD, DICD
- S B0=J(N),DA=DL,A0="CROSS REFERENCE^1"
- I DDA["T" S DDA="E" D G QQ
- TR .K A1,A2 S:$D(^DD(B0,DA,1,DQ,3)) A2=^(3) S:$D(^UTILITY("DDA",$J,B0,DA,3)) A1=^(3) Q:'$D(A1)&'$D(A2)
- .D ADD($G(A1),$G(A2)) Q
- S %=0 D I % D ADD(,) I $G(%D)>0 S B1=$S(DDA["D":1.1,1:2.1),A0="^DD(B0,DA,1,DQ," D XL
- CK .K A1,A2 F B1=1:1:3 S:$D(^DD(B0,DA,1,DQ,B1)) A1=^(B1) S:$D(^UTILITY("DDA",$J,B0,DA,B1)) A2=^(B1) I $D(A1)!$D(A2) D Q:%
- C ..I ($D(A1)&'$D(A2))!('$D(A1)&$D(A2)) S %=1 Q
- ..S:A1'=A2 %=1
- QQ S DDA="" K B0,%D,B1,B2,%,A0,A1,A2,^UTILITY("DDA",$J) Q
- ;
- ;
- ;
- ;
- XL Q:$G(%D)'>0 S %=0 F B2=1:1 S %=$O(@(A0_%_")")) Q:+%'>0 S ^DDA(B0,%D,B1,B2,0)=^(%)
- S B2=B2-1,%=$S(B1=1.1:.601,1:.602),^DDA(B0,%D,B1,0)="^"_%_"^"_B2_"^"_B2_"^"_DT
- I DDA["E",B1=2.1 S B1=1.1,A0="^UTILITY(""DDA"",$J,B0,DA," G XL
- K %,B2 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTA 4227 printed Jan 18, 2025@03:46:34 Page 2
- DICATTA ;SFISC/YJK - DD AUDIT ; Aug 09, 2022@08:20:56
- +1 ;;22.2;VA FileMan;**23**;Jan 05, 2016;Build 2
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 ;
- SV ;From DICATT & DICATTD
- +1 FOR %=1:1
- SET A0=$PIECE($$I,",",%)
- if A0=""
- QUIT
- IF $DATA(^DD(A,+Y,A0))
- SET ^UTILITY("DDA",$JOB,A,+Y,A0)=^(A0)
- +2 KILL %,A0
- QUIT
- +3 ;
- +4 ;
- +5 ;
- +6 ;
- AUDT ;
- +1 NEW OLD,NEW
- +2 SET B0=DDA(1)
- IF DDA="E"
- DO B
- GOTO QQ
- +3 SET A0="LABEL^.01"
- IF DDA["D"
- SET OLD=$PIECE(^UTILITY("DDA",$JOB,B0,DA,0),U)
- +4 IF '$TEST
- SET NEW=$PIECE(^DD(B0,DA,0),U)
- +5 DO ADD(.OLD,.NEW)
- GOTO QQ
- +6 ;
- B SET A0=""
- SET A1=^UTILITY("DDA",$JOB,B0,DA,0)
- SET A2=^DD(B0,DA,0)
- +1 SET A3=1
- SET A5="LABEL^TYPE^TYPE"
- SET B3=".01^.25^.25"
- +2 FOR %=1:1:3
- IF $PIECE(A1,U,%)'=$PIECE(A2,U,%)
- SET $PIECE(A0,",",A3)=$PIECE(A5,U,%)
- SET $PIECE(A4,",",A3)=$PIECE(B3,U,%)
- SET $PIECE(B1,"^",A3)=$PIECE(A1,U,%)
- SET $PIECE(B2,"^",A3)=$PIECE(A2,U,%)
- SET A3=A3+1
- +3 IF $PIECE(A1,U,5,99)'=$PIECE(A2,U,5,99)
- SET $PIECE(A0,",",A3)="INPUT TRANSFORM"
- SET $PIECE(B1,"^",A3)=$PIECE(A1,U,5,99)
- SET $PIECE(B2,"^",A3)=$PIECE(A2,U,5,99)
- SET $PIECE(A4,",",A3)=.5
- +4 IF A0]""
- SET A0=A0_"^"_A4
- SET A1=B1
- SET A2=B2
- DO ADD(A1,A2)
- +5 KILL B3,A1,A2,A3,A4,A5
- DO B1($$I)
- +6 QUIT
- +7 ;
- +8 ;
- I() QUIT "0,.1,3,4,8,8.5,9,9.1,10,AUDIT,AX"
- +1 ;
- +2 ;
- +3 ;
- B1(B1) FOR B2=2:1
- SET %=$PIECE(B1,",",B2)
- if %=""
- QUIT
- if $DATA(^UTILITY("DDA",$JOB,B0,DA,%))
- SET A1=^(%)
- if $DATA(^DD(B0,DA,%))
- SET A2=^(%)
- IF $DATA(A1)!$DATA(A2)
- SET %=$SELECT(%="AUDIT":1.1,%="AX":1.2,1:%)
- SET A0=$SELECT($DATA(^DD(0,%,0)):$PIECE(^(0),U,1),1:"")_"^"_%
- DO P
- +1 QUIT
- +2 ;
- +3 ;
- DDAUDITQ(FILE) ;ALWAYS DO DD AUDIT
- +1 QUIT 1
- +2 ;F Q:'$G(^DD(FILE,0,"UP")) S FILE=^("UP")
- +3 ;Q $G(^DD(FILE,0,"DDA"))="Y"
- +4 ;
- +5 ;
- +6 ;
- UPDATED(FILE,FIELD) ;
- +1 IF $DATA(^DD(FILE,FIELD,0))
- SET ^("DT")=DT
- +2 SET ^DD(FILE,0,"DT")=DT
- +3 ;find the file level, this won't work if KIDS installs a new multiple
- FOR
- if '$GET(^DD(FILE,0,"UP"))
- QUIT
- SET FILE=^("UP")
- +4 SET ^DD(FILE,0,"DT")=DT
- +5 ;p23 verify we are at the file level
- IF $DATA(^DIC(FILE,0))
- SET $PIECE(^DIC(FILE,"%MSC"),U)=$$NOWINT^DIUTL
- +6 QUIT
- +7 ;
- +8 ;
- P ;From ^DIAUTL & B1 above
- +1 IF $DATA(A1)
- IF '$DATA(A2)
- SET DDA="D"
- DO ADD(A1)
- KILL A1
- QUIT
- +2 IF '$DATA(A1)
- IF $DATA(A2)
- SET DDA="N"
- DO ADD(,A2)
- KILL A2
- QUIT
- +3 IF A1'=A2
- SET DDA="E"
- DO ADD(A1,A2)
- +4 KILL A1,A2
- QUIT
- +5 ;
- +6 ;
- +7 ;
- AUDIT(FILE,FIELD,OLD,NEW,ATTRIB) ;AUDIT the DATA DICTIONARY
- +1 if OLD=NEW
- QUIT
- +2 NEW DA,DDA,A0,B0,J
- +3 SET (J(0),B0)=FILE
- +4 SET DA=FIELD
- SET DDA="E"
- SET A0=$TRANSLATE(ATTRIB,"^")_"^"
- IF ATTRIB]""
- SET A0=A0_$ORDER(^DD(0,"B",ATTRIB,0))
- +5 DO ADD^DICATTA(OLD,NEW)
- +6 QUIT
- +7 ;
- +8 ;
- ADD(OLD,NEW) ;NEED 'B0' (FILE #), 'DA'(FIELD #), 'OLD' and 'NEW' values, and A0="LENGTH^.23" or whatever. %D is return variable. If it is not there, we are not auditing.
- +1 ;I '$$DDAUDITQ(B0) K %D Q
- DO UPDATED(B0,DA)
- +2 NEW B3,%T
- +3 IF '$DATA(^DDA(B0,0))
- SET %=$PIECE(^DIC(J(0),0),U)
- SET ^DDA(B0,0)=$SELECT(B0=J(0):%,1:%_" ("_$PIECE(^DD(B0,0),U,1)_")")_" DD AUDIT^.6I"
- +4 FOR B3=$PIECE(^(0),U,3):1
- IF '$DATA(^(B3))
- LOCK +^DDA(B0,B3):0
- if $TEST
- QUIT
- +5 SET $PIECE(^(0),U,3,4)=B3_U_($PIECE(^(0),U,4)+1)
- SET ^(B3,0)=DA
- LOCK -^DDA(B0,B3)
- +6 SET %T=$$NOWINT^DIUTL
- SET ^DDA(B0,"D",%T,B3)=""
- SET ^DDA(B0,"E",DUZ,B3)=""
- SET ^DDA(B0,"B",DA,B3)=""
- SET ^DDA(B0,B3,0)=DA_U_DDA_U_%T_U_DUZ_U_A0_U_B0
- +7 if $GET(OLD)]""
- SET ^(1)=OLD
- if $GET(NEW)]""
- SET ^(2)=NEW
- +8 ;RETURNS %D
- SET %D=B3
- QUIT
- +9 ;
- +10 ;
- IT ;From DIU3, DIU31, DICATT2
- +1 SET B0=DI
- SET DDA="E"
- DO ADD(A1,A2)
- GOTO QQ
- +2 ;
- IT1 ;From DIU31
- +1 SET B0=DI
- DO B1(",3,4,12.1")
- GOTO QQ
- +2 ;
- XS ;From DICE
- +1 IF $PIECE(^DD(J(N),DA,1,DQ,0),U,3)["TRIG"!($PIECE(^(0),U,3)["BULL")
- SET DDA="TE"
- if '$DATA(^(3))
- QUIT
- SET ^UTILITY("DDA",$JOB,J(N),DA,3)=^(3)
- QUIT
- +2 SET %=0
- FOR B1=1:1
- SET %=$ORDER(^DD(J(N),DA,1,DQ,%))
- if +%'>0
- QUIT
- SET ^UTILITY("DDA",$JOB,J(N),DA,B1)=^(%)
- +3 KILL B1,%
- QUIT
- +4 ;
- XA ;From DICE, DICE0, DIKD, DICD
- +1 SET B0=J(N)
- SET DA=DL
- SET A0="CROSS REFERENCE^1"
- +2 IF DDA["T"
- SET DDA="E"
- Begin DoDot:1
- TR KILL A1,A2
- if $DATA(^DD(B0,DA,1,DQ,3))
- SET A2=^(3)
- if $DATA(^UTILITY("DDA",$JOB,B0,DA,3))
- SET A1=^(3)
- if '$DATA(A1)&'$DATA(A2)
- QUIT
- +1 DO ADD($GET(A1),$GET(A2))
- QUIT
- End DoDot:1
- GOTO QQ
- +2 SET %=0
- Begin DoDot:1
- CK KILL A1,A2
- FOR B1=1:1:3
- if $DATA(^DD(B0,DA,1,DQ,B1))
- SET A1=^(B1)
- if $DATA(^UTILITY("DDA",$JOB,B0,DA,B1))
- SET A2=^(B1)
- IF $DATA(A1)!$DATA(A2)
- Begin DoDot:2
- C IF ($DATA(A1)&'$DATA(A2))!('$DATA(A1)&$DATA(A2))
- SET %=1
- QUIT
- +1 if A1'=A2
- SET %=1
- End DoDot:2
- if %
- QUIT
- End DoDot:1
- IF %
- DO ADD(,)
- IF $GET(%D)>0
- SET B1=$SELECT(DDA["D":1.1,1:2.1)
- SET A0="^DD(B0,DA,1,DQ,"
- DO XL
- QQ SET DDA=""
- KILL B0,%D,B1,B2,%,A0,A1,A2,^UTILITY("DDA",$JOB)
- QUIT
- +1 ;
- +2 ;
- +3 ;
- +4 ;
- XL if $GET(%D)'>0
- QUIT
- SET %=0
- FOR B2=1:1
- SET %=$ORDER(@(A0_%_")"))
- if +%'>0
- QUIT
- SET ^DDA(B0,%D,B1,B2,0)=^(%)
- +1 SET B2=B2-1
- SET %=$SELECT(B1=1.1:.601,1:.602)
- SET ^DDA(B0,%D,B1,0)="^"_%_"^"_B2_"^"_B2_"^"_DT
- +2 IF DDA["E"
- IF B1=2.1
- SET B1=1.1
- SET A0="^UTILITY(""DDA"",$J,B0,DA,"
- GOTO XL
- +3 KILL %,B2
- QUIT