- DIQ ;SFISC/GFT-CAPTIONED TEMPLATE ;6DEC2009
- ;;22.0;VA FileMan;**19,64,74,81,99,133,163**;Mar 30, 1999;Build 30
- ;Per VHA Directive 2004-038, this routine should not be modified.
- G INQ^DII
- ;
- GET1(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;Extrinsic Function
- ; file,record,field,parm,targetarray,errortargetarray,internal
- I '$D(DIQUIET) N DIQUIET S DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
- G DDENTRY^DIQG
- ;
- GETS(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;Procedure Call
- ; file,record,field,parm,targetarray,errortargetarray,internal
- I '$D(DIQUIET) N DIQUIET S DIQUIET=1
- I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
- N DIQGQERR
- D DDENTRY^DIQGQ
- I $G(DIQGQERR)]"" S DIERR=DIQGQERR
- D:$G(DIQGERRA)]"" CALLOUT^DIEFU(DIQGERRA)
- Q
- ;
- ;
- CAPTION(DD,DA,A,N,E) ;
- ; Newing of Line Counter 'S' needs to be before call
- N D0,DIQ,DIC,DIQS
- S DIQ(0)=$G(A),DIC=^DIC(DD,0,"GL") I $G(DIA),DD=.6!(DD=1.1) S DIC=DIC_DIA_"," ;In DIQ(0), 'A' means AUDIT, 'R' means SHOW RECORD NUMBER
- S E=$S($G(E)="":"N<0",1:"N]]"""_E_"""")
- S N=$S($G(N)="":-1,1:$O(@(DIC_"DA,N)"),-1))
- D R
- S X=""
- Q
- ;
- GUY ;from DII
- N N S N=-1
- R S:'$G(IOM) IOM=80 S:'$G(IOSL) IOSL=24,IOST="C-OTHER"
- S:'$D(DTIME) DTIME=300 K DTOUT,DUOUT,DIRUT,DIR
- N DIQDD,DIQAUDE,DIQAUDD,DIQZ,D,DL,D1,D2,D3,D4,D5,D6,D7,D8,D9,DIQE
- S D0=DA,D=DIC_DA_",",DL=1,DIQDD=DD S:'$G(S) S=3
- I '$D(DIQS) W !
- E D
- .S DIQZ=0,A=0 F S @("DIQZ=$O("_DIQS_"DIQZ))") Q:DIQZ="" S @(DIQS_"DIQZ)=""""")
- D 1(DA)
- G Q
- ;
- 1(DA) ;recursive, for 1 entry or subentry
- N DIQAUD
- I $D(DIQS) D ;old parameter -- undocumented
- .S DIQZ=0,A=0 F S @("DIQZ=$O("_DIQS_"DIQZ))") Q:DIQZ="" D
- ..S A=$O(^DD(DD,"B",DIQZ,0)) Q:'A
- ..I $D(^DD(DD,A,0)) S C=$P(^(0),U,2) I C["C" D COM S @(DIQS_"DIQZ)=X")
- I N<0,$D(^DD(DD,.001,0)) S W=.001,A=-1,Y=@("D"_(DL\2)) D W Q:'S G A
- I $G(DIQ(0))["R",DL=1 S W=.001,A=-1,O="NUMBER",Y=D0 D W2 Q:'S
- A I DIQ(0)["A" D ;Get AUDIT TRAIL data
- .N Z,D,SUB
- .I DL=1 S DIQAUDD="",(DIQAUDE(0),DIQAUDE)=D0 F Z=2:2 Q:'$D(^DD(DIQDD,0,"UP")) D
- ..S A=DIQDD,DIQDD=^("UP"),(DIQAUDE,DIQAUDE(0))=$P(DIC,",",$L(DIC,",")-Z)_","_DIQAUDE,(DIQAUDD(0),DIQAUDD)=$O(^DD(DIQDD,"SB",A,0))_","_DIQAUDD
- .E S DIQAUDD=$G(DIQAUDD(0)),DIQAUDE=DIQAUDE(0) F A=3:2:DL S DIQAUDE=DIQAUDE_","_(@("D"_(A\2))),DIQAUDD=DIQAUDD_DIQAUDD(A-1)_","
- .F Z=0:0 S Z=$O(^DIA(DIQDD,"B",DIQAUDE,Z)) Q:'Z D
- ..S D=$P($G(^DIA(DIQDD,Z,0)),U,3) Q:'D ;get field number
- ..I DIQAUDD]"" S D=$P(D,DIQAUDD,2,9)
- ..E I E["]]"!(N]]0) S SUB=$P($P($G(^DD(DIQDD,+D,0)),U,4),";") D
- ...I N]]SUB S D=0 Q
- ...N N S N=SUB I @E S D=0 Q
- ..I D,D'["," S DIQAUD(D,Z)="" Q
- N S @("N=$O("_D_"N))") I N="" S N=-1 G END:DL#2,MISSAUD
- I DL=1,@E G END
- S DIQZ=$G(^(N)) I DIQZ]"" S A="" F S A=$O(^DD(DD,"GL",N,A)) G N:A="" D G Q:'S ;write out what's on one data node
- .S W=$O(^(A,0)) Q:'W I A S Y=$P(DIQZ,U,A) Q:Y=""
- .E S Y=$E(DIQZ,+$E(A,2,9),$P(A,",",2)) Q:Y?." "
- .D W
- I DL#2 S DIQZ=$O(^DD(DD,"GL",N,0,0)) G N:DIQZ="" S O=0,X=+$P(^DD(DD,DIQZ,0),U,2) X:$D(DICS) DICS E G N
- E G MISSAUD:N'>0 S X=DD,O=-1,@("D"_(DL\2)_"=N") Q:$$STOP I $D(DSC(X)) X DSC(X) E G N ;we've found a new sub-entry
- S DD(DL)=DD,D(DL)=D,N(DL)=N,DL=DL+1,DIQAUDD(DL)=DIQZ S:+N'=N N=""""_N_"""" S D=D_N_",",N=O,DD=X ;down a level
- FIND1 I DL#2=0 S N=0 N DIQAUDR K:$G(DIQAUDE) @("DIQE("_DIQAUDE_")") G N ;let's look for the 1st multiple
- WP I '$D(DIQS),$P(^DD(DD,.01,0),U,2)["W" S O=$P(^(0),U),C=$P(^(0),U,2) D S DL=DL-1 G UP:S Q
- .N DIWF,DIWL,DIWR,DN,N,DD ;Word-processing field
- .D DIQ^DIWW I $D(DN),'DN S S=0
- S N=-1 D 1(DA) Q:'S
- UP S DL=DL-1,D=D(DL),DD=DD(DL),N=N(DL) Q:$$STOP G N ;go back UP a level
- ;
- MISSAUD I $G(DIQAUDE) S DIQE=DIQAUDE(0)_"," F S DIQE=$O(^DIA(DIQDD,"B",DIQE)) Q:'DIQE Q:DIQE-DIQAUDE Q:$$STOP I '$D(@("DIQE("_DIQE_")")) D ;SHOW MISSING ENTRIES THAT WERE CAPTURED BY AUDIT TRAIL
- .N E,DIQEMISS
- .S E="" F S E=$O(^DIA(DIQDD,"B",DIQE,E),-1) Q:'E Q:$$STOP I $P($G(^DIA(DIQDD,E,0)),U,3)=(DIQAUDD(DL)_",.01") D:'$G(DIQEMISS) D WRITEAUD
- ..D WRITE($P(^DD(DD,.01,0),U)_":") W ! S DIQEMISS=1 ;Write the label of the missing multiple
- G UP
- ;
- ;
- END Q:$$STOP
- F DIQZ=0:0 S DIQZ=$O(DIQAUD(DIQZ)) Q:'DIQZ I $D(^DD(DD,DIQZ,0)) D ;write out audited DELETED fields
- .N D W ?2,$P(^(0),U),":" I $P(^(0),U,2) Q
- .D PRINTAUD(DIQZ) Q:$$STOP
- I S,$G(DIQ(0))["C",$D(@(D_"0)")) D ^DIQ1 ;Computed fields at this level -- ONLY IF ENTRY EXISTS
- Q
- ;
- W S O=$P(^DD(DD,W,0),U),C=$P(^(0),U,2) I $D(DICS) X DICS E Q
- D Y
- I $D(DIQS) S:$D(@(DIQS_"O)")) @(DIQS_"O)=Y") S:$D(^(W)) @(DIQS_"W)=Y") Q
- W2 ;from DIQ1
- N DIQX
- S O=$E(O,1,253-$L(Y))_": "_Y
- D I $L(O)+DIQX>IOM!$D(DIQAUD(W)) Q:$$STOP D
- .S DIQX=$S($X:$X+1\40+1*40,W=.01!(W=.001):0,1:2)
- W ?DIQX
- D WRITE(O) D:$D(DIQAUD(W)) PRINTAUD(W) Q
- ;
- PRINTAUD(FLD) N E
- S E="" F S E=$O(DIQAUD(FLD,E),-1) Q:'E Q:$$STOP D WRITEAUD
- K DIQAUD(FLD) S @("DIQE("_DIQAUDE_")")=""
- D LF Q
- ;
- WRITEAUD N O,Z,W,N ;WRITE AN ENTRY FROM THE AUDIT TRAIL
- S O=$G(^DIA(DIQDD,E,2)),N=$G(^(3))
- I N="" S W="Deleted """_O_""""
- E S W=$S(O]"":"Changed from """_O_"""",1:"Created")
- I $D(^DIA(DIQDD,E,0)) S:$P(^(0),U,6)="i" W="Accessed" S Z=$P(^(0),U,4),W=W_" on "_$$FMTE^DILIBF($P(^(0),U,2),"IL") I Z]"" S W=W_" by User #"_Z
- W ?4 D WRITE(W)
- K W S Z=$G(^DIA(DIQDD,E,4.1)),O=$P(Z,U),Z=$P(Z,U,2) I O,$D(^DIC(19,O,0)) S W=" ("_$P(^(0),U)_" Option)"
- I Z S O=+Z,Z=$P(Z,";",2) I Z]"",$D(@(U_Z_O_",0)")) S W=" ("_$P(^(0),U)_" Protocol)"
- I $D(W) D:$X+$L(W)>79 LF Q:'S W ?(79-$L(W)),W
- Q
- ;
- WRITE(DIQW) N DIQWL
- F S DIQWL=IOM-$X W $E(DIQW,1,DIQWL) S DIQW=$E(DIQW,DIQWL+1,999) Q:DIQW="" Q:$$STOP
- Q
- ;
- Y ;PRINT TEMPLATES CALL HERE NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
- I $G(Y)="" S Y="" Q
- I C["O",$D(^(2)) X ^(2) Q
- S I C["S" S C=";"_$P(^(0),U,3),%=$F(C,";"_Y_":") S:% Y=$P($E(C,%,999),";",1) Q
- I C["P",$D(@("^"_$P(^(0),U,3)_"0)")) S C=$P(^(0),U,2) Q:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
- I C["V",+Y,Y["(",$D(@("^"_$P(Y,";",2)_"0)")) S C=$P(^(0),U,2) Q:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
- Q:C'["D" Q:'Y
- D S Y=$$FMTE^DILIBF(Y,"1U") Q
- ;
- DT D D:Y W Y Q
- H G H^DIO2
- ;
- STOP() D LF Q 'S
- LF I '$D(DIQS),$X W ! S S=S+1
- I '$D(DIOT(2)),$G(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL D
- .I '$D(DX(0)),$G(IOST)?1"C".E D:S>(IOSL-3) Q
- ..N X,Y,DIR S DIR(0)="E" D ^DIR W ! S S='$D(DIRUT)
- .I $G(^UTILITY($J,1))?1U1P1E.E D S:Y=U!($D(DTOUT))!($D(DUOUT)) S=0
- ..N S X ^(1)
- .S $Y=0
- Q
- ;
- EN1 S DRX=DR
- EN2 S DR=$P(DRX,";",1),DRX=$P(DRX,";",2,999) D EN W ! G EN2:DRX]""&S
- K DRX Q
- EN ;
- N C,O,W,N,E,Z,D,DD S S=0 S:$D(DICSS) DICS=DICSS
- I '$D(IOST)!'$D(IOSL)!'$D(IOM) S IOP="HOME" D ^%ZIS Q:POP S:'$G(IOM) IOM=80
- G Q:'$D(@(DIC_"0)")) S U="^",DD=+$P(^(0),U,2),DK=DD
- I '$D(DR) S N=-1,O=""
- E S N=$P(DR,":"),N=$S(0[N:-1,+N=N:N-.000001,1:$E(N,1,$L(N)-1)_$C($A(N,$L(N))-1)),O=$P(DR,":",DR[":"+1) G EN1:DR[";"
- S E="N<0" I O]"" S E=E_"!(N]"""_$S(+O=O:"?"")!(N>"_O_")",1:O_""")")
- I '$D(DIQ(0)) N DIQ S DIQ(0)=""
- D R S DA=D0
- Q K C,O,W,N,E,Z,D,DD,IOP Q
- ;
- COM X $P(^(0),U,5,99) S C=$P($P(C,"J",2),",",2) I C?1N.E,X S X=$J(X,0,C)
- DIQ ;SFISC/GFT-CAPTIONED TEMPLATE ;6DEC2009
- +1 ;;22.0;VA FileMan;**19,64,74,81,99,133,163**;Mar 30, 1999;Build 30
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 GOTO INQ^DII
- +4 ;
- GET1(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;Extrinsic Function
- +1 ; file,record,field,parm,targetarray,errortargetarray,internal
- +2 IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- +3 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +4 GOTO DDENTRY^DIQG
- +5 ;
- GETS(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;Procedure Call
- +1 ; file,record,field,parm,targetarray,errortargetarray,internal
- +2 IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- +3 IF '$DATA(DIFM)
- NEW DIFM
- SET DIFM=1
- DO INIZE^DIEFU
- +4 NEW DIQGQERR
- +5 DO DDENTRY^DIQGQ
- +6 IF $GET(DIQGQERR)]""
- SET DIERR=DIQGQERR
- +7 IF $GET(DIQGERRA)]""
- DO CALLOUT^DIEFU(DIQGERRA)
- +8 QUIT
- +9 ;
- +10 ;
- CAPTION(DD,DA,A,N,E) ;
- +1 ; Newing of Line Counter 'S' needs to be before call
- +2 NEW D0,DIQ,DIC,DIQS
- +3 ;In DIQ(0), 'A' means AUDIT, 'R' means SHOW RECORD NUMBER
- SET DIQ(0)=$GET(A)
- SET DIC=^DIC(DD,0,"GL")
- IF $GET(DIA)
- IF DD=.6!(DD=1.1)
- SET DIC=DIC_DIA_","
- +4 SET E=$SELECT($GET(E)="":"N<0",1:"N]]"""_E_"""")
- +5 SET N=$SELECT($GET(N)="":-1,1:$ORDER(@(DIC_"DA,N)"),-1))
- +6 DO R
- +7 SET X=""
- +8 QUIT
- +9 ;
- GUY ;from DII
- +1 NEW N
- SET N=-1
- R IF '$GET(IOM)
- SET IOM=80
- IF '$GET(IOSL)
- SET IOSL=24
- SET IOST="C-OTHER"
- +1 IF '$DATA(DTIME)
- SET DTIME=300
- KILL DTOUT,DUOUT,DIRUT,DIR
- +2 NEW DIQDD,DIQAUDE,DIQAUDD,DIQZ,D,DL,D1,D2,D3,D4,D5,D6,D7,D8,D9,DIQE
- +3 SET D0=DA
- SET D=DIC_DA_","
- SET DL=1
- SET DIQDD=DD
- IF '$GET(S)
- SET S=3
- +4 IF '$DATA(DIQS)
- WRITE !
- +5 IF '$TEST
- Begin DoDot:1
- +6 SET DIQZ=0
- SET A=0
- FOR
- SET @("DIQZ=$O("_DIQS_"DIQZ))")
- IF DIQZ=""
- QUIT
- SET @(DIQS_"DIQZ)=""""")
- End DoDot:1
- +7 DO 1(DA)
- +8 GOTO Q
- +9 ;
- 1(DA) ;recursive, for 1 entry or subentry
- +1 NEW DIQAUD
- +2 ;old parameter -- undocumented
- IF $DATA(DIQS)
- Begin DoDot:1
- +3 SET DIQZ=0
- SET A=0
- FOR
- SET @("DIQZ=$O("_DIQS_"DIQZ))")
- IF DIQZ=""
- QUIT
- Begin DoDot:2
- +4 SET A=$ORDER(^DD(DD,"B",DIQZ,0))
- IF 'A
- QUIT
- +5 IF $DATA(^DD(DD,A,0))
- SET C=$PIECE(^(0),U,2)
- IF C["C"
- DO COM
- SET @(DIQS_"DIQZ)=X")
- End DoDot:2
- End DoDot:1
- +6 IF N<0
- IF $DATA(^DD(DD,.001,0))
- SET W=.001
- SET A=-1
- SET Y=@("D"_(DL\2))
- DO W
- IF 'S
- QUIT
- GOTO A
- +7 IF $GET(DIQ(0))["R"
- IF DL=1
- SET W=.001
- SET A=-1
- SET O="NUMBER"
- SET Y=D0
- DO W2
- IF 'S
- QUIT
- A ;Get AUDIT TRAIL data
- IF DIQ(0)["A"
- Begin DoDot:1
- +1 NEW Z,D,SUB
- +2 IF DL=1
- SET DIQAUDD=""
- SET (DIQAUDE(0),DIQAUDE)=D0
- FOR Z=2:2
- IF '$DATA(^DD(DIQDD,0,"UP"))
- QUIT
- Begin DoDot:2
- +3 SET A=DIQDD
- SET DIQDD=^("UP")
- SET (DIQAUDE,DIQAUDE(0))=$PIECE(DIC,",",$LENGTH(DIC,",")-Z)_","_DIQAUDE
- SET (DIQAUDD(0),DIQAUDD)=$ORDER(^DD(DIQDD,"SB",A,0))_","_DIQAUDD
- End DoDot:2
- +4 IF '$TEST
- SET DIQAUDD=$GET(DIQAUDD(0))
- SET DIQAUDE=DIQAUDE(0)
- FOR A=3:2:DL
- SET DIQAUDE=DIQAUDE_","_(@("D"_(A\2)))
- SET DIQAUDD=DIQAUDD_DIQAUDD(A-1)_","
- +5 FOR Z=0:0
- SET Z=$ORDER(^DIA(DIQDD,"B",DIQAUDE,Z))
- IF 'Z
- QUIT
- Begin DoDot:2
- +6 ;get field number
- SET D=$PIECE($GET(^DIA(DIQDD,Z,0)),U,3)
- IF 'D
- QUIT
- +7 IF DIQAUDD]""
- SET D=$PIECE(D,DIQAUDD,2,9)
- +8 IF '$TEST
- IF E["]]"!(N]]0)
- SET SUB=$PIECE($PIECE($GET(^DD(DIQDD,+D,0)),U,4),";")
- Begin DoDot:3
- +9 IF N]]SUB
- SET D=0
- QUIT
- +10 NEW N
- SET N=SUB
- IF @E
- SET D=0
- QUIT
- End DoDot:3
- +11 IF D
- IF D'[","
- SET DIQAUD(D,Z)=""
- QUIT
- End DoDot:2
- End DoDot:1
- N SET @("N=$O("_D_"N))")
- IF N=""
- SET N=-1
- IF DL#2
- GOTO END
- GOTO MISSAUD
- +1 IF DL=1
- IF @E
- GOTO END
- +2 ;write out what's on one data node
- SET DIQZ=$GET(^(N))
- IF DIQZ]""
- SET A=""
- FOR
- SET A=$ORDER(^DD(DD,"GL",N,A))
- IF A=""
- GOTO N
- Begin DoDot:1
- +3 SET W=$ORDER(^(A,0))
- IF 'W
- QUIT
- IF A
- SET Y=$PIECE(DIQZ,U,A)
- IF Y=""
- QUIT
- +4 IF '$TEST
- SET Y=$EXTRACT(DIQZ,+$EXTRACT(A,2,9),$PIECE(A,",",2))
- IF Y?." "
- QUIT
- +5 DO W
- End DoDot:1
- IF 'S
- GOTO Q
- +6 IF DL#2
- SET DIQZ=$ORDER(^DD(DD,"GL",N,0,0))
- IF DIQZ=""
- GOTO N
- SET O=0
- SET X=+$PIECE(^DD(DD,DIQZ,0),U,2)
- IF $DATA(DICS)
- XECUTE DICS
- IF '$TEST
- GOTO N
- +7 ;we've found a new sub-entry
- IF '$TEST
- IF N'>0
- GOTO MISSAUD
- SET X=DD
- SET O=-1
- SET @("D"_(DL\2)_"=N")
- IF $$STOP
- QUIT
- IF $DATA(DSC(X))
- XECUTE DSC(X)
- IF '$TEST
- GOTO N
- +8 ;down a level
- SET DD(DL)=DD
- SET D(DL)=D
- SET N(DL)=N
- SET DL=DL+1
- SET DIQAUDD(DL)=DIQZ
- IF +N'=N
- SET N=""""_N_""""
- SET D=D_N_","
- SET N=O
- SET DD=X
- FIND1 ;let's look for the 1st multiple
- IF DL#2=0
- SET N=0
- NEW DIQAUDR
- IF $GET(DIQAUDE)
- KILL @("DIQE("_DIQAUDE_")")
- GOTO N
- WP IF '$DATA(DIQS)
- IF $PIECE(^DD(DD,.01,0),U,2)["W"
- SET O=$PIECE(^(0),U)
- SET C=$PIECE(^(0),U,2)
- Begin DoDot:1
- +1 ;Word-processing field
- NEW DIWF,DIWL,DIWR,DN,N,DD
- +2 DO DIQ^DIWW
- IF $DATA(DN)
- IF 'DN
- SET S=0
- End DoDot:1
- SET DL=DL-1
- IF S
- GOTO UP
- QUIT
- +3 SET N=-1
- DO 1(DA)
- IF 'S
- QUIT
- UP ;go back UP a level
- SET DL=DL-1
- SET D=D(DL)
- SET DD=DD(DL)
- SET N=N(DL)
- IF $$STOP
- QUIT
- GOTO N
- +1 ;
- MISSAUD ;SHOW MISSING ENTRIES THAT WERE CAPTURED BY AUDIT TRAIL
- IF $GET(DIQAUDE)
- SET DIQE=DIQAUDE(0)_","
- FOR
- SET DIQE=$ORDER(^DIA(DIQDD,"B",DIQE))
- IF 'DIQE
- QUIT
- IF DIQE-DIQAUDE
- QUIT
- IF $$STOP
- QUIT
- IF '$DATA(@("DIQE("_DIQE_")"))
- Begin DoDot:1
- +1 NEW E,DIQEMISS
- +2 SET E=""
- FOR
- SET E=$ORDER(^DIA(DIQDD,"B",DIQE,E),-1)
- IF 'E
- QUIT
- IF $$STOP
- QUIT
- IF $PIECE($GET(^DIA(DIQDD,E,0)),U,3)=(DIQAUDD(DL)_",.01")
- IF '$GET(DIQEMISS)
- Begin DoDot:2
- +3 ;Write the label of the missing multiple
- DO WRITE($PIECE(^DD(DD,.01,0),U)_":")
- WRITE !
- SET DIQEMISS=1
- End DoDot:2
- DO WRITEAUD
- End DoDot:1
- +4 GOTO UP
- +5 ;
- +6 ;
- END IF $$STOP
- QUIT
- +1 ;write out audited DELETED fields
- FOR DIQZ=0:0
- SET DIQZ=$ORDER(DIQAUD(DIQZ))
- IF 'DIQZ
- QUIT
- IF $DATA(^DD(DD,DIQZ,0))
- Begin DoDot:1
- +2 NEW D
- WRITE ?2,$PIECE(^(0),U),":"
- IF $PIECE(^(0),U,2)
- QUIT
- +3 DO PRINTAUD(DIQZ)
- IF $$STOP
- QUIT
- End DoDot:1
- +4 ;Computed fields at this level -- ONLY IF ENTRY EXISTS
- IF S
- IF $GET(DIQ(0))["C"
- IF $DATA(@(D_"0)"))
- DO ^DIQ1
- +5 QUIT
- +6 ;
- W SET O=$PIECE(^DD(DD,W,0),U)
- SET C=$PIECE(^(0),U,2)
- IF $DATA(DICS)
- XECUTE DICS
- IF '$TEST
- QUIT
- +1 DO Y
- +2 IF $DATA(DIQS)
- IF $DATA(@(DIQS_"O)"))
- SET @(DIQS_"O)=Y")
- IF $DATA(^(W))
- SET @(DIQS_"W)=Y")
- QUIT
- W2 ;from DIQ1
- +1 NEW DIQX
- +2 SET O=$EXTRACT(O,1,253-$LENGTH(Y))_": "_Y
- +3 Begin DoDot:1
- +4 SET DIQX=$SELECT($X:$X+1\40+1*40,W=.01!(W=.001):0,1:2)
- End DoDot:1
- IF $LENGTH(O)+DIQX>IOM!$DATA(DIQAUD(W))
- IF $$STOP
- QUIT
- Begin DoDot:1
- End DoDot:1
- +5 WRITE ?DIQX
- +6 DO WRITE(O)
- IF $DATA(DIQAUD(W))
- DO PRINTAUD(W)
- QUIT
- +7 ;
- PRINTAUD(FLD) NEW E
- +1 SET E=""
- FOR
- SET E=$ORDER(DIQAUD(FLD,E),-1)
- IF 'E
- QUIT
- IF $$STOP
- QUIT
- DO WRITEAUD
- +2 KILL DIQAUD(FLD)
- SET @("DIQE("_DIQAUDE_")")=""
- +3 DO LF
- QUIT
- +4 ;
- WRITEAUD ;WRITE AN ENTRY FROM THE AUDIT TRAIL
- NEW O,Z,W,N
- +1 SET O=$GET(^DIA(DIQDD,E,2))
- SET N=$GET(^(3))
- +2 IF N=""
- SET W="Deleted """_O_""""
- +3 IF '$TEST
- SET W=$SELECT(O]"":"Changed from """_O_"""",1:"Created")
- +4 IF $DATA(^DIA(DIQDD,E,0))
- IF $PIECE(^(0),U,6)="i"
- SET W="Accessed"
- SET Z=$PIECE(^(0),U,4)
- SET W=W_" on "_$$FMTE^DILIBF($PIECE(^(0),U,2),"IL")
- IF Z]""
- SET W=W_" by User #"_Z
- +5 WRITE ?4
- DO WRITE(W)
- +6 KILL W
- SET Z=$GET(^DIA(DIQDD,E,4.1))
- SET O=$PIECE(Z,U)
- SET Z=$PIECE(Z,U,2)
- IF O
- IF $DATA(^DIC(19,O,0))
- SET W=" ("_$PIECE(^(0),U)_" Option)"
- +7 IF Z
- SET O=+Z
- SET Z=$PIECE(Z,";",2)
- IF Z]""
- IF $DATA(@(U_Z_O_",0)"))
- SET W=" ("_$PIECE(^(0),U)_" Protocol)"
- +8 IF $DATA(W)
- IF $X+$LENGTH(W)>79
- DO LF
- IF 'S
- QUIT
- WRITE ?(79-$LENGTH(W)),W
- +9 QUIT
- +10 ;
- WRITE(DIQW) NEW DIQWL
- +1 FOR
- SET DIQWL=IOM-$X
- WRITE $EXTRACT(DIQW,1,DIQWL)
- SET DIQW=$EXTRACT(DIQW,DIQWL+1,999)
- IF DIQW=""
- QUIT
- IF $$STOP
- QUIT
- +2 QUIT
- +3 ;
- Y ;PRINT TEMPLATES CALL HERE NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
- +1 IF $GET(Y)=""
- SET Y=""
- QUIT
- +2 IF C["O"
- IF $DATA(^(2))
- XECUTE ^(2)
- QUIT
- S IF C["S"
- SET C=";"_$PIECE(^(0),U,3)
- SET %=$FIND(C,";"_Y_":")
- IF %
- SET Y=$PIECE($EXTRACT(C,%,999),";",1)
- QUIT
- +1 IF C["P"
- IF $DATA(@("^"_$PIECE(^(0),U,3)_"0)"))
- SET C=$PIECE(^(0),U,2)
- IF '$DATA(^(+Y,0))
- QUIT
- SET Y=$PIECE(^(0),U)
- IF $DATA(^DD(+C,.01,0))
- SET C=$PIECE(^(0),U,2)
- GOTO S
- +2 IF C["V"
- IF +Y
- IF Y["("
- IF $DATA(@("^"_$PIECE(Y,";",2)_"0)"))
- SET C=$PIECE(^(0),U,2)
- IF '$DATA(^(+Y,0))
- QUIT
- SET Y=$PIECE(^(0),U)
- IF $DATA(^DD(+C,.01,0))
- SET C=$PIECE(^(0),U,2)
- GOTO S
- +3 IF C'["D"
- QUIT
- IF 'Y
- QUIT
- D SET Y=$$FMTE^DILIBF(Y,"1U")
- QUIT
- +1 ;
- DT IF Y
- DO D
- WRITE Y
- QUIT
- H GOTO H^DIO2
- +1 ;
- STOP() DO LF
- QUIT 'S
- LF IF '$DATA(DIQS)
- IF $X
- WRITE !
- SET S=S+1
- +1 IF '$DATA(DIOT(2))
- IF $GET(IOSL)
- IF $SELECT('$DATA(DIWF):1,$PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:1)+$Y'<IOSL
- Begin DoDot:1
- +2 IF '$DATA(DX(0))
- IF $GET(IOST)?1"C".E
- IF S>(IOSL-3)
- Begin DoDot:2
- +3 NEW X,Y,DIR
- SET DIR(0)="E"
- DO ^DIR
- WRITE !
- SET S='$DATA(DIRUT)
- End DoDot:2
- QUIT
- +4 IF $GET(^UTILITY($JOB,1))?1U1P1E.E
- Begin DoDot:2
- +5 NEW S
- XECUTE ^(1)
- End DoDot:2
- IF Y=U!($DATA(DTOUT))!($DATA(DUOUT))
- SET S=0
- +6 SET $Y=0
- End DoDot:1
- +7 QUIT
- +8 ;
- EN1 SET DRX=DR
- EN2 SET DR=$PIECE(DRX,";",1)
- SET DRX=$PIECE(DRX,";",2,999)
- DO EN
- WRITE !
- IF DRX]""&S
- GOTO EN2
- +1 KILL DRX
- QUIT
- EN ;
- +1 NEW C,O,W,N,E,Z,D,DD
- SET S=0
- IF $DATA(DICSS)
- SET DICS=DICSS
- +2 IF '$DATA(IOST)!'$DATA(IOSL)!'$DATA(IOM)
- SET IOP="HOME"
- DO ^%ZIS
- IF POP
- QUIT
- IF '$GET(IOM)
- SET IOM=80
- +3 IF '$DATA(@(DIC_"0)"))
- GOTO Q
- SET U="^"
- SET DD=+$PIECE(^(0),U,2)
- SET DK=DD
- +4 IF '$DATA(DR)
- SET N=-1
- SET O=""
- +5 IF '$TEST
- SET N=$PIECE(DR,":")
- SET N=$SELECT(0[N:-1,+N=N:N-.000001,1:$EXTRACT(N,1,$LENGTH(N)-1)_$CHAR($ASCII(N,$LENGTH(N))-1))
- SET O=$PIECE(DR,":",DR[":"+1)
- IF DR[";"
- GOTO EN1
- +6 SET E="N<0"
- IF O]""
- SET E=E_"!(N]"""_$SELECT(+O=O:"?"")!(N>"_O_")",1:O_""")")
- +7 IF '$DATA(DIQ(0))
- NEW DIQ
- SET DIQ(0)=""
- +8 DO R
- SET DA=D0
- Q KILL C,O,W,N,E,Z,D,DD,IOP
- QUIT
- +1 ;
- COM XECUTE $PIECE(^(0),U,5,99)
- SET C=$PIECE($PIECE(C,"J",2),",",2)
- IF C?1N.E
- IF X
- SET X=$JUSTIFY(X,0,C)