- DIAUTL ;GFT;13AUG2004
- ;;22.0;VA FileMan;**76,140**;Mar 30, 1999
- ;
- TURNON(DIFILE,FLDS,DIMODE) ;Turn on AUDITING for the FLDS named
- N D,DIFIELD,DIE,DR,DA,DIQUIET,DIEZS,D0,DQ,DI,DIC,X
- S DIMODE=$E($G(DIMODE,"y")),DIQUIET=1,DIEZS=1 Q:DIFILE<2 Q:"yen"'[DIMODE
- 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 Q:$P($G(^DD(+D,.01,0)),U,2)["W" 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!!
- D ^DIE
- D IN^DIU0(DIFILE,DIFIELD),DDAUDIT(DIFILE,DIFIELD,1.1,DIOLD,DIMODE)
- 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:'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
- ;
- LAST(DIQGR,ENTRY,FLDS) ;returns DATE^USER who most recently touched any of the FLDS in ENTRY in File DIQGR
- N E,F,DILAST,DENTRY
- S DILAST="",DENTRY=ENTRY 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),-1) Q:'E I $$FLDSINC(DIQGR,FLDS,+$P($G(^DIA(DIQGR,E,0)),U,3)) D Q:DENTRY=ENTRY
- .N L S L=$P(^DIA(DIQGR,E,0),"^",2)_"^"_$P(^(0),"^",4)
- .I 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,$D(^(2)) S OUT(E)=^(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" G 202
- 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" G 202
- 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) I $G(^DD(J(0),0,"DDA"))'["Y" Q ;only if DD audit is on
- 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
- DIAUTL ;GFT;13AUG2004
- +1 ;;22.0;VA FileMan;**76,140**;Mar 30, 1999
- +2 ;
- TURNON(DIFILE,FLDS,DIMODE) ;Turn on AUDITING for the FLDS named
- +1 NEW D,DIFIELD,DIE,DR,DA,DIQUIET,DIEZS,D0,DQ,DI,DIC,X
- +2 SET DIMODE=$EXTRACT($GET(DIMODE,"y"))
- SET DIQUIET=1
- SET DIEZS=1
- IF DIFILE<2
- QUIT
- IF "yen"'[DIMODE
- QUIT
- +3 FOR DIFIELD=0:0
- SET DIFIELD=$ORDER(^DD(DIFILE,DIFIELD))
- IF 'DIFIELD
- QUIT
- IF $$FLDSINC(DIFILE,FLDS,DIFIELD)
- DO ON
- +4 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
- IF $PIECE($GET(^DD(+D,.01,0)),U,2)["W"
- QUIT
- 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 DO ^DIE
- +7 DO IN^DIU0(DIFILE,DIFIELD)
- DO DDAUDIT(DIFILE,DIFIELD,1.1,DIOLD,DIMODE)
- +8 QUIT
- +9 ;
- 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 '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 ;
- LAST(DIQGR,ENTRY,FLDS) ;returns DATE^USER who most recently touched any of the FLDS in ENTRY in File DIQGR
- +1 NEW E,F,DILAST,DENTRY
- +2 SET DILAST=""
- SET DENTRY=ENTRY
- DO E
- +3 SET DENTRY=ENTRY_","
- +4 FOR
- SET DENTRY=$ORDER(^DIA(DIQGR,"B",DENTRY))
- IF DENTRY-ENTRY
- QUIT
- DO E
- +5 QUIT DILAST
- E SET E=""
- FOR
- SET E=$ORDER(^DIA(DIQGR,"B",DENTRY,E),-1)
- IF 'E
- QUIT
- IF $$FLDSINC(DIQGR,FLDS,+$PIECE($GET(^DIA(DIQGR,E,0)),U,3))
- Begin DoDot:1
- +1 NEW L
- SET L=$PIECE(^DIA(DIQGR,E,0),"^",2)_"^"_$PIECE(^(0),"^",4)
- +2 IF L>DILAST
- SET DILAST=L
- End DoDot:1
- IF DENTRY=ENTRY
- QUIT
- +3 QUIT
- +4 ;
- 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
- IF $DATA(^(2))
- SET OUT(E)=^(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"
- GOTO 202
- +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"
- GOTO 202
- +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 ;only if DD audit is on
- DO IJ^DIUTL(B0)
- IF $GET(^DD(J(0),0,"DDA"))'["Y"
- QUIT
- +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
