DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;6DEC2004
;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
;;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.
;
;From a TRIGGER on field DIH,DIG
;DIU is old value, DIV new
AUDIT I $P(^DD(DIH,DIG,0),U,2)["a" D ;NOIS ISB-1102-31285
.N DIANUM,DIIX,C,DP
.D SAVE ;p14
.I DIU]"" S X=DIU,DIIX=2_U_DIG,DP=DIH D AUDIT^DIET
.I DIV]"",^DD(DIH,DIG,"AUDIT")'="e"!(DIU]"") S X=DIV,DIIX=3_U_DIG,DP=DIH D AUDIT^DIET ;Don't audit NEW if there's no OLD and mode is EDIT ONLY
.D RESTORE ;p14
Q:'$O(^DD(DIH,DIG,1,0))&'$D(^DD("IX","F",DIH,DIG))
N DICRIENS,DICRBADK
I $D(^DD("KEY","F",DIH,DIG)) D Q:$G(DICRBADK)
. N DICRFDA,DICRMSG,DIERR
. D SAVE
. S DICRIENS=$$IENS(DIH,.DA)
. S DICRFDA(DIH,DICRIENS,DIG)=DIV
. I '$$KEYVAL^DIE("","DICRFDA","DICRMSG") D
.. S DICRBADK=1
.. S X=DIU X $$HSET(DIH,DIG)
. D RESTORE
;
I DIU]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIU Q:'DIW I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,2)) S DB(0,DIH,DIG,DIW,2)=1 D SAVE X ^(2) D RESTORE
I DIV]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIV Q:'DIW I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,1)) S DB(0,DIH,DIG,DIW,1)=1 D SAVE X ^(1) D RESTORE
;
I $D(^DD("IX","F",DIH,DIG)) D
. N DICRCTRL,DICRVAL,I
. D SAVE
. S:$D(DICRIENS)[0 DICRIENS=$$IENS(DIH,.DA)
. S DICRVAL(DIH,DICRIENS,DIG,"O")=DIU
. S DICRVAL(DIH,DICRIENS,DIG,"N")=DIV
. S:$G(DICRREC)]"" DICRCTRL="r"
. S DICRCTRL("VAL")="DICRVAL("
. D INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL)
. D:$G(DICRREC)]"" @DICRREC
. D RESTORE
Q Q
;
SAVE F DB=1:1 Q:'$D(DB(DB))
F Y="DIC","DIV","DA" S %="" F DB=DB:0 S @("%=$O("_Y_"(%))") Q:%="" S DB(DB,Y,%)=@(Y_"(%)")
F %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR" S DB(DB,%)="" I $D(@%)#2 S DB(DB,%)=@%
K DA F Y=-1:1 Q:'$D(DIV(Y+1))
I Y+1 S DA=DIV(Y) F %=Y-1:-1:0 S DA(Y-%)=DIV(%)
Q
;
RESTORE F DB=1:1 Q:'$D(DB(DB+1))
F Y="DIC","DIV","DA" K @Y S %="" F DB=DB:0 S %=$O(DB(DB,Y,%)) Q:%="" S @(Y_"(%)=DB(DB,Y,%)")
S Y="" F %=0:0 S Y=$O(DB(DB,Y)) Q:Y="" S @Y=DB(DB,Y)
K DB(DB) K:DB=1 DB Q
;
DICL N I
K DIC("S"),DLAYGO I '$P(Y,U,3) K DIC Q
DICADD ;
S (D0,DIV(0))=+Y,DIV(U)=Y
I DIC S DIH=DIC,DIC=^DIC(DIC,0,"GL")
E S @("DIH=+$P("_DIC_"0),U,2)")
S DICR=$S($D(DA)#2:DA,1:0),DA=D0 F DIG=.001:0 S DIG=$O(DIC(DIG)) Q:DIG'>0 D U:DIC(DIG)]""
S DA=DICR,Y=DIV(U) K DIC Q
;
U S %=$P(^DD(DIH,DIG,0),U,4),Y=$P(%,";",2),%=$P(%,";",1),X="",DIV=DIC(DIG) I @("$D("_DIC_DIV(0)_",%))") S X=^(%)
G P:Y,Q:Y'?1"E"1N.NP S D=+$E(Y,2,9),Y=$P(Y,",",2),DIU=$E(X,D,Y) I DIU?." " S DIU="" S:$L(X)+1<D X=X_$J("",D-1-$L(X))
S ^(%)=$E(X,1,D-1)_DIV_$E(X,Y+1,999)
G DICR
P S DIU=$P(X,U,Y),$P(^(%),U,Y)=DIV
G DICR
CONV ;
K DA F %=0:1 Q:'$D(@("D"_%))
S %=%-1 I '% S DA=D0 K % Q
S DA=@("D"_%),%=%-1,Y=0
F %1=%:-1:0 S Y=Y+1,DA(Y)=@("D"_%1)
K %,%1,Y
Q
SD ;
S DIV(0)=DA D U:DA>0 K DA,DIH,DIG,DIV Q
;
TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields
;in DICRLIST so that they call ^DICR unconditionally.
;In:
; DICRLIST(file#,field#) = array of potentionally triggered fields
;Out:
; DICROUT(file,field)="" (of triggering field modified)
;
N DICRFIL,DICRFLD
S DICRFIL=""
F S DICRFIL=$O(DICRLIST(DICRFIL)) Q:'DICRFIL D
. S DICRFLD=""
. F S DICRFLD=$O(DICRLIST(DICRFIL,DICRFLD)) Q:'DICRFLD D TRMOD(DICRFIL,DICRFLD,.DICROUT)
Q
;
TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that
;trigger a field so that they call ^DICR unconditionally.
;In:
; DICRFIL = file# of triggered field
; DICRFLD = triggered field#
;Out:
; DICROUT(file,field)="" (of triggering field modified)
;
;Loop through 5 node to get triggering fields/xrefs
N DICRN,DICRFL,DICRFD,DICRXR
S DICRN=0
F S DICRN=$O(^DD(DICRFIL,DICRFLD,5,DICRN)) Q:'DICRN D
. S DICRXR=$G(^DD(DICRFIL,DICRFLD,5,DICRN,0))
. S DICRFL=+$P(DICRXR,U),DICRFD=+$P(DICRXR,U,2),DICRXR=+$P(DICRXR,U,3)
. Q:'DICRFL!'DICRFD!'DICRXR
. D MOD(DICRFL,DICRFD,DICRXR,.DICROUT)
Q
;
MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic
;In:
; DICRFL = file# of triggering field
; DICRFD = field# of triggering field
; DICRXR = xref# of trigger
;Out:
; DICROUT(file,field)="" (if trigger was modified)
;
Q:'$D(^DD(DICRFL,DICRFD,1,DICRXR))
N DICRMOD,DICRND,DICRSTR,DICRVAL
;
;Loop through xref nodes
S DICRND=0
F S DICRND=$O(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)) Q:'DICRND D
. S DICRVAL=$G(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)),DICRMOD=0
. F DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0" D
.. F Q:DICRVAL'[DICRSTR D
... S DICRVAL=$P(DICRVAL,DICRSTR)_"D ^DICR"_$P(DICRVAL,DICRSTR,2,999)
... S DICRMOD=1
. Q:'DICRMOD
. S ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL
. S DICROUT(DICRFL,DICRFD)=""
Q
;
IENS(FIL,DA) ;Build IENS
N I,IENS
S IENS=DA_","
F I=1:1:$$FLEV^DIKCU(FIL) S IENS=IENS_DA(I)_","
Q IENS
;
HSET(FIL,FLD) ;Hard set a value in the file
Q:$P($G(^DD(FIL,FLD,0)),U)="" ""
;
N HSET,ND,PC,OROOT
S PC=$P($G(^DD(FIL,FLD,0)),U,4)
S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) ""
S:ND'=+$P(ND,"E") ND=""""_ND_""""
;
S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA,"
I PC S HSET="S $P("_OROOT_ND_"),U,"_PC_")=X"
E S HSET="S $E("_OROOT_ND_"),"_+$E(PC,2,999)_","_$P(PC,",",2)_")=X"
Q HSET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICR 5572 printed Sep 23, 2025@20:22:41 Page 2
DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;6DEC2004
+1 ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
+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 ;From a TRIGGER on field DIH,DIG
+8 ;DIU is old value, DIV new
AUDIT ;NOIS ISB-1102-31285
IF $PIECE(^DD(DIH,DIG,0),U,2)["a"
Begin DoDot:1
+1 NEW DIANUM,DIIX,C,DP
+2 ;p14
DO SAVE
+3 IF DIU]""
SET X=DIU
SET DIIX=2_U_DIG
SET DP=DIH
DO AUDIT^DIET
+4 ;Don't audit NEW if there's no OLD and mode is EDIT ONLY
IF DIV]""
IF ^DD(DIH,DIG,"AUDIT")'="e"!(DIU]"")
SET X=DIV
SET DIIX=3_U_DIG
SET DP=DIH
DO AUDIT^DIET
+5 ;p14
DO RESTORE
End DoDot:1
+6 if '$ORDER(^DD(DIH,DIG,1,0))&'$DATA(^DD("IX","F",DIH,DIG))
QUIT
+7 NEW DICRIENS,DICRBADK
+8 IF $DATA(^DD("KEY","F",DIH,DIG))
Begin DoDot:1
+9 NEW DICRFDA,DICRMSG,DIERR
+10 DO SAVE
+11 SET DICRIENS=$$IENS(DIH,.DA)
+12 SET DICRFDA(DIH,DICRIENS,DIG)=DIV
+13 IF '$$KEYVAL^DIE("","DICRFDA","DICRMSG")
Begin DoDot:2
+14 SET DICRBADK=1
+15 SET X=DIU
XECUTE $$HSET(DIH,DIG)
End DoDot:2
+16 DO RESTORE
End DoDot:1
if $GET(DICRBADK)
QUIT
+17 ;
+18 IF DIU]""
FOR DIW=0:0
SET DIW=$ORDER(^DD(DIH,DIG,1,DIW))
SET X=DIU
if 'DIW
QUIT
IF $PIECE(^(DIW,0),U,3)=""!'$DATA(DB(0,DIH,DIG,DIW,2))
SET DB(0,DIH,DIG,DIW,2)=1
DO SAVE
XECUTE ^(2)
DO RESTORE
+19 IF DIV]""
FOR DIW=0:0
SET DIW=$ORDER(^DD(DIH,DIG,1,DIW))
SET X=DIV
if 'DIW
QUIT
IF $PIECE(^(DIW,0),U,3)=""!'$DATA(DB(0,DIH,DIG,DIW,1))
SET DB(0,DIH,DIG,DIW,1)=1
DO SAVE
XECUTE ^(1)
DO RESTORE
+20 ;
+21 IF $DATA(^DD("IX","F",DIH,DIG))
Begin DoDot:1
+22 NEW DICRCTRL,DICRVAL,I
+23 DO SAVE
+24 if $DATA(DICRIENS)[0
SET DICRIENS=$$IENS(DIH,.DA)
+25 SET DICRVAL(DIH,DICRIENS,DIG,"O")=DIU
+26 SET DICRVAL(DIH,DICRIENS,DIG,"N")=DIV
+27 if $GET(DICRREC)]""
SET DICRCTRL="r"
+28 SET DICRCTRL("VAL")="DICRVAL("
+29 DO INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL)
+30 if $GET(DICRREC)]""
DO @DICRREC
+31 DO RESTORE
End DoDot:1
Q QUIT
+1 ;
SAVE FOR DB=1:1
if '$DATA(DB(DB))
QUIT
+1 FOR Y="DIC","DIV","DA"
SET %=""
FOR DB=DB:0
SET @("%=$O("_Y_"(%))")
if %=""
QUIT
SET DB(DB,Y,%)=@(Y_"(%)")
+2 FOR %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR"
SET DB(DB,%)=""
IF $DATA(@%)#2
SET DB(DB,%)=@%
+3 KILL DA
FOR Y=-1:1
if '$DATA(DIV(Y+1))
QUIT
+4 IF Y+1
SET DA=DIV(Y)
FOR %=Y-1:-1:0
SET DA(Y-%)=DIV(%)
+5 QUIT
+6 ;
RESTORE FOR DB=1:1
if '$DATA(DB(DB+1))
QUIT
+1 FOR Y="DIC","DIV","DA"
KILL @Y
SET %=""
FOR DB=DB:0
SET %=$ORDER(DB(DB,Y,%))
if %=""
QUIT
SET @(Y_"(%)=DB(DB,Y,%)")
+2 SET Y=""
FOR %=0:0
SET Y=$ORDER(DB(DB,Y))
if Y=""
QUIT
SET @Y=DB(DB,Y)
+3 KILL DB(DB)
if DB=1
KILL DB
QUIT
+4 ;
DICL NEW I
+1 KILL DIC("S"),DLAYGO
IF '$PIECE(Y,U,3)
KILL DIC
QUIT
DICADD ;
+1 SET (D0,DIV(0))=+Y
SET DIV(U)=Y
+2 IF DIC
SET DIH=DIC
SET DIC=^DIC(DIC,0,"GL")
+3 IF '$TEST
SET @("DIH=+$P("_DIC_"0),U,2)")
+4 SET DICR=$SELECT($DATA(DA)#2:DA,1:0)
SET DA=D0
FOR DIG=.001:0
SET DIG=$ORDER(DIC(DIG))
if DIG'>0
QUIT
if DIC(DIG)]""
DO U
+5 SET DA=DICR
SET Y=DIV(U)
KILL DIC
QUIT
+6 ;
U SET %=$PIECE(^DD(DIH,DIG,0),U,4)
SET Y=$PIECE(%,";",2)
SET %=$PIECE(%,";",1)
SET X=""
SET DIV=DIC(DIG)
IF @("$D("_DIC_DIV(0)_",%))")
SET X=^(%)
+1 if Y
GOTO P
if Y'?1"E"1N.NP
GOTO Q
SET D=+$EXTRACT(Y,2,9)
SET Y=$PIECE(Y,",",2)
SET DIU=$EXTRACT(X,D,Y)
IF DIU?." "
SET DIU=""
if $LENGTH(X)+1<D
SET X=X_$JUSTIFY("",D-1-$LENGTH(X))
+2 SET ^(%)=$EXTRACT(X,1,D-1)_DIV_$EXTRACT(X,Y+1,999)
+3 GOTO DICR
P SET DIU=$PIECE(X,U,Y)
SET $PIECE(^(%),U,Y)=DIV
+1 GOTO DICR
CONV ;
+1 KILL DA
FOR %=0:1
if '$DATA(@("D"_%))
QUIT
+2 SET %=%-1
IF '%
SET DA=D0
KILL %
QUIT
+3 SET DA=@("D"_%)
SET %=%-1
SET Y=0
+4 FOR %1=%:-1:0
SET Y=Y+1
SET DA(Y)=@("D"_%1)
+5 KILL %,%1,Y
+6 QUIT
SD ;
+1 SET DIV(0)=DA
if DA>0
DO U
KILL DA,DIH,DIG,DIV
QUIT
+2 ;
TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields
+1 ;in DICRLIST so that they call ^DICR unconditionally.
+2 ;In:
+3 ; DICRLIST(file#,field#) = array of potentionally triggered fields
+4 ;Out:
+5 ; DICROUT(file,field)="" (of triggering field modified)
+6 ;
+7 NEW DICRFIL,DICRFLD
+8 SET DICRFIL=""
+9 FOR
SET DICRFIL=$ORDER(DICRLIST(DICRFIL))
if 'DICRFIL
QUIT
Begin DoDot:1
+10 SET DICRFLD=""
+11 FOR
SET DICRFLD=$ORDER(DICRLIST(DICRFIL,DICRFLD))
if 'DICRFLD
QUIT
DO TRMOD(DICRFIL,DICRFLD,.DICROUT)
End DoDot:1
+12 QUIT
+13 ;
TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that
+1 ;trigger a field so that they call ^DICR unconditionally.
+2 ;In:
+3 ; DICRFIL = file# of triggered field
+4 ; DICRFLD = triggered field#
+5 ;Out:
+6 ; DICROUT(file,field)="" (of triggering field modified)
+7 ;
+8 ;Loop through 5 node to get triggering fields/xrefs
+9 NEW DICRN,DICRFL,DICRFD,DICRXR
+10 SET DICRN=0
+11 FOR
SET DICRN=$ORDER(^DD(DICRFIL,DICRFLD,5,DICRN))
if 'DICRN
QUIT
Begin DoDot:1
+12 SET DICRXR=$GET(^DD(DICRFIL,DICRFLD,5,DICRN,0))
+13 SET DICRFL=+$PIECE(DICRXR,U)
SET DICRFD=+$PIECE(DICRXR,U,2)
SET DICRXR=+$PIECE(DICRXR,U,3)
+14 if 'DICRFL!'DICRFD!'DICRXR
QUIT
+15 DO MOD(DICRFL,DICRFD,DICRXR,.DICROUT)
End DoDot:1
+16 QUIT
+17 ;
MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic
+1 ;In:
+2 ; DICRFL = file# of triggering field
+3 ; DICRFD = field# of triggering field
+4 ; DICRXR = xref# of trigger
+5 ;Out:
+6 ; DICROUT(file,field)="" (if trigger was modified)
+7 ;
+8 if '$DATA(^DD(DICRFL,DICRFD,1,DICRXR))
QUIT
+9 NEW DICRMOD,DICRND,DICRSTR,DICRVAL
+10 ;
+11 ;Loop through xref nodes
+12 SET DICRND=0
+13 FOR
SET DICRND=$ORDER(^DD(DICRFL,DICRFD,1,DICRXR,DICRND))
if 'DICRND
QUIT
Begin DoDot:1
+14 SET DICRVAL=$GET(^DD(DICRFL,DICRFD,1,DICRXR,DICRND))
SET DICRMOD=0
+15 FOR DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0"
Begin DoDot:2
+16 FOR
if DICRVAL'[DICRSTR
QUIT
Begin DoDot:3
+17 SET DICRVAL=$PIECE(DICRVAL,DICRSTR)_"D ^DICR"_$PIECE(DICRVAL,DICRSTR,2,999)
+18 SET DICRMOD=1
End DoDot:3
End DoDot:2
+19 if 'DICRMOD
QUIT
+20 SET ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL
+21 SET DICROUT(DICRFL,DICRFD)=""
End DoDot:1
+22 QUIT
+23 ;
IENS(FIL,DA) ;Build IENS
+1 NEW I,IENS
+2 SET IENS=DA_","
+3 FOR I=1:1:$$FLEV^DIKCU(FIL)
SET IENS=IENS_DA(I)_","
+4 QUIT IENS
+5 ;
HSET(FIL,FLD) ;Hard set a value in the file
+1 if $PIECE($GET(^DD(FIL,FLD,0)),U)=""
QUIT ""
+2 ;
+3 NEW HSET,ND,PC,OROOT
+4 SET PC=$PIECE($GET(^DD(FIL,FLD,0)),U,4)
+5 SET ND=$PIECE(PC,";")
SET PC=$PIECE(PC,";",2)
if ND?." "!("0 "[PC)
QUIT ""
+6 if ND'=+$PIECE(ND,"E")
SET ND=""""_ND_""""
+7 ;
+8 SET OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA,"
if OROOT="DA,"
QUIT
+9 IF PC
SET HSET="S $P("_OROOT_ND_"),U,"_PC_")=X"
+10 IF '$TEST
SET HSET="S $E("_OROOT_ND_"),"_+$EXTRACT(PC,2,999)_","_$PIECE(PC,",",2)_")=X"
+11 QUIT HSET
