source: cprs/branches/tmg-cprs/m_files/TMGDIA3.m@ 833

Last change on this file since 833 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 6.5 KB
RevLine 
[796]1TMGDIA3 ;TMG/kst/Custom version of DIA3 ;03/25/06
2 ;;1.0;TMG-LIB;**1**;01/01/06
3
4
5DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94 09:57
6 ;;22.0;VA FileMan;;Mar 30, 1999
7 ;Per VHA Directive 10-93-142, this routine should not be modified.
8
9 ;"*************************************************************************
10 ;"* Custom version of Fileman code, for customization
11 ;"* Also includes code from DITP.m
12 ;"*************************************************************************
13
14FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN)
15 ;"Purpose: DELETE OR REPOINT POINTERS
16 ;"Note: In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to.
17 ;"Input: DIFLG="D" (delete) ;" ADDED "R" (replace) //kt
18 ;" DIFILE=File# previously pointed to
19 ;" DIDELIEN=Record# previously pointed to
20 ;" DIPTIEN=New pointed-to record(future) ;"//KT fixed to do now.
21 ;" ;"//e.g. if wanting to replace all pointers to file#50, record#20 to record#40 (must be in file#50)
22 ;" ;"// then DIFILE=50, DIDELIEN=20, DIPTIEN=40
23 ;"Output:
24 ;"Result: none
25
26 ;"Note: sample of array passed to P^DITP
27 ;" 23510 is $J
28 ;" 47 is IEN to be deleted in file 50 (stored at ^PSDRUG(*))
29 ;" 1646 is IEN to be substituted for all 47's
30 ;"
31 ;" First part of array is list of all files & fields that point to file
32 ;" ----------------
33 ;" ^UTILITY("DIT",23510,0,1)="727.819^67^P50'"
34 ;" ...
35 ;" ^UTILITY("DIT",23510,0,54)="801.43^.02^RV"
36 ;" ^UTILITY("DIT",23510,0,55)="810.31^.04^V"
37 ;" ^UTILITY("DIT",23510,0,56)="810.32^.01^V"
38 ;" ^UTILITY("DIT",23510,0,57)="811.52^.01^MVX"
39 ;" ^UTILITY("DIT",23510,0,58)="811.902^.01^MVX"
40 ;" ^UTILITY("DIT",23510,0,59)="9009032.4^.05^P50'"
41 ;"
42 ;" Second part of array is list of changes that should be made. Only 1 change shown here.
43 ;" ----------------
44 ;" ^UTILITY("DIT",23510,47)="1646;PSDRUG("
45 ;" ^UTILITY("DIT",23510,"47;PSDRUG(")="1646;PSDRUG("
46
47 new %X,%Y,X,Y
48 ;"new DIPTIEN ;//kt allow input value to be used.
49 new DIFIXPT,DIFIXPTC,DIFIXPTH
50 do if $G(X)]"" do BLD^DIALOG(201,X) quit ;"BUILD FILEMAN DIALOG
51 . set X="DIFLG" quit:(($G(DIFLG)'="D")&($G(DIFLG)'="R")) ;"//kt added "R"
52 . set X="DIDELIEN" Q:'$G(DIDELIEN)
53 . set X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))=""
54 . set X="DIPTIEN"
55 . if (DIFLG="R"),$G(DIPTIEN) do quit:(Y="")
56 . . set Y=$get(^DIC(DIFILE,0,"GL")) ;"//kt changed ^DD to ^DIC
57 . . quit:Y=""
58 . . if '$data(@(Y_DIPTIEN_",0)")) set Y="" quit
59 . kill X
60 . quit
61 set DIPTIEN=+$G(DIPTIEN)
62 set (DIFIXPT,DIFIXPTC)=1
63 new %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z
64 kill ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J)
65 set (DIFILE,DIA("P"),Y)=+DIFILE
66 set (DIA,DTO)=^DIC(DIFILE,0,"GL")
67 set DIA(1)=DIDELIEN
68 do PTS^DIT
69 set ^UTILITY("DIT",$J,0)=0
70 goto:$D(^(0))<9 QFIXPT
71 set ^UTILITY("DIT",$J,DIA(1))=DIPTIEN_";"_$E(DIA,2,999)
72 set ^UTILITY("DIT",$J,DIA(1)_";"_$E(DIA,2,999))=DIPTIEN_";"_$E(DIA,2,999)
73
74 zwr ^UTILITY("DIT",$J,*)
75 ;"do P^DITP
76 ;"do P
77
78QFIXPT
79 K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN
80 quit
81 ;
82
83 ;"*************************************************************************
84 ;"* Code below from DITP.m
85 ;"*************************************************************************
86
87PTS ;
88 D WAIT^DICD
89 kill IOP
90P kill DR,D,DL,X
91 set (BY,FR,TO)=""
92 set X=$O(^UTILITY("DIT",$J,0,0))
93 if X="" do quit ;"<--- exit point from loop
94 . K ^UTILITY("DIT",$J),DIA,DHD,DR,DISTOP,BY,TO,FR,FLDS,L
95 set Y=^(X) ;"get value of entry e.g. 50^905^P50'X
96 set L=$P(Y,U,2) ;"L= field#
97 set DL=1
98 set DL(1)=L
99 set DL(1)=DL(1)_"////^S X=$S($D(DE(DQ))[0:"""",$D(^UTILITY(""DIT"",$J,DE(DQ)))-1:"""",^(DE(DQ)):"
100 set DL(1)=DL(1)_$S($P(Y,U,3)'["V":"+",1:"")
101 set DL(1)=DL(1)_"^(DE(DQ)),1:""@"") I X]"""",$G(DIFIXPT)=1 D PTRPT^TMGDIA3"
102 kill ^(X) ;"delete entry from top of list
103 set L=$P(^DD(+Y,L,0),U,4) ;"+Y=File#, L=Field# --> L set to 4th piece of data dictionary entry, e.g. '8;6'
104 set %=$P(L,";",2) ;"e.g. %=6
105 set L=""""_$P(L,";",1)_"""" ;"e.g. L="8"
106 set DHD=$P(^(0),U) ;"DHD--> header for EN1^DIP
107 if % set %="$P(^("_L_"),U,"_% ;"--> e.g. set %='$P(^(8),U,8
108 else set %="$E(^("_L_"),"_+$E(%,2,9)_","_$P(%,",",2)
109 set L=L_")):"""","_%_")?."" "":"""",'$D(^UTILITY(""DIT"",$J,"_$S($P(Y,U,3)'["V":"+",1:"")_%_"))):"""",1:D"
110UP set D(DL)=+Y ;"+Y = File#
111 set %=+Y ;"+Y = File#
112 if $D(^DD(%,0,"UP")) do goto UP
113 . set DL=DL+1
114 . set Y=^("UP")
115 . set (DL(DL),%)=$O(^DD(Y,"SB",%,0))_"///"
116 . set X(DL)=""""_$P($P(^DD(Y,+%,0),U,4),";")_""""
117 . set BY=+%_","_BY
118 set DHD=$O(^("NM",0))_" entries whose '"_DHD_"' pointers have been changed"
119 if '$D(^DIC(%,0,"GL")) goto P
120 set DIC=^("GL")
121 set Y="S X=$S('$D("_DIC_"D0,"
122 for X=0:1:DL-1 do
123 . set DR(X+1,D(DL-X))=DL(DL-X)
124 . if X set Y=Y_X(DL+1-X)_",D"_X_","
125 set DIA("P")=%
126 set %=$L(BY,",")
127 if %>2 set BY=$P(BY,",",%-2)_",.01,"_BY
128 set BY=BY_Y_L_X_")"
129 set L=0
130 set FLDS=""
131 set DISTOP=0
132 set DHIT="G LOOP^DIA2"
133 set %ZIS=""
134 do EN1^DIP
135 if $G(DIFIXPT)=1 goto P
136 set IOP=$G(IO)
137 goto P
138 ;
139
140PTRPT
141 quit:'$G(DIFIXPTC)
142 new I,J,X
143 for I=1:1:DL do
144 . set J=""
145 . for set J=$order(DR(I,J)) quit:J="" do
146 . . if DR(I,J)["///" do
147 . . . set X=$P($G(DR(I,J)),"///",1)
148 . . . if X]"" do
149 . . . . new s
150 . . . . set s=^TMP("DIFIXPT",$J,DIFIXPTC)
151 . . . . set s=s_$S(I>1:" entry:"_$S(I=DL:$G(DA),1:$G(DA(DL-I))),1:"")
152 . . . . set s=s_$S(I=DL:" field:",1:" mult.fld:")
153 . . . . set s=s_X
154 . . . . set ^TMP("DIFIXPT",$J,DIFIXPTC)=s
155 Q
156
Note: See TracBrowser for help on using the repository browser.