DIAUTL ;GFT/MSC - UTILITIES TO TURN ON AND TO ANALYZE FILEMAN AUDITS; May 01, 2023@08:35:32
;;22.2;VA FileMan;**27**;Jan 05, 2016;Build 7
;;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.
;GFT;**76,140,1000,1004,1005,1012,1022,1023,1039,1043,1044,1052,1053,1054**
;
TURNONDD(DIFILE,DIMODE) ;Turn on DATA DICTIONARY AUDITING --THIS IS NOW A NO-OP, BECAUSE WE AUDIT ALL DD CHANGES IN FILE .6!!!!
K:$G(DIMODE)=1 DIMODE S DIMODE=$G(DIMODE,"Y")
I DIMODE'="Y",DIMODE'="N" D BLD^DIALOG(200) Q
I DIFILE<1.11 Q
I '$D(^DIC(+DIFILE)) D BLD^DIALOG(401,DIFILE) Q
S ^DD(DIFILE,0,"DDA")=DIMODE ;It's really just one SET!
Q
;
DISP(DDB) ;DISPLAY DD CHANGES FROM ^DDA SINCE DATE 'DDB'
N DIA,FR,BY,TO,DHD,DDHD,DIC,L,POP,DDIO,DIOEND,DDTOUT,DIOSL,DIFIXPT,DIFIXPTH,DDIOST,DIOBEG S DIFIXPT=1 ;KEEPS ^%ZIS FROM BEING CALLED IN ^DIP3
D ^%ZIS Q:POP S DDIO=$G(ION,IO),DDIOST=IOST U IO
F DIA=0:0 S DIA=$O(^DDA(DIA)) Q:'DIA S FR=$O(^DDA(DIA,"D",DDB)) D:FR Q:$D(DDTOUT)
.U IO W @IOF D DDHD
.S DIC="^DDA("_DIA_",",BY="-(#.03)@",TO=DT_.2359,FLDS="[DIAUTL]",L=0
.S DIOEND="S:$G(DIOO1) DDTOUT=1",DIOSL=IOSL,DIOBEG="S ^UTILITY($J,1)=""D DISP1^DIAUTL""" ;DHD="W ?0 D DDHD^DIAUTL",IOP=DDIO
.D EN1^DIP
.I $G(DDIOST)?1"C".E N DIRUT,DIR S DIR(0)="E" D ^DIR W ! I $G(DIRUT) S DDTOUT=1
U IO W @IOF D CLOSE^DIO4
Q
DISP1 ;CALLED FROM ^UTILITY($J,1) TO HOLD LONG PRINTOUT FROM A SINGLE FILE'S DATA DICTIONARY AUDIT
I $G(DDIOST)?1"C".E,DC?.N W $C(7) R Y:DTIME W:$Y # E S DN=0,DDTOUT=1 Q
S DC=1
Q
;
DDHD S DDHD="DATA DICTIONARY CHANGES, "_$P($G(^DIC(DIA,0)),U)_" FILE(#"_DIA_")" S:DDB>2000000 DDHD=DDHD_" since "_$$DATE^DIUTL(DDB)
W DDHD,!
W "FIELD ATTRIBUTE USER NUMBER",!
W "------------------------------------------------------------------------------",!
Q
;
;
TURNON(DIFILE,FLDS,DIMODE,DICOND) ;Turn on AUDITING
;Input: DIFILE=file #, FLDS=fields to audit, DIMODE=mode("y","n","e"), DICOND=audit condition ;p27
;DICOND is only set if FLDS=single field
N D,DIFIELD,DIE,DR,DA,DIQUIET,DIEZS,D0,DQ,DI,DIC,X
K:$G(DIMODE)=1 DIMODE S DIMODE=$E($G(DIMODE,"y"))
I DIMODE'="y",DIMODE'="e",DIMODE'="n" D BLD^DIALOG(200) Q
S DIQUIET=1,DIEZS=1 Q:DIFILE<1.11&(DIFILE-.4)&(DIFILE-.401)&(DIFILE-.402)&(DIFILE-.403)&(DIFILE-.5)&(DIFILE-.7)&(DIFILE-.84)&(DIFILE-.847)
D DT^DICRW
I $G(DICOND)]"",FLDS=+FLDS,FLDS'=.001 D Q ;add Audit Condition to a field ;p27
. S DIFIELD=FLDS D ON
. Q:DIMODE="n" ;quit if no audit
. S DR="1.2////"_DICOND,DIE="^DD("_DIFILE_",",DA(1)=DIFILE,DA=DIFIELD
. D ^DIE
. Q
F DIFIELD=0:0 S DIFIELD=$O(^DD(DIFILE,DIFIELD)) Q:'DIFIELD D:$$FLDSINC(DIFILE,FLDS,DIFIELD) ON
Q
ON N DIOLD
S DIOLD=$G(^DD(DIFILE,DIFIELD,"AUDIT")) I DIOLD=DIMODE Q ;It's already on
S D=$P($G(^(0)),U,2) Q:D["C"
I D D TURNON(+D,"**",DIMODE) Q ;Recursive!
S DR="1.1////"_DIMODE,DIE="^DD("_DIFILE_",",DA(1)=DIFILE,DA=DIFIELD
I DA=.001,DIMODE="y" Q ;CAN'T AUDIT NUMBER FIELD!!
S:DIMODE="n" DR=DR_";1.2////@" ;delete Audit Condition if not auditing
D ^DIE
D IN^DIU0(DIFILE,DIFIELD),DDAUDIT(DIFILE,DIFIELD,1.1,DIOLD,DIMODE)
I $G(^DD(DIFILE,0,"DIK"))]"" D EN2^DIKZ(DIFILE,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes
Q
;
CHANGED(FILE,FLDS,FLAGS,ARRAY,START,END) ;
;Returns in @ARRAY the list of entries in FILE who had any of the fields in FLDS changed from START to END
;If FLAGS is "O", the Oldest values are saved in @ARRAY@(entry,field)
N GLO,E,F,T,D,%I
K @ARRAY
S FLAGS=$G(FLAGS)
S GLO=^DIC(FILE,0,"GL")
I '$G(START) S START=0
I '$G(END) D NOW^%DTC S END=%
S T=START D F S T=$O(^DIA(FILE,"C",T)) Q:T>END!'T D
.F D=0:0 S D=$O(^DIA(FILE,"C",T,D)) Q:'D D
..S E=$G(^DIA(FILE,D,0)) Q:$P(E,U,6)="i"!'E
..I $D(@ARRAY@(+E)),FLAGS="" Q
..S F=+$P(E,U,3) Q:'$$FLDSINC(FILE,FLDS,F)
..I '$D(@(GLO_"+E)")),FLAGS="" Q
..S @ARRAY@(+E)="" I FLAGS["O",'$D(@ARRAY@(+E,F)) S @ARRAY@(+E,F)=$G(^DIA(FILE,D,2))
Q
;
FIRST(DIQGR,ENTRY,FLDS) ;
N LOF S LOF=1 G LOF
LAST(DIQGR,ENTRY,FLDS) ;returns DATE^USER who most recently touched any of the FLDS in ENTRY in File DIQGR
N LOF S LOF=-1
LOF N E,F,DILAST,DENTRY,L
S DILAST="",DENTRY=+ENTRY
I ENTRY["," D
.F F=2:1 Q:'$D(^DD(DIQGR,0,"UP")) S DENTRY=$P(ENTRY,",",F)_","_DENTRY
D E
S DENTRY=ENTRY_","
F S DENTRY=$O(^DIA(DIQGR,"B",DENTRY)) Q:DENTRY-ENTRY D E
Q DILAST
;
E S E="" F S E=$O(^DIA(DIQGR,"B",DENTRY,E),LOF) Q:'E I $$FLDSINC(DIQGR,FLDS,+$P($G(^DIA(DIQGR,E,0)),U,3)) D Q:DENTRY=ENTRY&DILAST
.Q:$P(^DIA(DIQGR,E,0),U,6)="i" ;Ignore INQUIRY
.S L=$P(^(0),"^",2)_"^"_$P(^(0),"^",4)_"^"_$P($G(^(4.1)),U)
.I LOF=-1,L>DILAST S DILAST=L
.I LOF=1,DILAST>L!'DILAST S DILAST=L
Q
;
DATE(FILE,FIELD) ;
D VALUE(FILE,FIELD,2) Q
;
USER(FILE,FIELD) ;
D VALUE(FILE,FIELD,4) Q
;
VALUE(FILE,FIELD,TU) ;FILE' can be SubFile
N DIACMP,ENTRY,I
S ENTRY=+$G(D0)
F I=1:1 Q:'$D(^DD(FILE,0,"UP")) S ENTRY=ENTRY_","_+$G(@("D"_I)),F=^("UP"),FIELD=$O(^DD(F,"SB",FILE,0))_","_FIELD,FILE=F
D PRIOR(FILE,ENTRY,FIELD,.DIACMP)
S D="" F S D=$O(DIACMP(D),-1) Q:'D S X=$S($G(TU):$P(^DIA(FILE,D,0),U,TU),1:DIACMP(D)) X DICMX Q:'$D(D)
S X="" Q
;
PRIOR(FILE,ENTRY,FIELD,OUT) ;
N E
F E=0:0 S E=$O(^DIA(FILE,"B",ENTRY,E)) Q:'E I $P($G(^DIA(FILE,E,0)),U,3)=FIELD S OUT(E)=$G(^(2))
Q
;
FLDSINC(DIQGR,DR,DIAUTLF) ;is DIAUTLF within DR? -- from 'DIQGQ' routine
I DR=""!'DIAUTLF Q 0
I DR="*" Q 1
N DIAUGOT,DIQGCP,DIQGDD,DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDD
S DIQGXDC=0,DIAUGOT=0,DIQGDD=1,DIQGCP="D"
I '$D(DIQGR) N X S X(1)="FILE" D 202 Q 0
S DIQGXDD="^DD("_DIQGR_")"
S:DIQGR DIQGR=$S(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE AND IEN COMBINATION" D 202 Q 0
F DIQGXDI=1:1 S DIQGXDF=$P(DR,";",DIQGXDI),DIQGXDN=$P(DIQGXDF,":") Q:DIQGXDF="" D RANGE G GOT:DIAUGOT
NOGOT Q 0
;
RANGE I DIQGXDC,$P(^DD(+DIQGXDC,.01,0),"^",2)'["W" S:DR="**" DIQGXDN=DIQGXDN_"*" Q:$L(DIQGXDN,"*")'=2 ;multiple
I DIQGXDN'?.N,$L(DIQGXDN,"*")=2,$P(DIQGXDN,"*")]"",$D(@DIQGXDD@("B",$P(DIQGXDN,"*"))) S DIQGXDN=$O(^($P(DIQGXDN,"*"),""))_"*"
I DIQGXDN?1.2"*" S DIAUGOT=1 Q
Q:DIAUTLF<DIQGXDN I $P(DIQGXDF,":",2)<DIAUTLF Q:DIAUTLF-DIQGXDN
S DIAUGOT=1 Q
;
GOT Q 1
;
DD(X) Q:'$D(^DD(X)) "" Q "^DD("_X_","
202 D BLD^DIALOG(202,.X) Q ;bad parameter
;
;
GET(FIL,DA,DATE,TMP,FIELD) ;BUILD 'TMP' ARRAY AS OF DATE
;DA is in IEN format FIELD, optional, means just look at one field
K @TMP
N DAT,FLD,FILE,F,D,E,B,C,T
S F=FIL,FILE=$$FNO^DILIBF(F),@TMP=FILE,D=+$P(DA,",",$L(DA,",")-1) I 'D S D=DA
I F=FILE F E=0:0 S E=$O(^DIA(FILE,"B",D,E)) Q:'E D L G Q:$G(@TMP@(F,D_","))
SUBFILES S D=D_"," F S E=D,D=$O(^DIA(FILE,"B",D)) Q:D-E D
.F E=0:0 S E=$O(^DIA(FILE,"B",D,E)) Q:'E D L
Q
L I $P($G(^DIA(FILE,E,0)),U)'=D Q
S FLD=$P(^(0),U,3),DAT=$P(^(0),U,2),I="",F=FILE
F S C=$L(FLD,","),I=I_$P(D,",",C)_"," Q:C=1 S T=+FLD G Q:'$D(^DD(F,T,0)) S T=+$P(^(0),U,2) G Q:T'>F!'$D(^DD(T)) S F=T,FLD=$P(FLD,",",2,C)
I FLD=.01,DAT>DATE,$P(^DIA(FILE,E,0),U,5)="A" K @TMP@(F,I) S @TMP@(F,I)=1 Q ;THAT ENTRY OR SUB-ENTRY DIDN'T EXIST AS OF DATE 2nd level will only be defined in this case
I $G(FIELD),FLD-FIELD!(F-FIL) Q
I '$D(@TMP@(F,I,FLD)) S @TMP@(F,I,FLD)=DAT_U_E Q
I DAT>DATE Q
I @TMP@(F,I,FLD)<DAT S @TMP@(F,I,FLD)=DAT_U_E
Q Q
;
DIA(DAT,FILE,X,DIAUTLEX) ;FROM DIQG AND DIQGQ
;X is a node value from the 'TMP' array built by the GET subroutine, above
;DAT is the date/time as of which we want the audited value
;DIAUTLEX may contain "E" if we want external value
I X>DAT Q $$D(2) ;We know what it was before deletion
Q $$D(3)
D(ON) S X=$G(^DIA(FILE,+$P(X,U,2),ON)) I $G(DIAUTLEX)["E" Q X
N S,Y S S=$G(^(ON+.1)) I X]"",S="" D I Y>0 Q Y
.N %DT S %DT="T" D ^%DT
S S=$P(S,U) I S]"" Q S
Q X
;
DDAUDIT(B0,DA,A0,A1,A2) ;B0=File or SubFile, DA=Field, A0=Attribute #, A1=Old value, A2=New value
N DDA,%,%T,%D,J,B3,I
Q:'$D(DUZ)!'$G(DT)
D IJ^DIUTL(B0)
S A0=+$G(A0),A0=$P($G(^DD(0,A0,0)),U)_U_A0
K:$G(A1)="" A1 L:$G(A2)="" A2
D P^DICATTA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAUTL 8260 printed Dec 13, 2024@02:45 Page 2
DIAUTL ;GFT/MSC - UTILITIES TO TURN ON AND TO ANALYZE FILEMAN AUDITS; May 01, 2023@08:35:32
+1 ;;22.2;VA FileMan;**27**;Jan 05, 2016;Build 7
+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 ;GFT;**76,140,1000,1004,1005,1012,1022,1023,1039,1043,1044,1052,1053,1054**
+7 ;
TURNONDD(DIFILE,DIMODE) ;Turn on DATA DICTIONARY AUDITING --THIS IS NOW A NO-OP, BECAUSE WE AUDIT ALL DD CHANGES IN FILE .6!!!!
+1 if $GET(DIMODE)=1
KILL DIMODE
SET DIMODE=$GET(DIMODE,"Y")
+2 IF DIMODE'="Y"
IF DIMODE'="N"
DO BLD^DIALOG(200)
QUIT
+3 IF DIFILE<1.11
QUIT
+4 IF '$DATA(^DIC(+DIFILE))
DO BLD^DIALOG(401,DIFILE)
QUIT
+5 ;It's really just one SET!
SET ^DD(DIFILE,0,"DDA")=DIMODE
+6 QUIT
+7 ;
DISP(DDB) ;DISPLAY DD CHANGES FROM ^DDA SINCE DATE 'DDB'
+1 ;KEEPS ^%ZIS FROM BEING CALLED IN ^DIP3
NEW DIA,FR,BY,TO,DHD,DDHD,DIC,L,POP,DDIO,DIOEND,DDTOUT,DIOSL,DIFIXPT,DIFIXPTH,DDIOST,DIOBEG
SET DIFIXPT=1
+2 DO ^%ZIS
if POP
QUIT
SET DDIO=$GET(ION,IO)
SET DDIOST=IOST
USE IO
+3 FOR DIA=0:0
SET DIA=$ORDER(^DDA(DIA))
if 'DIA
QUIT
SET FR=$ORDER(^DDA(DIA,"D",DDB))
if FR
Begin DoDot:1
+4 USE IO
WRITE @IOF
DO DDHD
+5 SET DIC="^DDA("_DIA_","
SET BY="-(#.03)@"
SET TO=DT_.2359
SET FLDS="[DIAUTL]"
SET L=0
+6 ;DHD="W ?0 D DDHD^DIAUTL",IOP=DDIO
SET DIOEND="S:$G(DIOO1) DDTOUT=1"
SET DIOSL=IOSL
SET DIOBEG="S ^UTILITY($J,1)=""D DISP1^DIAUTL"""
+7 DO EN1^DIP
+8 IF $GET(DDIOST)?1"C".E
NEW DIRUT,DIR
SET DIR(0)="E"
DO ^DIR
WRITE !
IF $GET(DIRUT)
SET DDTOUT=1
End DoDot:1
if $DATA(DDTOUT)
QUIT
+9 USE IO
WRITE @IOF
DO CLOSE^DIO4
+10 QUIT
DISP1 ;CALLED FROM ^UTILITY($J,1) TO HOLD LONG PRINTOUT FROM A SINGLE FILE'S DATA DICTIONARY AUDIT
+1 IF $GET(DDIOST)?1"C".E
IF DC?.N
WRITE $CHAR(7)
READ Y:DTIME
if $Y
WRITE #
IF '$TEST
SET DN=0
SET DDTOUT=1
QUIT
+2 SET DC=1
+3 QUIT
+4 ;
DDHD SET DDHD="DATA DICTIONARY CHANGES, "_$PIECE($GET(^DIC(DIA,0)),U)_" FILE(#"_DIA_")"
if DDB>2000000
SET DDHD=DDHD_" since "_$$DATE^DIUTL(DDB)
+1 WRITE DDHD,!
+2 WRITE "FIELD ATTRIBUTE USER NUMBER",!
+3 WRITE "------------------------------------------------------------------------------",!
+4 QUIT
+5 ;
+6 ;
TURNON(DIFILE,FLDS,DIMODE,DICOND) ;Turn on AUDITING
+1 ;Input: DIFILE=file #, FLDS=fields to audit, DIMODE=mode("y","n","e"), DICOND=audit condition ;p27
+2 ;DICOND is only set if FLDS=single field
+3 NEW D,DIFIELD,DIE,DR,DA,DIQUIET,DIEZS,D0,DQ,DI,DIC,X
+4 if $GET(DIMODE)=1
KILL DIMODE
SET DIMODE=$EXTRACT($GET(DIMODE,"y"))
+5 IF DIMODE'="y"
IF DIMODE'="e"
IF DIMODE'="n"
DO BLD^DIALOG(200)
QUIT
+6 SET DIQUIET=1
SET DIEZS=1
if DIFILE<1.11&(DIFILE-.4)&(DIFILE-.401)&(DIFILE-.402)&(DIFILE-.403)&(DIFILE-.5)&(DIFILE-.7)&(DIFILE-.84)&(DIFILE-.847)
QUIT
+7 DO DT^DICRW
+8 ;add Audit Condition to a field ;p27
IF $GET(DICOND)]""
IF FLDS=+FLDS
IF FLDS'=.001
Begin DoDot:1
+9 SET DIFIELD=FLDS
DO ON
+10 ;quit if no audit
if DIMODE="n"
QUIT
+11 SET DR="1.2////"_DICOND
SET DIE="^DD("_DIFILE_","
SET DA(1)=DIFILE
SET DA=DIFIELD
+12 DO ^DIE
+13 QUIT
End DoDot:1
QUIT
+14 FOR DIFIELD=0:0
SET DIFIELD=$ORDER(^DD(DIFILE,DIFIELD))
if 'DIFIELD
QUIT
if $$FLDSINC(DIFILE,FLDS,DIFIELD)
DO ON
+15 QUIT
ON NEW DIOLD
+1 ;It's already on
SET DIOLD=$GET(^DD(DIFILE,DIFIELD,"AUDIT"))
IF DIOLD=DIMODE
QUIT
+2 SET D=$PIECE($GET(^(0)),U,2)
if D["C"
QUIT
+3 ;Recursive!
IF D
DO TURNON(+D,"**",DIMODE)
QUIT
+4 SET DR="1.1////"_DIMODE
SET DIE="^DD("_DIFILE_","
SET DA(1)=DIFILE
SET DA=DIFIELD
+5 ;CAN'T AUDIT NUMBER FIELD!!
IF DA=.001
IF DIMODE="y"
QUIT
+6 ;delete Audit Condition if not auditing
if DIMODE="n"
SET DR=DR_";1.2////@"
+7 DO ^DIE
+8 DO IN^DIU0(DIFILE,DIFIELD)
DO DDAUDIT(DIFILE,DIFIELD,1.1,DIOLD,DIMODE)
+9 ;Recompile CROSS-REFS if auditing changes
IF $GET(^DD(DIFILE,0,"DIK"))]""
DO EN2^DIKZ(DIFILE,"",^("DIK"))
+10 QUIT
+11 ;
CHANGED(FILE,FLDS,FLAGS,ARRAY,START,END) ;
+1 ;Returns in @ARRAY the list of entries in FILE who had any of the fields in FLDS changed from START to END
+2 ;If FLAGS is "O", the Oldest values are saved in @ARRAY@(entry,field)
+3 NEW GLO,E,F,T,D,%I
+4 KILL @ARRAY
+5 SET FLAGS=$GET(FLAGS)
+6 SET GLO=^DIC(FILE,0,"GL")
+7 IF '$GET(START)
SET START=0
+8 IF '$GET(END)
DO NOW^%DTC
SET END=%
+9 SET T=START
Begin DoDot:1
+10 FOR D=0:0
SET D=$ORDER(^DIA(FILE,"C",T,D))
if 'D
QUIT
Begin DoDot:2
+11 SET E=$GET(^DIA(FILE,D,0))
if $PIECE(E,U,6)="i"!'E
QUIT
+12 IF $DATA(@ARRAY@(+E))
IF FLAGS=""
QUIT
+13 SET F=+$PIECE(E,U,3)
if '$$FLDSINC(FILE,FLDS,F)
QUIT
+14 IF '$DATA(@(GLO_"+E)"))
IF FLAGS=""
QUIT
+15 SET @ARRAY@(+E)=""
IF FLAGS["O"
IF '$DATA(@ARRAY@(+E,F))
SET @ARRAY@(+E,F)=$GET(^DIA(FILE,D,2))
End DoDot:2
End DoDot:1
FOR
SET T=$ORDER(^DIA(FILE,"C",T))
if T>END!'T
QUIT
Begin DoDot:1
End DoDot:1
+16 QUIT
+17 ;
FIRST(DIQGR,ENTRY,FLDS) ;
+1 NEW LOF
SET LOF=1
GOTO LOF
LAST(DIQGR,ENTRY,FLDS) ;returns DATE^USER who most recently touched any of the FLDS in ENTRY in File DIQGR
+1 NEW LOF
SET LOF=-1
LOF NEW E,F,DILAST,DENTRY,L
+1 SET DILAST=""
SET DENTRY=+ENTRY
+2 IF ENTRY[","
Begin DoDot:1
+3 FOR F=2:1
if '$DATA(^DD(DIQGR,0,"UP"))
QUIT
SET DENTRY=$PIECE(ENTRY,",",F)_","_DENTRY
End DoDot:1
+4 DO E
+5 SET DENTRY=ENTRY_","
+6 FOR
SET DENTRY=$ORDER(^DIA(DIQGR,"B",DENTRY))
if DENTRY-ENTRY
QUIT
DO E
+7 QUIT DILAST
+8 ;
E SET E=""
FOR
SET E=$ORDER(^DIA(DIQGR,"B",DENTRY,E),LOF)
if 'E
QUIT
IF $$FLDSINC(DIQGR,FLDS,+$PIECE($GET(^DIA(DIQGR,E,0)),U,3))
Begin DoDot:1
+1 ;Ignore INQUIRY
if $PIECE(^DIA(DIQGR,E,0),U,6)="i"
QUIT
+2 SET L=$PIECE(^(0),"^",2)_"^"_$PIECE(^(0),"^",4)_"^"_$PIECE($GET(^(4.1)),U)
+3 IF LOF=-1
IF L>DILAST
SET DILAST=L
+4 IF LOF=1
IF DILAST>L!'DILAST
SET DILAST=L
End DoDot:1
if DENTRY=ENTRY&DILAST
QUIT
+5 QUIT
+6 ;
DATE(FILE,FIELD) ;
+1 DO VALUE(FILE,FIELD,2)
QUIT
+2 ;
USER(FILE,FIELD) ;
+1 DO VALUE(FILE,FIELD,4)
QUIT
+2 ;
VALUE(FILE,FIELD,TU) ;FILE' can be SubFile
+1 NEW DIACMP,ENTRY,I
+2 SET ENTRY=+$GET(D0)
+3 FOR I=1:1
if '$DATA(^DD(FILE,0,"UP"))
QUIT
SET ENTRY=ENTRY_","_+$GET(@("D"_I))
SET F=^("UP")
SET FIELD=$ORDER(^DD(F,"SB",FILE,0))_","_FIELD
SET FILE=F
+4 DO PRIOR(FILE,ENTRY,FIELD,.DIACMP)
+5 SET D=""
FOR
SET D=$ORDER(DIACMP(D),-1)
if 'D
QUIT
SET X=$SELECT($GET(TU):$PIECE(^DIA(FILE,D,0),U,TU),1:DIACMP(D))
XECUTE DICMX
if '$DATA(D)
QUIT
+6 SET X=""
QUIT
+7 ;
PRIOR(FILE,ENTRY,FIELD,OUT) ;
+1 NEW E
+2 FOR E=0:0
SET E=$ORDER(^DIA(FILE,"B",ENTRY,E))
if 'E
QUIT
IF $PIECE($GET(^DIA(FILE,E,0)),U,3)=FIELD
SET OUT(E)=$GET(^(2))
+3 QUIT
+4 ;
FLDSINC(DIQGR,DR,DIAUTLF) ;is DIAUTLF within DR? -- from 'DIQGQ' routine
+1 IF DR=""!'DIAUTLF
QUIT 0
+2 IF DR="*"
QUIT 1
+3 NEW DIAUGOT,DIQGCP,DIQGDD,DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDD
+4 SET DIQGXDC=0
SET DIAUGOT=0
SET DIQGDD=1
SET DIQGCP="D"
+5 IF '$DATA(DIQGR)
NEW X
SET X(1)="FILE"
DO 202
QUIT 0
+6 SET DIQGXDD="^DD("_DIQGR_")"
+7 if DIQGR
SET DIQGR=$SELECT(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA))
IF DIQGR=""
NEW X
SET X(1)="FILE AND IEN COMBINATION"
DO 202
QUIT 0
+8 FOR DIQGXDI=1:1
SET DIQGXDF=$PIECE(DR,";",DIQGXDI)
SET DIQGXDN=$PIECE(DIQGXDF,":")
if DIQGXDF=""
QUIT
DO RANGE
if DIAUGOT
GOTO GOT
NOGOT QUIT 0
+1 ;
RANGE ;multiple
IF DIQGXDC
IF $PIECE(^DD(+DIQGXDC,.01,0),"^",2)'["W"
if DR="**"
SET DIQGXDN=DIQGXDN_"*"
if $LENGTH(DIQGXDN,"*")'=2
QUIT
+1 IF DIQGXDN'?.N
IF $LENGTH(DIQGXDN,"*")=2
IF $PIECE(DIQGXDN,"*")]""
IF $DATA(@DIQGXDD@("B",$PIECE(DIQGXDN,"*")))
SET DIQGXDN=$ORDER(^($PIECE(DIQGXDN,"*"),""))_"*"
+2 IF DIQGXDN?1.2"*"
SET DIAUGOT=1
QUIT
+3 if DIAUTLF<DIQGXDN
QUIT
IF $PIECE(DIQGXDF,":",2)<DIAUTLF
if DIAUTLF-DIQGXDN
QUIT
+4 SET DIAUGOT=1
QUIT
+5 ;
GOT QUIT 1
+1 ;
DD(X) if '$DATA(^DD(X))
QUIT ""
QUIT "^DD("_X_","
202 ;bad parameter
DO BLD^DIALOG(202,.X)
QUIT
+1 ;
+2 ;
GET(FIL,DA,DATE,TMP,FIELD) ;BUILD 'TMP' ARRAY AS OF DATE
+1 ;DA is in IEN format FIELD, optional, means just look at one field
+2 KILL @TMP
+3 NEW DAT,FLD,FILE,F,D,E,B,C,T
+4 SET F=FIL
SET FILE=$$FNO^DILIBF(F)
SET @TMP=FILE
SET D=+$PIECE(DA,",",$LENGTH(DA,",")-1)
IF 'D
SET D=DA
+5 IF F=FILE
FOR E=0:0
SET E=$ORDER(^DIA(FILE,"B",D,E))
if 'E
QUIT
DO L
if $GET(@TMP@(F,D_","))
GOTO Q
SUBFILES SET D=D_","
FOR
SET E=D
SET D=$ORDER(^DIA(FILE,"B",D))
if D-E
QUIT
Begin DoDot:1
+1 FOR E=0:0
SET E=$ORDER(^DIA(FILE,"B",D,E))
if 'E
QUIT
DO L
End DoDot:1
+2 QUIT
L IF $PIECE($GET(^DIA(FILE,E,0)),U)'=D
QUIT
+1 SET FLD=$PIECE(^(0),U,3)
SET DAT=$PIECE(^(0),U,2)
SET I=""
SET F=FILE
+2 FOR
SET C=$LENGTH(FLD,",")
SET I=I_$PIECE(D,",",C)_","
if C=1
QUIT
SET T=+FLD
if '$DATA(^DD(F,T,0))
GOTO Q
SET T=+$PIECE(^(0),U,2)
if T'>F!'$DATA(^DD(T))
GOTO Q
SET F=T
SET FLD=$PIECE(FLD,",",2,C)
+3 ;THAT ENTRY OR SUB-ENTRY DIDN'T EXIST AS OF DATE 2nd level will only be defined in this case
IF FLD=.01
IF DAT>DATE
IF $PIECE(^DIA(FILE,E,0),U,5)="A"
KILL @TMP@(F,I)
SET @TMP@(F,I)=1
QUIT
+4 IF $GET(FIELD)
IF FLD-FIELD!(F-FIL)
QUIT
+5 IF '$DATA(@TMP@(F,I,FLD))
SET @TMP@(F,I,FLD)=DAT_U_E
QUIT
+6 IF DAT>DATE
QUIT
+7 IF @TMP@(F,I,FLD)<DAT
SET @TMP@(F,I,FLD)=DAT_U_E
Q QUIT
+1 ;
DIA(DAT,FILE,X,DIAUTLEX) ;FROM DIQG AND DIQGQ
+1 ;X is a node value from the 'TMP' array built by the GET subroutine, above
+2 ;DAT is the date/time as of which we want the audited value
+3 ;DIAUTLEX may contain "E" if we want external value
+4 ;We know what it was before deletion
IF X>DAT
QUIT $$D(2)
+5 QUIT $$D(3)
D(ON) SET X=$GET(^DIA(FILE,+$PIECE(X,U,2),ON))
IF $GET(DIAUTLEX)["E"
QUIT X
+1 NEW S,Y
SET S=$GET(^(ON+.1))
IF X]""
IF S=""
Begin DoDot:1
+2 NEW %DT
SET %DT="T"
DO ^%DT
End DoDot:1
IF Y>0
QUIT Y
+3 SET S=$PIECE(S,U)
IF S]""
QUIT S
+4 QUIT X
+5 ;
DDAUDIT(B0,DA,A0,A1,A2) ;B0=File or SubFile, DA=Field, A0=Attribute #, A1=Old value, A2=New value
+1 NEW DDA,%,%T,%D,J,B3,I
+2 if '$DATA(DUZ)!'$GET(DT)
QUIT
+3 DO IJ^DIUTL(B0)
+4 SET A0=+$GET(A0)
SET A0=$PIECE($GET(^DD(0,A0,0)),U)_U_A0
+5 if $GET(A1)=""
KILL A1
if $GET(A2)=""
LOCK A2
+6 DO P^DICATTA
QUIT
