DIQ ;SFISC/GFT - CAPTIONED TEMPLATE ;28NOV2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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;;**19,64,74,81,99,129,133,999,1021,1035,1037,1053,1054**;
;
;
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
NUMBER I $G(DIQ(0))["R",DL=1 S W=.001,A=-1,O=$$EZBLD^DIALOG(7099),Y=D0 D W2 Q:'S ;**CCO/NI THE WORD 'NUMBER'
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=$$LABEL^DIALOGZ(DD,.01),C=$P(^DD(DD,.01,0),U,2) D S DL=DL-1 D WPAUD($G(DIQAUDD(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($$LABEL^DIALOGZ(DD,.01)_":") W ! S DIQEMISS=1 ;Write the label of the missing multiple
G UP
;
;
WPAUD(FLD,DIQCHNGD) N DIWF,DIWL,DIWR,E,O,Z,W,N ;DIQCHNGD=0 means FLD is currently deleted.
Q:'$G(FLD)
S E="",DIWF=$E("N",C["L")_"W|",DIWL=7,DIWR=IOM
F S E=$O(DIQAUD(FLD,E),-1) Q:'E Q:$$STOP D
.S W=""
.I $D(^DIA(DIQDD,E,0)) S Z=$P(^(0),U,4),W=W_" on "_$$FMTE^DILIBF($P(^(0),U,2),"IL") I Z]"" S W=W_" by User #"_Z
.S Z=$G(^(4.1)),O=$P(Z,U),Z=$P(Z,U,2) I O,$D(^DIC(19,O,0)) S W=W_" ("_$P(^(0),U)_" Option)"
.I Z S O=+Z,Z=$P(Z,";",2) I Z]"",$D(@(U_Z_O_",0)")) S W=W_" ("_$P(^(0),U)_" Protocol)"
.S X=$O(^DIA(DIQDD,E,2.14,0)) ;Do we have old text stored for this audited event?
.I 'DIQCHNGD,X S W=$TR($$EZBLD^DIALOG(8197.1),"""")_W_":" S DIQCHNGD=1 ;'DELETED'
.E I X S W="Changed"_W_" from:" S DIQCHNGD=1
.E S W=$$EZBLD^DIALOG(8197.3)_W S DIQCHNGD=0 ;'CREATED'
.W ?4 D WRITE(W)
.S W=0,X="" F D S W=$O(^DIA(DIQDD,E,2.14,W)) Q:W'>0!(S=0) S X=^(W,0) D ^DIWP D
..N W D LF
.D ^DIWW
K DIQAUD(FLD)
D LF Q
;
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) D WPAUD(DIQZ,0) 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=$$LABEL^DIALOGZ(DD,W),C=$P(^DD(DD,W,0),U,2) I $D(DICS) X DICS E Q
VP I C["V" D I $D(^DD(DD,W,0)) ;get naked back
.N F S F=$P(Y,";",2) I F["(",$D(@("^"_F_"0)"))#2 S F=+$P(^(0),U,2) I F S F=$O(^DD(DD,W,"V","B",F,0)) I F,$D(^DD(DD,W,"V",F,0)) S O=O_" ("_$P(^(0),U,4)_")"
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=$$EZBLD^DIALOG(8197.1,O) ;**CCO/NI 'DELETED'
E S W=$S(O]"":$$EZBLD^DIALOG(8197.2,O),1:$$EZBLD^DIALOG(8197.3)) ;**CCO/NI 'CHANGED FROM' OR 'CREATED'
I $D(^DIA(DIQDD,E,0)) S:$P(^(0),U,6)="i" W=$$EZBLD^DIALOG(8197.5) K Z S Z(3)=$P(^(0),U,4),Z(2)=$$DATE^DIUTL($P(^(0),U,2)),Z(1)=W,W=$$EZBLD^DIALOG(8197.4,.Z) ;**'ACCESSED'; CCO/NI WHEN, WHO
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
TYPE I C["t" X $$OUTPUT^DIETLIBF Q ;DATA TYPE IS IN FILE .81!
I C["O",$D(^(2)) X ^(2) Q
S I C["S" D PARSET($$LANGSET,.Y) 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=$$NAKED^DIUTL("$$DATE^DIUTL(Y)") Q ;GENERAL DATE OUTPUT --NEEDS TO PRESERVE THE NAKED INDICATOR
;
;
;
SET(FILE,FIELD,Y) ;GET EXTERNAL VERSION OF 'Y' FOR A SET FIELD
I $D(^DD(FILE,FIELD,0)) D PARSET($$LANGSET,.Y)
Q Y
;
PARSET(C,Y) ;FOR SPECIFIER C, CHANGE Y TO ITS EXTERNAL VALUE called from DIDU & DDS11
N DIN,%
S DIN=Y,C=";"_C,%=$F(C,";"_Y_":") I % S Y=$P($E(C,%,999),";")
Q
;
LANGSET() ;USES NAKED REFERENCE TO ^DD(FILE,FIELD,0)
N C S C=$P(^(0),U,3)
I $G(DUZ("LANG"))>1 Q $$NAKED^DIUTL("$$SETOUT^DIALOGZ")
Q C
;
;
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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQ 9364 printed Sep 23, 2025@20:29:39 Page 2
DIQ ;SFISC/GFT - CAPTIONED TEMPLATE ;28NOV2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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;;**19,64,74,81,99,129,133,999,1021,1035,1037,1053,1054**;
+7 ;
+8 ;
+9 GOTO INQ^DII
+10 ;
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
NUMBER ;**CCO/NI THE WORD 'NUMBER'
IF $GET(DIQ(0))["R"
IF DL=1
SET W=.001
SET A=-1
SET O=$$EZBLD^DIALOG(7099)
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=$$LABEL^DIALOGZ(DD,.01)
SET C=$PIECE(^DD(DD,.01,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
DO WPAUD($GET(DIQAUDD(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($$LABEL^DIALOGZ(DD,.01)_":")
WRITE !
SET DIQEMISS=1
End DoDot:2
DO WRITEAUD
End DoDot:1
+4 GOTO UP
+5 ;
+6 ;
WPAUD(FLD,DIQCHNGD) ;DIQCHNGD=0 means FLD is currently deleted.
NEW DIWF,DIWL,DIWR,E,O,Z,W,N
+1 if '$GET(FLD)
QUIT
+2 SET E=""
SET DIWF=$EXTRACT("N",C["L")_"W|"
SET DIWL=7
SET DIWR=IOM
+3 FOR
SET E=$ORDER(DIQAUD(FLD,E),-1)
if 'E
QUIT
if $$STOP
QUIT
Begin DoDot:1
+4 SET W=""
+5 IF $DATA(^DIA(DIQDD,E,0))
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
+6 SET Z=$GET(^(4.1))
SET O=$PIECE(Z,U)
SET Z=$PIECE(Z,U,2)
IF O
IF $DATA(^DIC(19,O,0))
SET W=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=W_" ("_$PIECE(^(0),U)_" Protocol)"
+8 ;Do we have old text stored for this audited event?
SET X=$ORDER(^DIA(DIQDD,E,2.14,0))
+9 ;'DELETED'
IF 'DIQCHNGD
IF X
SET W=$TRANSLATE($$EZBLD^DIALOG(8197.1),"""")_W_":"
SET DIQCHNGD=1
+10 IF '$TEST
IF X
SET W="Changed"_W_" from:"
SET DIQCHNGD=1
+11 ;'CREATED'
IF '$TEST
SET W=$$EZBLD^DIALOG(8197.3)_W
SET DIQCHNGD=0
+12 WRITE ?4
DO WRITE(W)
+13 SET W=0
SET X=""
FOR
Begin DoDot:2
+14 NEW W
DO LF
End DoDot:2
SET W=$ORDER(^DIA(DIQDD,E,2.14,W))
if W'>0!(S=0)
QUIT
SET X=^(W,0)
DO ^DIWP
Begin DoDot:2
End DoDot:2
+15 DO ^DIWW
End DoDot:1
+16 KILL DIQAUD(FLD)
+17 DO LF
QUIT
+18 ;
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)
DO WPAUD(DIQZ,0)
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=$$LABEL^DIALOGZ(DD,W)
SET C=$PIECE(^DD(DD,W,0),U,2)
IF $DATA(DICS)
XECUTE DICS
IF '$TEST
QUIT
VP ;get naked back
IF C["V"
Begin DoDot:1
+1 NEW F
SET F=$PIECE(Y,";",2)
IF F["("
IF $DATA(@("^"_F_"0)"))#2
SET F=+$PIECE(^(0),U,2)
IF F
SET F=$ORDER(^DD(DD,W,"V","B",F,0))
IF F
IF $DATA(^DD(DD,W,"V",F,0))
SET O=O_" ("_$PIECE(^(0),U,4)_")"
End DoDot:1
IF $DATA(^DD(DD,W,0))
+2 DO Y
+3 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 ;**CCO/NI 'DELETED'
IF N=""
SET W=$$EZBLD^DIALOG(8197.1,O)
+3 ;**CCO/NI 'CHANGED FROM' OR 'CREATED'
IF '$TEST
SET W=$SELECT(O]"":$$EZBLD^DIALOG(8197.2,O),1:$$EZBLD^DIALOG(8197.3))
+4 ;**'ACCESSED'; CCO/NI WHEN, WHO
IF $DATA(^DIA(DIQDD,E,0))
if $PIECE(^(0),U,6)="i"
SET W=$$EZBLD^DIALOG(8197.5)
KILL Z
SET Z(3)=$PIECE(^(0),U,4)
SET Z(2)=$$DATE^DIUTL($PIECE(^(0),U,2))
SET Z(1)=W
SET W=$$EZBLD^DIALOG(8197.4,.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
TYPE ;DATA TYPE IS IN FILE .81!
IF C["t"
XECUTE $$OUTPUT^DIETLIBF
QUIT
+1 IF C["O"
IF $DATA(^(2))
XECUTE ^(2)
QUIT
S IF C["S"
DO PARSET($$LANGSET,.Y)
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 ;GENERAL DATE OUTPUT --NEEDS TO PRESERVE THE NAKED INDICATOR
SET Y=$$NAKED^DIUTL("$$DATE^DIUTL(Y)")
QUIT
+1 ;
+2 ;
+3 ;
SET(FILE,FIELD,Y) ;GET EXTERNAL VERSION OF 'Y' FOR A SET FIELD
+1 IF $DATA(^DD(FILE,FIELD,0))
DO PARSET($$LANGSET,.Y)
+2 QUIT Y
+3 ;
PARSET(C,Y) ;FOR SPECIFIER C, CHANGE Y TO ITS EXTERNAL VALUE called from DIDU & DDS11
+1 NEW DIN,%
+2 SET DIN=Y
SET C=";"_C
SET %=$FIND(C,";"_Y_":")
IF %
SET Y=$PIECE($EXTRACT(C,%,999),";")
+3 QUIT
+4 ;
LANGSET() ;USES NAKED REFERENCE TO ^DD(FILE,FIELD,0)
+1 NEW C
SET C=$PIECE(^(0),U,3)
+2 IF $GET(DUZ("LANG"))>1
QUIT $$NAKED^DIUTL("$$SETOUT^DIALOGZ")
+3 QUIT C
+4 ;
+5 ;
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)
