source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICR.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;10:01 AM 14 May 2001
2 ;;22.0;VA FileMan;**11,88**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q:'$O(^DD(DIH,DIG,1,0))&'$D(^DD("IX","F",DIH,DIG))
5 ;
6 N DICRIENS,DICRBADK
7 I $D(^DD("KEY","F",DIH,DIG)) D Q:$G(DICRBADK)
8 . N DICRFDA,DICRMSG,DIERR
9 . D SAVE
10 . S DICRIENS=$$IENS(DIH,.DA)
11 . S DICRFDA(DIH,DICRIENS,DIG)=DIV
12 . I '$$KEYVAL^DIE("","DICRFDA","DICRMSG") D
13 .. S DICRBADK=1
14 .. S X=DIU X $$HSET(DIH,DIG)
15 . D RESTORE
16 ;
17 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
18 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
19 ;
20 I $D(^DD("IX","F",DIH,DIG)) D
21 . N DICRCTRL,DICRVAL,I
22 . D SAVE
23 . S:$D(DICRIENS)[0 DICRIENS=$$IENS(DIH,.DA)
24 . S DICRVAL(DIH,DICRIENS,DIG,"O")=DIU
25 . S DICRVAL(DIH,DICRIENS,DIG,"N")=DIV
26 . S:$G(DICRREC)]"" DICRCTRL="r"
27 . S DICRCTRL("VAL")="DICRVAL("
28 . D INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL)
29 . D:$G(DICRREC)]"" @DICRREC
30 . D RESTORE
31Q Q
32 ;
33SAVE F DB=1:1 Q:'$D(DB(DB))
34 F Y="DIC","DIV","DA" S %="" F DB=DB:0 S @("%=$O("_Y_"(%))") Q:%="" S DB(DB,Y,%)=@(Y_"(%)")
35 F %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR" S DB(DB,%)="" I $D(@%)#2 S DB(DB,%)=@%
36 K DA F Y=-1:1 Q:'$D(DIV(Y+1))
37 I Y+1 S DA=DIV(Y) F %=Y-1:-1:0 S DA(Y-%)=DIV(%)
38 Q
39 ;
40RESTORE F DB=1:1 Q:'$D(DB(DB+1))
41 F Y="DIC","DIV","DA" K @Y S %="" F DB=DB:0 S %=$O(DB(DB,Y,%)) Q:%="" S @(Y_"(%)=DB(DB,Y,%)")
42 S Y="" F %=0:0 S Y=$O(DB(DB,Y)) Q:Y="" S @Y=DB(DB,Y)
43 K DB(DB) K:DB=1 DB Q
44 ;
45DICL N I
46 K DIC("S"),DLAYGO I '$P(Y,U,3) K DIC Q
47DICADD ;
48 S (D0,DIV(0))=+Y,DIV(U)=Y
49 I DIC S DIH=DIC,DIC=^DIC(DIC,0,"GL")
50 E S @("DIH=+$P("_DIC_"0),U,2)")
51 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)]""
52 S DA=DICR,Y=DIV(U) K DIC Q
53 ;
54U S %=$P(^DD(DIH,DIG,0),U,4),Y=$P(%,";",2),%=$P(%,";",1),X="",DIV=DIC(DIG) I @("$D("_DIC_DIV(0)_",%))") S X=^(%)
55 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))
56 S ^(%)=$E(X,1,D-1)_DIV_$E(X,Y+1,999)
57 G DICR
58P S DIU=$P(X,U,Y),$P(^(%),U,Y)=DIV
59 G DICR
60CONV ;
61 K DA F %=0:1 Q:'$D(@("D"_%))
62 S %=%-1 I '% S DA=D0 K % Q
63 S DA=@("D"_%),%=%-1,Y=0
64 F %1=%:-1:0 S Y=Y+1,DA(Y)=@("D"_%1)
65 K %,%1,Y
66 Q
67SD ;
68 S DIV(0)=DA D U K DA,DIH,DIG,DIV Q
69 ;
70TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields
71 ;in DICRLIST so that they call ^DICR unconditionally.
72 ;In:
73 ; DICRLIST(file#,field#) = array of potentionally triggered fields
74 ;Out:
75 ; DICROUT(file,field)="" (of triggering field modified)
76 ;
77 N DICRFIL,DICRFLD
78 S DICRFIL=""
79 F S DICRFIL=$O(DICRLIST(DICRFIL)) Q:'DICRFIL D
80 . S DICRFLD=""
81 . F S DICRFLD=$O(DICRLIST(DICRFIL,DICRFLD)) Q:'DICRFLD D TRMOD(DICRFIL,DICRFLD,.DICROUT)
82 Q
83 ;
84TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that
85 ;trigger a field so that they call ^DICR unconditionally.
86 ;In:
87 ; DICRFIL = file# of triggered field
88 ; DICRFLD = triggered field#
89 ;Out:
90 ; DICROUT(file,field)="" (of triggering field modified)
91 ;
92 ;Loop through 5 node to get triggering fields/xrefs
93 N DICRN,DICRFL,DICRFD,DICRXR
94 S DICRN=0
95 F S DICRN=$O(^DD(DICRFIL,DICRFLD,5,DICRN)) Q:'DICRN D
96 . S DICRXR=$G(^DD(DICRFIL,DICRFLD,5,DICRN,0))
97 . S DICRFL=+$P(DICRXR,U),DICRFD=+$P(DICRXR,U,2),DICRXR=+$P(DICRXR,U,3)
98 . Q:'DICRFL!'DICRFD!'DICRXR
99 . D MOD(DICRFL,DICRFD,DICRXR,.DICROUT)
100 Q
101 ;
102MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic
103 ;In:
104 ; DICRFL = file# of triggering field
105 ; DICRFD = field# of triggering field
106 ; DICRXR = xref# of trigger
107 ;Out:
108 ; DICROUT(file,field)="" (if trigger was modified)
109 ;
110 Q:'$D(^DD(DICRFL,DICRFD,1,DICRXR))
111 N DICRMOD,DICRND,DICRSTR,DICRVAL
112 ;
113 ;Loop through xref nodes
114 S DICRND=0
115 F S DICRND=$O(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)) Q:'DICRND D
116 . S DICRVAL=$G(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)),DICRMOD=0
117 . F DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0" D
118 .. F Q:DICRVAL'[DICRSTR D
119 ... S DICRVAL=$P(DICRVAL,DICRSTR)_"D ^DICR"_$P(DICRVAL,DICRSTR,2,999)
120 ... S DICRMOD=1
121 . Q:'DICRMOD
122 . S ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL
123 . S DICROUT(DICRFL,DICRFD)=""
124 Q
125 ;
126IENS(FIL,DA) ;Build IENS
127 N I,IENS
128 S IENS=DA_","
129 F I=1:1:$$FLEV^DIKCU(FIL) S IENS=IENS_DA(I)_","
130 Q IENS
131 ;
132HSET(FIL,FLD) ;Hard set a value in the file
133 Q:$P($G(^DD(FIL,FLD,0)),U)="" ""
134 ;
135 N HSET,ND,PC,OROOT
136 S PC=$P($G(^DD(FIL,FLD,0)),U,4)
137 S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) ""
138 S:ND'=+$P(ND,"E") ND=""""_ND_""""
139 ;
140 S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA,"
141 I PC S HSET="S $P("_OROOT_ND_"),U,"_PC_")=X"
142 E S HSET="S $E("_OROOT_ND_"),"_+$E(PC,2,999)_","_$P(PC,",",2)_")=X"
143 Q HSET
Note: See TracBrowser for help on using the repository browser.