| [613] | 1 | HLEVSRV3 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | OPENMAIL ; 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 | ;
|
|---|
| 58 | DEFAULT() ; 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 | ;
|
|---|
| 65 | SHOWLIC ; 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 | ;
|
|---|
| 87 | SETLIC(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 | ;
|
|---|
| 102 | HDM ; 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 | ;
|
|---|
| 114 | EXM 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 | ;
|
|---|
| 128 | GRANT() ; 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 !
|
|---|
| 155 | G1 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 | ;
|
|---|
| 162 | CODE() ; 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 | ;
|
|---|
| 175 | RNO(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 | ;
|
|---|
| 186 | ALPHA(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 | ;
|
|---|
| 191 | ASKDIR(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 | ;
|
|---|
| 206 | EOR ;HLEVSRV3 - Event Monitor SERVER ;5/16/03 14:42
|
|---|
