source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLEVSRV4.m@ 1259

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1HLEVSRV4 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4LICEXT ; Change license date... (Resets CODEXP,EXPNOW)
5 N CUT
6 W !
7 S CUT=$$ASKDATE^HLEVAPI2("Enter NEW CUTOFF DATE/TIME","EXT")
8 I CUT'?7N1"."1.N W " no action taken..." QUIT ;->
9 S $P(^XTMP(XTMP,"CODE"),U)=CUT
10 S ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
11 S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
12 W !!,"The current license has been changed to "
13 W $$FMTE^XLFDT(CUT),"..."
14 S CODEXP=CUT,EXPNOW=$S(CUT>NOW:0,1:1)
15 D SETLIC^HLEVSRV3(CODEXP_U_CODE)
16 Q
17 ;
18LICUSER ; Enter new users now...
19 ; IOINHI,IOINORM -- req
20 N POSX,USER
21 ;
22 W !!,"Enter the email address of the recipient(s). (Enter the address of an"
23 W !,"existing user and they will be removed.)"
24 W !!,IOINHI,"Hint:",IOINORM," "
25 S POSX=8
26 W "You may enter ""something"" that is less exact than the complete"
27 W !,?POSX,"email address and not compromise security. For example, if"
28 W !,?POSX,"the remote requester is named 'John Doe' and will be sending"
29 W !,?POSX,"requests from the Buffalo VAMC, you still might not know"
30 W !,?POSX,"the exact email address to enter. (E.g., Should you enter"
31 W !,?POSX,"'JOHN.DOE@MED.VA.GOV' or 'DOE.JOHN@BUFFALO.VA.GOV'?) And, this"
32 W !,?POSX,"is why it is often advantageous to enter something like"
33 W !,?POSX,"'DOE@BUFFALO' and also 'DOE@MED.VA.GOV'. When a remote "
34 W !,?POSX,"request is received, as long as 'DOE' is in the sender's"
35 W !,?POSX,"name, and either 'BUFFALO' or 'MED.VA.GOV' is in the"
36 W !,?POSX,"address, it will be honored."
37 W !
38 ;
39 F D QUIT:USER']""
40 . S USER=$$FT^HLEVSRV2("Enter REMOTE ADDRESS","","O")
41 . I USER']""!(USER[U) S USER="" QUIT ;->
42 . I USER'?1.E1"@"1.E D QUIT ;->
43 . . W !!,?5,"No action taken! (Use 'NAME@ADDRESS' format.)"
44 . . W !
45 . S USER=$$UP^XLFSTR(USER)
46 . I $D(^XTMP(XTMP,"USER",USER)) D QUIT ;->
47 . . KILL ^XTMP(XTMP,"USER",USER)
48 . . W " removed..."
49 . S ^XTMP(XTMP,"USER",USER)=$$NOW^XLFDT_U_$G(DUZ)
50 . W " added..."
51 Q
52 ;
53LICNEW ; Create new license... (Creates CODE,CODEXP,EXPNOW)
54 ;
55 I $G(^XTMP(XTMP,"CODE"))]"" D I '$$YN^HLCSRPT4("Continue","No") W " no action taken..." QUIT ;->
56 . W !!,IOINHI,"Warning!!",IOINORM
57 . W " The current license, along with all licensed requesters, will"
58 . W " be deleted if you continue."
59 . W !
60 ;
61 S (CODEXP,EXPNOW)="",CODE=$$CODE^HLEVSRV3
62 W !!,"License '",IOINHI,CODE,IOINORM,"' will be used after you enter cutoff date..."
63 W !!,"Defaulting 'NOW + 7 days' below..."
64 W !
65 S CODEXP=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2))
66 I CODEXP'?7N1"."1.N S (CODE,CODEXP,EXPNOW)="" QUIT ;->
67 ; Accept any date. For user will have opportunity to change later.
68 S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
69 D SETLIC^HLEVSRV3(CODEXP_U_CODE)
70 ;
71 Q
72 ;
73LICAN ; Cancel current license...
74 ; XTMP -- req
75 ;
76 ; If no license exists...
77 I '$D(^XTMP(XTMP)) D QUIT ;->
78 . W !,"No license exists..."
79 ;
80 W !!,"If you cancel license, the code and all requesters will be removed!"
81 W !
82 I '$$YN^HLCSRPT4("OK to cancel license","No") D QUIT ;->
83 . W " no action taken..."
84 ;
85 KILL ^XTMP(XTMP)
86 W " license canceled..."
87 S (CODE,CODEXP,EXPNOW)=""
88 ;
89 Q
90 ;
91CHKLIC(CODEXM,FROM) ; Called by server action to see if passed in license
92 ; matches current license. If so, data will be returned to
93 ; requester. If not, a refusal email will be returned to XMFROM.
94 N OXMZ,OXTMP
95 ;
96 S OXMZ=$G(XMZ),OXTMP=$G(XTMP)
97 ;
98 N CODE,CUT,NOW,XTMP
99 ;
100 S XTMP="HLEV REMOTE LICENSE",NOW=$$NOW^XLFDT
101 S CODE=$G(^XTMP(XTMP,"CODE")),CUT=+CODE,CODE=$P(CODE,U,2,999)
102 ;
103 ; If no requester known...
104 I $G(XMFROM)']"" D QUIT ;->
105 . D REFUSE("requester unknown.")
106 ;
107 ; If no code exists...
108 I CODE']"" D QUIT ;->
109 . D REFUSE("no license exists.")
110 ;
111 ; License has expired...
112 I CUT<NOW D REFUSE("the current license has expired.") QUIT ;->
113 ;
114 ; Incorrect code sent by remote requester...
115 I CODEXM'=CODE D REFUSE("incorrect code received.") QUIT ;->
116 ;
117 ; Is remote requester licensed?
118 I '$$LICENSED($G(XMFROM)) D QUIT ;->
119 . D REFUSE("Requester is not licensed.")
120 ;
121 ; Set XMY so report returned to remote requester...
122 I $G(XMFROM)]"" S XMY(XMFROM)=""
123 ;
124 D RECXTMP("Request# "_XMZ_" from "_$G(XMFROM)_" honored. ["_OXTMP_"]")
125 ;
126 Q
127 ;
128LICENSED(FROM) ; Is requester licensed?
129 N OK,USER
130 S FROM=$$UP^XLFSTR(FROM)
131 S ADDR=$P(FROM,"@",2) QUIT:ADDR']"" "" ;->
132 S FROM=$P(FROM,"@") QUIT:FROM']"" "" ;->
133 S OK=0,USER=""
134 F S USER=$O(^XTMP(XTMP,"USER",USER)) Q:USER']""!(OK) D
135 . S FROM(1)=$P(USER,"@"),ADDR(1)=$P(USER,"@",2)
136 . QUIT:FROM'[FROM(1) ;-> License NAME not in XMFROM
137 . QUIT:ADDR'[ADDR(1) ;-> License ADDR not in XMFROM
138 . S OK=1
139 Q $S(OK:1,1:"")
140 ;
141REFUSE(REA) ; Send refusal email back to remote requester...
142 ; XMFROM,XTMP -- req
143 N HOLD,NO,TEXT,XMDUZ,XMSUB,XMTEXT
144 ;
145 D RECXTMP("Refused ("_REA_") Request# "_$G(XMZ)_" from "_$G(XMFROM))
146 ;
147 N XMZ
148 S XMDUZ=.5,XMSUB="HL7 Remote Request Refusal: "_$G(XMFROM)
149 S XMTEXT="HOLD("
150 ;
151 D MAILADD("The following remote request for VistA HL7 data has been refused.")
152 D MAILADD("Details are included below."),MAILADD("")
153 D MAILADD(" Requester: "_$G(XMFROM))
154 D MAILADD(" Message#: "_$G(OXMZ))
155 D MAILADD(" Reason: "_REA)
156 ;
157 S XMY("HL7SystemMonitoring@med.va.gov")=""
158 I $G(XMFROM)]"" S XMY(XMFROM)=""
159 ;
160 D ^XMD
161 ;
162 QUIT
163 ;
164MAILADD(T) S NO=$O(HOLD(":"),-1)+1,HOLD(NO)=T
165 Q
166 ;
167RECXTMP(TXT) ; Record in ^XTMP for remote requests...
168 ; XTMP -- req
169 S NO=$O(^XTMP(XTMP,"REQ",":"),-1)+1
170 S ^XTMP(XTMP,"REQ",+NO)=TXT
171 Q
172 ;
173EOR ;HLEVSRV4 - Event Monitor SERVER ;5/16/03 14:42
Note: See TracBrowser for help on using the repository browser.