144 lines
4.7 KiB
Mathematica
144 lines
4.7 KiB
Mathematica
DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;10:01 AM 14 May 2001
|
|
;;22.0;VA FileMan;**11,88**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
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 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
|