source: cprs/branches/tmg-cprs/m_files/TMGRPC3D.m@ 896

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

Initial upload

File size: 9.3 KB
RevLine 
[796]1TMGRPC3D ;TMG/kst/Support Functions for GUI_Config ;08/31/08 ; 5/12/10 4:01pm
2 ;;1.0;TMG-LIB;**1**;08/31/08
3 ;
4 ;"TMG RPC FUNCTIONS for a GUI config program
5 ;
6 ;"Kevin Toppenberg MD
7 ;"GNU Lessor General Public License (LGPL) applies
8 ;"7/20/08
9 ;
10 ;"=======================================================================
11 ;" RPC -- Public Functions.
12 ;"=======================================================================
13 ;" <none>
14 ;"=======================================================================
15 ;"PRIVATE API FUNCTIONS
16 ;"=======================================================================
17 ;"QTERMUSR(XUDA) -- quietly inactive a given user
18 ;"QTREAUSR(TMGDA) -- launch quiet reactivation code
19 ;"GETSRLST(TMGOUT,TMGPARAMS) -- Get all .01 sub record entries for a subfile
20 ;"CLONEUSR(TMGOUT,TMGPARAMS) -- replicate a record into a new record, including all subrecs.
21 ;"CLONEREC(TMGOUT,TMGPARAMS) --- replicate a record into a new record, including all subrecs.
22 ;
23 ;"=======================================================================
24 ;"=======================================================================
25 ;"Dependencies:
26 ;" TMGRPC3* only
27 ;
28 ;"=======================================================================
29 ;"=======================================================================
30 ;
31QTERMUSR(XUDA) ;"QUITELY TERMINATE USER
32 ;"Purpose: to quietly inactive a given user
33 ;" I traced through menu option XUSERDEACT --> XUSTERM to create below
34 ;"Input: XUDA -- the IEN in 200 of user to inactivate
35 ;"Note: based on code from XUSTERM
36 ;"Results: 0 = OK, or 1^message if error
37 ;
38 NEW TMGRESULT SET TMGRESULT=0
39 NEW TMGFDA,TMGMSG,XUDT,DIC
40 SET TMGFDA(200,+XUDA_",",9.2)="NOW"
41 DO FILE^DIE("EK","TMGFDA","TMGMSG")
42 IF $DATA(TMGMSG("DIERR")) DO GOTO QTUDONE
43 . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG)_";"_$GET(TMGOUT(1))
44 SET XUDT=$P(^VA(200,+XUDA,0),"^",11) ;" field 9.2 termination date
45 DO GET^XUSTERM ;"load up info about mail, mailboxes, keys ? needed ?
46 SET ZTDTH=XUDT ;"Task Start time. VA FileMan or $HOROLOG format
47 SET ZTRTN="DQ1^XUSTERM1" ;"routine to be fired
48 SET ZTDESC="DEACTIVATE USER" ;"description
49 SET ZTSAVE("XUDA")="" ;"save variable XUDA for use in task
50 SET ZTIO="" ;"no IO device needed
51 DO ^%ZTLOAD ;"que a taskman task
52QTUDONE ;
53 QUIT TMGRESULT
54 ;
55 ;
56QTREAUSR(TMGDA) ;"QUITELY REACTIVE USER
57 ;"Purpose: launch quiet reactivation code
58 ;" I traced through menu option XUSERREACT --> REACT^XUSERNEW to create below
59 ;"Input: TMGDA -- the IEN in 200 to be reactivated
60 ;"Results: 0 if OK, or 1^ErrMsg
61 ;"NOTE: when user is deleated through VistA code, the access and verify codes
62 ;" are deleted. This function does NOT replace these.
63 ;
64 NEW TMGRESULT SET TMGRESULT=0
65 NEW TMGFDA,TMGMSG,DIC,Y
66 SET TMGFDA(200,TMGDA_",",9.2)="@" ;"Clear the Termination date
67 DO FILE^DIE("EK","TMGFDA","TMGMSG") ;"Post data
68 IF $DATA(TMGMSG("DIERR")) DO GOTO QRUDONE
69 . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG)
70 ;
71 KILL XMZ ;" if null, then user can access old mail.
72 SET Y=TMGDA ;"set user to work on.
73 DO NEW^XM ;"mailman driver -- create a mailbox for user Y
74 ;
75 IF +$PIECE($GET(^VA(200,TMGDA,201)),"^",1)'>0 DO ;"201;1 = PRIMARY MENU OPTION (#201)
76 . SET TMGFDA(200,TMGDA_",",201)="EVE" ;"set default primary menu to EVE (high level!)
77 . DO FILE^DIE("EK","TMGFDA","TMGMSG")
78 . IF $DATA(TMGMSG("DIERR")) DO
79 . . SET TMGRESULT="1^"_$$GETERSTR^TMGRPC3G(.TMGMSG)
80 IF +TMGRESULT>0 GOTO QRUDONE
81 ;
82 KILL XMDT,XMM,XMZ
83 DO REACT^XQ84(TMGDA) ;"See if this user's menu trees need to be rebuilt
84QRUDONE ;
85 QUIT TMGRESULT
86 ;
87 ;
88GETSRLST(TMGOUT,TMGPARAMS) ;"GET SUB-RECS LIST
89 ;"Purpose: Get all .01 sub record entries for a subfile
90 ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE.
91 ;" TMGPARAMS -- SubFileNum^ParentIENS
92 ;" SubFileNum - Subfile Number to get list from.
93 ;" ParentIENS -- IENS for parent to get list from (e.g. "73,"
94 ;"Output: TMGOUT is filled as follows:
95 ;" TMGOUT(0)="1^Success" or "-1^Message"
96 ;" TMGOUT(1)=IEN^Value
97 ;" TMGOUT(2)=IEN^Value
98 ;" ...
99 ;"Results: none
100 ;
101 SET TMGOUT(0)="1^Success"
102 NEW TMGSUBFILE SET TMGSUBFILE=+$PIECE(TMGPARAMS,"^",1)
103 IF TMGSUBFILE'>0 DO GOTO GSRLDONE
104 . SET TMGOUT(0)="-1^No Subfile number supplied"
105 NEW TMGPARIENTIENS SET TMGPARIENTIENS=$PIECE(TMGPARAMS,"^",2)
106 IF TMGPARIENTIENS="" DO GOTO GSRLDONE
107 . SET TMGOUT(0)="-1^No Parent IENS supplied"
108 NEW TMGIENS SET TMGIENS=","_TMGPARIENTIENS
109 ;
110 DO LIST^DIC(TMGSUBFILE,TMGIENS,,"PU","*",,,,,,"TMGMSG","TMGERR")
111 ;
112 IF $DATA(TMGMSG("DIERR")) DO GOTO GSRLDONE
113 . SET TMGOUT(0)="-1^See Fileman message"
114 . SET TMGOUT(1)=$$GETERSTR^TMGRPC3G(.TMGMSG)
115 ;
116 NEW TMGCOUNT SET TMGCOUNT=1
117 NEW TMGI SET TMGI=0
118 FOR SET TMGI=$ORDER(TMGMSG("DILIST",TMGI)) QUIT:(+TMGI'>0) DO
119 . NEW TMGONEENTRY SET TMGONEENTRY=$GET(TMGMSG("DILIST",TMGI,0))
120 . IF TMGONEENTRY="" QUIT
121 . NEW TMGIEN SET TMGIEN=$PIECE(TMGONEENTRY,"^",1)
122 . SET $PIECE(TMGONEENTRY,"^",1)=TMGIEN_","_TMGPARIENTIENS
123 . SET TMGOUT(TMGCOUNT)=TMGONEENTRY
124 . SET TMGCOUNT=TMGCOUNT+1
125 ;
126GSRLDONE ;
127 QUIT
128 ;
129 ;
130CLONEUSR(TMGOUT,TMGPARAMS) ;
131 ;"Purpose: to replicate a record into a new record, including all subrecs.
132 ;" Implementation of "CLONE RECORD" request
133 ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE.
134 ;" TMGPARAMS -- SourceIENS^New.01Value
135 ;" FileNum - filename file that is to be worked in
136 ;" SourceIENS -- source IENS for new record, (i.e. '123,' not '123')
137 ;" New.01Value -- new value to be put into the .01 field (to distinguish it from the old record)
138 ;"Output: TMGOUT is filled as follows:
139 ;" TMGOUT(0)="1^Success^NewIENS" or "-1^Message"
140 ;" TMGOUT(1)=Long Fileman message (if -1 error)
141 ;
142 SET TMGPARAMS="200^"_TMGPARAMS
143 DO CLONEREC(.TMGOUT,TMGPARAMS)
144 NEW TMGFDA,TMGMSG
145 IF +TMGOUT(0)'=1 GOTO CUDONE
146 NEW TMGNEWIEN
147 SET TMGNEWIEN=+$PIECE(TMGOUT(0),"^",3)
148 IF TMGNEWIEN="" DO GOTO CUDONE
149 . SET TMGOUT(0)="-1^Can't find IEN of added record"
150 ;
151 ;"Set new user to inactive (needs editing before it is active)
152 NEW TMGDATA
153 SET TMGDATA(0)="200^"_TMGNEWIEN_",^7^^YES"
154 DO POSTDATA^TMGRPC3C(.TMGOUT,.TMGDATA,"E")
155 IF +TMGOUT(0)=1 SET $PIECE(TMGOUT(0),"^",3)=TMGNEWIEN
156 ;
157CUDONE ;
158 QUIT
159 ;
160CLONEREC(TMGOUT,TMGPARAMS) ;
161 ;"Purpose: to replicate a record into a NEW record, including all subrecs.
162 ;" Implementation of "CLONE RECORD" request
163 ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE.
164 ;" TMGPARAMS -- FileNum^SourceIENS^New.01Value
165 ;" FileNum - filename file that is to be worked in
166 ;" SourceIENS -- the source IENS for the new record, (i.e. 123, not 123)
167 ;" New.01Value -- the new value to be put into the .01 field (to distinguish it from the old record)
168 ;"Output: TMGOUT is filled as follows:
169 ;" TMGOUT(0)="1^Success^NewIENS" or "-1^Message"
170 ;" TMGOUT(1)=Long Fileman message (if -1 error)
171 ;"NOTE: This hasn't been tested on subfiles yet...
172 ;
173 NEW TMGFILE,TMGIENS,TMGNEW01VALUE
174 SET TMGOUT(0)="-1^Error" ;"default to error
175 ;
176 SET TMGFILE=+$PIECE(TMGPARAMS,"^",1)
177 IF TMGFILE'>0 DO GOTO CRDONE
178 . SET TMGOUT(0)="-1^No file number supplied"
179 SET TMGIENS=$PIECE(TMGPARAMS,"^",2)
180 IF TMGIENS="" DO GOTO CRDONE
181 . SET TMGOUT(0)="-1^IENS supplied"
182 IF +TMGIENS=TMGIENS DO
183 . IF TMGIENS'["," SET TMGIENS=TMGIENS_","
184 SET TMGNEW01VALUE=$PIECE(TMGPARAMS,"^",3)
185 IF TMGNEW01VALUE="" DO GOTO CRDONE
186 . SET TMGOUT(0)="-1^No new value supplied for .01 value"
187 ;
188 NEW TMGARRAY,TMGMSG,TMGTEMP
189 NEW TMGREF SET TMGREF="TMGARRAY"
190 ;
191 DO STUBNEWR^TMGRPC3E(TMGFILE,TMGNEW01VALUE,.TMGOUT)
192 IF +TMGOUT(0)'=1 DO GOTO CRDONE
193 . SET $PIECE(TMGOUT(0),"^",2)="Unable to stub in new record. "_$PIECE(TMGOUT(0),"^",2)
194 NEW TMGNEWIEN SET TMGNEWIEN=$PIECE(TMGOUT(0),"^",3)
195 ;"Write "The IENS of the new record is: ",TMGNEWIEN,! ;"TEMP!!!
196 ;
197 ;"Note: Using a "X" flag is VERY slow, because it reindexes
198 ;" ALL XREFS for ALL entries in file (e.g. 60 seconds)
199 ;"DO TRNMRG^TMGDIT("M",TMGFILE,TMGFILE,TMGIENS,TMGNEWIEN_",") ;"DO actual record copy.
200 DO TRNMRG^DIT("M",TMGFILE,TMGFILE,TMGIENS,TMGNEWIEN_",") ;"do actual record copy.
201 NEW DA,DIK
202 SET DIK=$GET(^DIC(TMGFILE,0,"GL"))
203 SET DA=TMGNEWIEN
204 IF (+DA>0)&(DIK'="") DO IX1^DIK ;"index just the new record
205 ;
206 ;"OK if we got this far (can't check error from TRNMRG)
207 SET TMGOUT(0)="1^Success^"_TMGNEWIEN
208 ;
209CRDONE QUIT
210 ;
211 ;
Note: See TracBrowser for help on using the repository browser.