source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLEVSRV3.m@ 949

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1HLEVSRV3 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4OPENMAIL ; Grant license to remote requesters...
5 N ANS,CODE,CODEXP,EXPNOW,IOINHI,IOINORM,NOW,X,XTMP
6 ;
7 S XTMP="HLEV REMOTE LICENSE"
8 S X="IOINHI;IOINORM" D ENDR^%ZISS
9 S NOW=$$NOW^XLFDT
10 ;
11 D HDM
12 D EXM
13 F Q:($Y+3)>IOSL W !
14 QUIT:$$BTE^HLCSMON("Press RETURN to continue, or '^' to exit... ")
15 ;
16 D HDM
17 ;
18 S (CODE,CODEXP,EXPNOW)="" ; Default to no current license...
19 ;
20 ; Current license? Show details of current (maybe expired) license.
21 S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D
22 . S CODEXP=$P(CODE,U),CODE=$P(CODE,U,2)
23 . S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
24 . D SHOWLIC
25 ;
26 I CODE']"" W !!,"No current license exists..."
27 ;
28 ; OK. License and expiration date exist...
29 S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
30 ;
31 F D QUIT:ACTION="EXIT"
32 . N STR
33 . S STR=$S($D(^XTMP(XTMP)):1,1:0)
34 . I STR S STR(1)="LICEXT^Change cutoff date/time~LICUSER^Add requesters~LICNEW^Create new license"_$S(CODE]"":" (and cancel old license)",1:"")_"~LICAN^Cancel current license~EXIT^Exit"
35 . I 'STR S STR(1)="LICNEW^Create new license~EXIT^Exit"
36 . S ACTION=$$ASKDIR(STR(1),$$DEFAULT)
37 . S:ACTION']"" ACTION="EXIT"
38 . QUIT:ACTION="EXIT" ;->
39 . S ACTION=ACTION_"^HLEVSRV4"
40 . D @ACTION
41 . D SHOWLIC
42 ;
43 I '$D(^XTMP(XTMP)) QUIT ;->
44 ;
45 I $O(^XTMP(XTMP,"USER",""))']"" D
46 . W !!,"No requesters have been created under this license. So, even thought a"
47 . W !,"license exists, no one can make use of the license. To enter requesters, you"
48 . W !,"must reinvoke this option and enter one or more requesters."
49 ;
50 I EXPNOW W !!,"The current license is expired!"
51 ;
52 I $O(^XTMP(XTMP,"USER",""))']""!(EXPNOW) D
53 . W !
54 . S X=$$BTE^HLCSMON("Press RETURN to exit...")
55 ;
56 Q
57 ;
58DEFAULT() ; What would most users do under circumstances?
59 ; CODE,CODEXP,EXPNOW,XTMP -- req
60 I CODE']""!('$D(^XTMP(XTMP))) QUIT "Create new license" ;->
61 I EXPNOW QUIT "Change cutoff date/time" ;->
62 I $O(^XTMP(XTMP,"USER",""))']"" QUIT "Add requesters" ;->
63 Q "Exit"
64 ;
65SHOWLIC ; Show license and expiration date...
66 ; CODE,CODEXP,EXPNOW,IOINHI,IOINORM,XTMP -- req
67 N HOLD,NO,USER
68 ;
69 I '$D(^XTMP(XTMP)) D QUIT ;->
70 . W !!,$$CJ^XLFSTR("---------------- No License Exists ----------------",IOM)
71 ;
72 W !!,$$CJ^XLFSTR("---------------- Current License - "_CODE_" ["_$S(EXPNOW:IOINHI,1:"")_$$SDT^HLEVX001(CODEXP)_IOINORM_"] ----------------",IOM)
73 ;
74 S NO=0,USER=""
75 F S USER=$O(^XTMP(XTMP,"USER",USER)) Q:USER']"" D
76 . S NO=NO+1,HOLD(USER)=""
77 ;
78 I NO'>0 W !,$$CJ^XLFSTR("No current users exist!",IOM) QUIT ;->
79 ;
80 W !,$$CJ^XLFSTR("----- Licensed Requesters ------",IOM)
81 S USER=""
82 F S USER=$O(HOLD(USER)) Q:USER']"" D
83 . W !,$$CJ^XLFSTR(USER,IOM)
84 ;
85 Q
86 ;
87SETLIC(CODE) ; Set license...
88 ; XTMP -- req
89 N CUT
90 S CUT=+CODE
91 ;
92 KILL ^XTMP(XTMP) ; Remove all old data...
93 ;
94 ; Set vaporization date to 7 days after cutoff time...
95 S ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
96 ;
97 S ^XTMP(XTMP,"CODE")=CODE ; Cutoff date/time ^ Code
98 S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
99 ;
100 Q
101 ;
102HDM ; Header for option...
103 ; IOINHI,IOINORM,XTMP -- req
104 N CODE,NOW
105 W @IOF,$$CJ^XLFSTR("Grant License to Remote Requesters",IOM)
106 S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D
107 . S CUT=+CODE,CODE=$P(CODE,U,2,999)
108 . I CUT<$$NOW^XLFDT D QUIT ;->
109 . . W !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_IOINHI_$$FMTE^XLFDT(CUT)_IOINORM,IOM+$L(IOINHI)+$L(IOINORM))
110 . W !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_$$FMTE^XLFDT(CUT),IOM)
111 W !,$$REPEAT^XLFSTR("=",IOM)
112 QUIT
113 ;
114EXM N I,T F I=1:1 S T=$T(EXM+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
115 ;;Mailman server requests can be sent to your site requesting HL7 data be
116 ;;returned to the VistA HL7 team. These requests are normally only sent to
117 ;;the VistA HL7 team. However, from time to time, support personnel will have
118 ;;legitimate need to retrieve critical VistA HL7 data. In order to receive
119 ;;return data, anyone not on the VistA HL7 team needs a license. This option
120 ;;will generate a license that must be communicated to those (not on the VistA
121 ;;HL7 team) requesting remote query rights.
122 ;;
123 ;;Note: Notification of every remote server request is automatically sent to
124 ;; the VistA HL7 team. And, this includes the messages sent remotely
125 ;; to non-VistA HL7 recipients (using the license you are about to grant.)
126 QUIT
127 ;
128GRANT() ; Get date and license...
129 N CODE,CONT,CUT,FUTURE,LICENSE
130 ;
131 S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D QUIT:'CONT "" ;->
132 . S CONT=1
133 . W !!,"License# ",IOINHI,$P(CODE,U,2),IOINORM," exists and has a cutoff time of ",$$FMTE^XLFDT($P(CODE,U)),"."
134 . W !
135 . I $$YN^HLCSRPT4("Terminate license now","No") D QUIT:'CONT ;->
136 . . KILL ^XTMP(XTMP)
137 . . W " done..."
138 . . S CONT=""
139 . W !
140 . QUIT:'$$YN^HLCSRPT4("Keep license and extend time","Yes") ;->
141 . W !!,"Defaulting 'NOW + 7 days' below..."
142 . W !
143 . S CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2)) QUIT:'CUT ;->
144 . S $P(^XTMP(XTMP,"CODE"),U)=CUT
145 . S ^XTMP(XTMP,0)=CUT_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
146 . S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
147 . W " updated..."
148 . S CONT=0
149 ;
150 S FUTURE=$$FMADD^XLFDT($$NOW^XLFDT,0,1)
151 W !!,"Enter a future cutoff date/time now after which no remote requests by"
152 W !,"non-VistA HL7 team message recipients will be honored."
153 W !!,"Defaulting 'NOW + 7 days' below..."
154 W !
155G1 S CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2)) QUIT:'CUT "NO" ;->
156 I CUT<FUTURE D G G1 ;->
157 . W " enter time one hour or more in future..."
158 S LICENSE=$$CODE
159 W !!,"License# ",IOINHI,LICENSE,IOINORM," generated..."
160 Q "SET^"_CUT_U_LICENSE
161 ;
162CODE() ; Return license code...
163 N CODE,EX,NOP,TYPE
164 F EX=39,44,95,96 S EX(EX)=""
165 S CODE="",NOP=0
166 F EX=1:1:6 D
167 . S TYPE=$P("A^P",U,$R(2)+1)
168 . I EX=6,NOP=0 S TYPE="P" ; Must be at least one punctuation
169 . I TYPE="P" S NOP=NOP+1
170 . S:NOP>1 TYPE="A"
171 . S CODE=CODE_$$RNO(TYPE)
172 . I EX=3 S CODE=CODE_"-"
173 Q CODE
174 ;
175RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
176 ; NOP -- req
177 N NO,OK
178 F S NO=$R(89)+33 D Q:OK
179 . S OK=0
180 . I $D(EX(NO)) QUIT ;-> Is it in exclusion list?
181 . I TYPE="A" D QUIT ;-> Is it an alpha character
182 . . I $$ALPHA(NO) S OK=1
183 . I '$$ALPHA(NO) S OK=1 ; Need punctuation...
184 Q $C(NO)
185 ;
186ALPHA(NO) ; Is it ALPHA character?
187 N X
188 S X=$A($$UP^XLFSTR($C(NO))) QUIT:X>64&(X<91) 1 ;->
189 Q ""
190 ;
191ASKDIR(CHOICES,DEFAULT) ; Ask user what to do...
192 ; CODE,CODEXP,EXPNOW -- req
193 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,HOLD,PCE,TXT,X,Y
194 S DIR(0)="S^",DIR("A")="Select ACTION"
195 F PCE=1:1:$L(CHOICES,"~") D
196 . S TXT=$P(CHOICES,"~",+PCE) QUIT:TXT']"" ;->
197 . S TAG=$P(TXT,U),PMT=$P(TXT,U,2)
198 . S DIR(0)=DIR(0)_$S(DIR(0)'="S^":";",1:"")_PCE_":"_PMT
199 . S HOLD(PCE)=TAG
200 QUIT:DIR(0)="S^" "" ;->
201 I $G(DEFAULT)]"" S DIR("B")=DEFAULT
202 D ^DIR
203 S X=$G(HOLD(+Y)) QUIT:X]"" X ;->
204 Q ""
205 ;
206EOR ;HLEVSRV3 - Event Monitor SERVER ;5/16/03 14:42
Note: See TracBrowser for help on using the repository browser.