source: WorldVistAEHR/trunk/r/ELECTRONIC_SIGNATURE-XOBE/XOBESIG.m@ 975

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

initial load of WorldVistAEHR

File size: 6.2 KB
Line 
1XOBESIG ;Oakland/mko-ELECTRONIC SIGNATURE CODES ;9:29 AM 14 Jul 2006
2 ;;1.0;Electronic Signature;;Jul 14, 2006
3 ;;Foundations Electronic Signature Release v1.0 [Build: 1.0.0.024]
4 ;
5ISDEF(RESULT) ; -- Returns whether the user has an Electronic Signature Code defined.
6 ; Returns:
7 ; 0 : if the user has no esig defined
8 ; 1 : if the user does have an esig defined
9 ; -2 : if DUZ doesn't refer to a valid user
10 ;
11 ; Remote Procedure: XOBE ESIG IS DEFINED
12 ;
13 NEW XOBESIG,XOBEMSG,DIERR
14 KILL RESULT
15 ;
16 ; -- Get current esig
17 SET XOBESIG=$$GET1^DIQ(200,+$GET(DUZ)_",",20.4,"I","","XOBEMSG")
18 ;
19 ; -- Check result
20 IF $GET(DIERR),$DATA(XOBEMSG("DIERR","E",601)) SET RESULT=-2
21 ELSE IF XOBESIG]"" SET RESULT=1
22 ELSE SET RESULT=0
23 QUIT
24 ;
25GETCODE(RESULT) ; -- Get user's Electronic Signature Code
26 ; Return:
27 ; Electronic signature code
28 ; -2 : if DUZ doesn't refer to a valid user
29 ;
30 ; Remote Procedure: XOBE ESIG GET CODE
31 ;
32 NEW XOBESIG,XOBEMSG,DIERR
33 KILL RESULT
34 ;
35 ; -- Get current esig
36 SET XOBESIG=$$GET1^DIQ(200,+$GET(DUZ)_",",20.4,"I","","XOBEMSG")
37 ;
38 ; -- Return result
39 IF $GET(DIERR),$DATA(XOBEMSG("DIERR","E",601)) SET RESULT=-2
40 ELSE IF XOBESIG="" SET RESULT=""
41 ELSE SET RESULT=$$ENCRYP^XUSRB1(XOBESIG)
42 QUIT
43 ;
44SETCODE(RESULT,XOBESIG) ; -- Save user's Electronic Signature Code
45 ; Return:
46 ; 1 : if new ESig was correctly filed
47 ; 0 : if new ESig code is not valid
48 ; -1 : if new ESig is the same as the old one
49 ; -2 : if DUZ doesn't refer to a valid user
50 ;
51 ; Remote Procedure: XOBE ESIG SET CODE
52 ;
53 NEW X,XOBEIENS,XOBEOLD,XOBEFDA,XOBEMSG,DIERR
54 KILL RESULT
55 ;
56 ; -- Get the old esig code
57 SET XOBEIENS=+$GET(DUZ)_","
58 SET XOBEOLD=$$GET1^DIQ(200,XOBEIENS,20.4,"I","","XOBEMSG")
59 IF $GET(DIERR) DO QUIT
60 . IF $DATA(XOBEMSG("DIERR","E",601)) SET RESULT=-2
61 . ELSE SET RESULT=0
62 ;
63 ; -- Validate format of new esig
64 IF $GET(XOBESIG)="" SET RESULT=0 QUIT
65 SET X=$$DECRYP^XUSRB1(XOBESIG)
66 IF X'?.UNP!($LENGTH(X)>20)!($LENGTH(X)<6) SET RESULT=0 QUIT
67 ;
68 ; -- Make sure old and new are different
69 DO HASH^XUSHSHP
70 IF X=XOBEOLD SET RESULT=-1 QUIT
71 ;
72 ; -- Save the new code
73 SET XOBEFDA(200,XOBEIENS,20.4)=X
74 DO FILE^DIE("","XOBEFDA","XOBEMSG")
75 IF $GET(DIERR) SET RESULT=0 QUIT
76 ;
77 SET RESULT=1
78 QUIT
79 ;
80GETDATA(RESULT) ; -- Return electronic signature block-related data
81 ; Return:
82 ; Electronic signature block-related data
83 ; -2 : if DUZ doesn't refer to a valid user
84 ;
85 ; Remote Procedure: XOBE ESIG GET DATA
86 ;
87 NEW XOBEIENS,XOBEFLDS,XOBETARG,XOBEMSG,DIERR
88 KILL RESULT
89 ;
90 ; -- Setup input variables to GETS^DIQ call
91 SET XOBEIENS=+$GET(DUZ)_","
92 SET XOBEFLDS="1;20.2;20.3;.132;.137;.138"
93 ;
94 ; -- Get data
95 DO GETS^DIQ(200,XOBEIENS,XOBEFLDS,"I","XOBETARG","XOBEMSG")
96 IF $GET(DIERR) DO QUIT
97 . IF $DATA(XOBEMSG("DIERR","E",601)) SET RESULT=-2
98 . ELSE SET RESULT=""
99 ;
100 ; -- Put data into RESULT array
101 SET RESULT(1)=$$VALUE($GET(XOBETARG(200,XOBEIENS,1,"I"))) ;initial
102 SET RESULT(2)=$$VALUE($GET(XOBETARG(200,XOBEIENS,20.2,"I"))) ;sig blk printed name
103 SET RESULT(3)=$$VALUE($GET(XOBETARG(200,XOBEIENS,20.3,"I"))) ;sig blk title
104 SET RESULT(4)=$$VALUE($GET(XOBETARG(200,XOBEIENS,.132,"I"))) ;office phone
105 SET RESULT(5)=$$VALUE($GET(XOBETARG(200,XOBEIENS,.137,"I"))) ;voice pager
106 SET RESULT(6)=$$VALUE($GET(XOBETARG(200,XOBEIENS,.138,"I"))) ;digital pager
107 QUIT
108 ;
109VALUE(X) ; -- Return X or if X is "", return @
110 QUIT $SELECT($GET(X)="":"@",1:X)
111 ;
112SETDATA(RESULT,XOBEVALS) ; -- Save electronic signature block-related data
113 ; Return:
114 ; 1 : if successfully filed
115 ; -2 : if DUZ doesn't refer to a valid user
116 ; error text : if Filer call failed
117 ;
118 ; Remote Procedure: XOBE ESIG SET DATA
119 ;
120 NEW XOBEFDA,DIERR,XOBEMSG,XOBEIENS
121 KILL RESULT
122 SET XOBEIENS=+$GET(DUZ)_","
123 ;
124 ; -- Setup up FDA for FILE^DIE call
125 SET XOBEFDA(200,XOBEIENS,1)=$GET(XOBEVALS("initial"))
126 SET XOBEFDA(200,XOBEIENS,20.2)=$GET(XOBEVALS("signature block printed name"))
127 SET XOBEFDA(200,XOBEIENS,20.3)=$GET(XOBEVALS("signature block title"))
128 SET XOBEFDA(200,XOBEIENS,.132)=$GET(XOBEVALS("office phone"))
129 SET XOBEFDA(200,XOBEIENS,.137)=$GET(XOBEVALS("voice pager"))
130 SET XOBEFDA(200,XOBEIENS,.138)=$GET(XOBEVALS("digital pager"))
131 ;
132 ; -- File the data
133 DO FILE^DIE("ET","XOBEFDA","XOBEMSG")
134 ;
135 ; -- Handle errors
136 IF $GET(DIERR) DO QUIT
137 . ; -- Entry not found error
138 . IF $DATA(XOBEMSG("DIERR","E",601)) SET RESULT(1)=-2 QUIT
139 . ;
140 . ; -- Put error message into RESULT array
141 . NEW ERR,LN
142 . SET ERR=0 FOR SET ERR=$ORDER(XOBEMSG("DIERR",ERR)) QUIT:'ERR DO
143 .. DO ADDTEXT("Error #"_XOBEMSG("DIERR",ERR),.RESULT)
144 .. DO ADDTEXT("--------------",.RESULT)
145 .. SET LN=0 FOR SET LN=$ORDER(XOBEMSG("DIERR",ERR,"TEXT",LN)) QUIT:'LN DO
146 ... DO ADDTEXT(XOBEMSG("DIERR",ERR,"TEXT",LN),.RESULT)
147 .. ;
148 .. ; -- If the error returned is 701 (invalid input),
149 .. ; -- put the ? help for the field into the RESULT array
150 .. IF XOBEMSG("DIERR",ERR)=701 DO ADDHELP(.XOBEMSG,ERR,.RESULT)
151 ;
152 ; -- Values were successfully saved
153 SET RESULT(1)=1
154 QUIT
155 ;
156ADDHELP(XOBEMSG,ERR,RESULT) ;
157 NEW FILE,IENS,FIELD,LINE,MSG,DIERR,DIHELP
158 ;
159 ; -- Get file/field information from the XOBEMSG array
160 SET FILE=$GET(XOBEMSG("DIERR",ERR,"PARAM","FILE"))
161 SET IENS=$GET(XOBEMSG("DIERR",ERR,"PARAM","IENS"))
162 SET FIELD=$GET(XOBEMSG("DIERR",ERR,"PARAM","FIELD"))
163 ;
164 ; -- Get the ? help for the field
165 DO HELP^DIE(FILE,IENS,FIELD,"?","MSG")
166 ;
167 ; -- Add the ? help to the RESULT array
168 SET LINE=0 FOR SET LINE=$ORDER(MSG("DIHELP",LINE)) Q:'LINE DO
169 . DO ADDTEXT(MSG("DIHELP",LINE),.RESULT)
170 DO ADDTEXT("",.RESULT)
171 QUIT
172 ;
173ADDTEXT(TEXT,RESULT) ;Add TEXT to RESULT array
174 NEW NODE
175 SET NODE=$ORDER(RESULT(" "),-1)+1
176 SET RESULT(NODE)=$GET(TEXT)
177 QUIT
178 ;
179VALIDATE(RESULT,XOBESIG) ; -- Return whether passed ESig is valid
180 ; Return:
181 ; 1 if ESig is valid
182 ; 0 if ESig is invalid
183 ; -1 if ESig is null
184 ; -2 if DUZ doesn't refer to a valid user
185 ; This entry point is not currently used.
186 ;
187 NEW X,XOBECURR,XOBEIENS,XOBEMSG,DIERR
188 KILL RESULT
189 ;
190 ; -- Get esig from New Person file
191 SET XOBEIENS=+$GET(DUZ)_","
192 SET XOBECURR=$$GET1^DIQ(200,XOBEIENS,20.4,"I","","XOBEMSG")
193 ;
194 ; -- Check that DUZ refers to a valid user
195 IF $GET(DIERR),$DATA(XOBEMSG("DIERR","E",601)) SET RESULT=-2 QUIT
196 ;
197 ; -- Check for null esig
198 IF XOBECURR="" SET RESULT=-1 QUIT
199 ;
200 ; -- Check whether old matches value passed in
201 SET X=$$DECRYP^XUSRB1(XOBESIG)
202 DO HASH^XUSHSHP
203 SET RESULT=X=XOBECURR
204 QUIT
Note: See TracBrowser for help on using the repository browser.