HLEVSRV3 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
OPENMAIL ; Grant license to remote requesters...
N ANS,CODE,CODEXP,EXPNOW,IOINHI,IOINORM,NOW,X,XTMP
;
S XTMP="HLEV REMOTE LICENSE"
S X="IOINHI;IOINORM" D ENDR^%ZISS
S NOW=$$NOW^XLFDT
;
D HDM
D EXM
F Q:($Y+3)>IOSL W !
QUIT:$$BTE^HLCSMON("Press RETURN to continue, or '^' to exit... ")
;
D HDM
;
S (CODE,CODEXP,EXPNOW)="" ; Default to no current license...
;
; Current license? Show details of current (maybe expired) license.
S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D
. S CODEXP=$P(CODE,U),CODE=$P(CODE,U,2)
. S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
. D SHOWLIC
;
I CODE']"" W !!,"No current license exists..."
;
; OK. License and expiration date exist...
S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
;
F D QUIT:ACTION="EXIT"
. N STR
. S STR=$S($D(^XTMP(XTMP)):1,1:0)
. 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"
. I 'STR S STR(1)="LICNEW^Create new license~EXIT^Exit"
. S ACTION=$$ASKDIR(STR(1),$$DEFAULT)
. S:ACTION']"" ACTION="EXIT"
. QUIT:ACTION="EXIT" ;->
. S ACTION=ACTION_"^HLEVSRV4"
. D @ACTION
. D SHOWLIC
;
I '$D(^XTMP(XTMP)) QUIT ;->
;
I $O(^XTMP(XTMP,"USER",""))']"" D
. W !!,"No requesters have been created under this license. So, even thought a"
. W !,"license exists, no one can make use of the license. To enter requesters, you"
. W !,"must reinvoke this option and enter one or more requesters."
;
I EXPNOW W !!,"The current license is expired!"
;
I $O(^XTMP(XTMP,"USER",""))']""!(EXPNOW) D
. W !
. S X=$$BTE^HLCSMON("Press RETURN to exit...")
;
Q
;
DEFAULT() ; What would most users do under circumstances?
; CODE,CODEXP,EXPNOW,XTMP -- req
I CODE']""!('$D(^XTMP(XTMP))) QUIT "Create new license" ;->
I EXPNOW QUIT "Change cutoff date/time" ;->
I $O(^XTMP(XTMP,"USER",""))']"" QUIT "Add requesters" ;->
Q "Exit"
;
SHOWLIC ; Show license and expiration date...
; CODE,CODEXP,EXPNOW,IOINHI,IOINORM,XTMP -- req
N HOLD,NO,USER
;
I '$D(^XTMP(XTMP)) D QUIT ;->
. W !!,$$CJ^XLFSTR("---------------- No License Exists ----------------",IOM)
;
W !!,$$CJ^XLFSTR("---------------- Current License - "_CODE_" ["_$S(EXPNOW:IOINHI,1:"")_$$SDT^HLEVX001(CODEXP)_IOINORM_"] ----------------",IOM)
;
S NO=0,USER=""
F S USER=$O(^XTMP(XTMP,"USER",USER)) Q:USER']"" D
. S NO=NO+1,HOLD(USER)=""
;
I NO'>0 W !,$$CJ^XLFSTR("No current users exist!",IOM) QUIT ;->
;
W !,$$CJ^XLFSTR("----- Licensed Requesters ------",IOM)
S USER=""
F S USER=$O(HOLD(USER)) Q:USER']"" D
. W !,$$CJ^XLFSTR(USER,IOM)
;
Q
;
SETLIC(CODE) ; Set license...
; XTMP -- req
N CUT
S CUT=+CODE
;
KILL ^XTMP(XTMP) ; Remove all old data...
;
; Set vaporization date to 7 days after cutoff time...
S ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
;
S ^XTMP(XTMP,"CODE")=CODE ; Cutoff date/time ^ Code
S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
;
Q
;
HDM ; Header for option...
; IOINHI,IOINORM,XTMP -- req
N CODE,NOW
W @IOF,$$CJ^XLFSTR("Grant License to Remote Requesters",IOM)
S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D
. S CUT=+CODE,CODE=$P(CODE,U,2,999)
. I CUT<$$NOW^XLFDT D QUIT ;->
. . W !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_IOINHI_$$FMTE^XLFDT(CUT)_IOINORM,IOM+$L(IOINHI)+$L(IOINORM))
. W !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_$$FMTE^XLFDT(CUT),IOM)
W !,$$REPEAT^XLFSTR("=",IOM)
QUIT
;
EXM N I,T F I=1:1 S T=$T(EXM+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
;;Mailman server requests can be sent to your site requesting HL7 data be
;;returned to the VistA HL7 team. These requests are normally only sent to
;;the VistA HL7 team. However, from time to time, support personnel will have
;;legitimate need to retrieve critical VistA HL7 data. In order to receive
;;return data, anyone not on the VistA HL7 team needs a license. This option
;;will generate a license that must be communicated to those (not on the VistA
;;HL7 team) requesting remote query rights.
;;
;;Note: Notification of every remote server request is automatically sent to
;; the VistA HL7 team. And, this includes the messages sent remotely
;; to non-VistA HL7 recipients (using the license you are about to grant.)
QUIT
;
GRANT() ; Get date and license...
N CODE,CONT,CUT,FUTURE,LICENSE
;
S CODE=$G(^XTMP(XTMP,"CODE")) I CODE]"" D QUIT:'CONT "" ;->
. S CONT=1
. W !!,"License# ",IOINHI,$P(CODE,U,2),IOINORM," exists and has a cutoff time of ",$$FMTE^XLFDT($P(CODE,U)),"."
. W !
. I $$YN^HLCSRPT4("Terminate license now","No") D QUIT:'CONT ;->
. . KILL ^XTMP(XTMP)
. . W " done..."
. . S CONT=""
. W !
. QUIT:'$$YN^HLCSRPT4("Keep license and extend time","Yes") ;->
. W !!,"Defaulting 'NOW + 7 days' below..."
. W !
. S CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2)) QUIT:'CUT ;->
. S $P(^XTMP(XTMP,"CODE"),U)=CUT
. S ^XTMP(XTMP,0)=CUT_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
. S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
. W " updated..."
. S CONT=0
;
S FUTURE=$$FMADD^XLFDT($$NOW^XLFDT,0,1)
W !!,"Enter a future cutoff date/time now after which no remote requests by"
W !,"non-VistA HL7 team message recipients will be honored."
W !!,"Defaulting 'NOW + 7 days' below..."
W !
G1 S CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2)) QUIT:'CUT "NO" ;->
I CUT<FUTURE D G G1 ;->
. W " enter time one hour or more in future..."
S LICENSE=$$CODE
W !!,"License# ",IOINHI,LICENSE,IOINORM," generated..."
Q "SET^"_CUT_U_LICENSE
;
CODE() ; Return license code...
N CODE,EX,NOP,TYPE
F EX=39,44,95,96 S EX(EX)=""
S CODE="",NOP=0
F EX=1:1:6 D
. S TYPE=$P("A^P",U,$R(2)+1)
. I EX=6,NOP=0 S TYPE="P" ; Must be at least one punctuation
. I TYPE="P" S NOP=NOP+1
. S:NOP>1 TYPE="A"
. S CODE=CODE_$$RNO(TYPE)
. I EX=3 S CODE=CODE_"-"
Q CODE
;
RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
; NOP -- req
N NO,OK
F S NO=$R(89)+33 D Q:OK
. S OK=0
. I $D(EX(NO)) QUIT ;-> Is it in exclusion list?
. I TYPE="A" D QUIT ;-> Is it an alpha character
. . I $$ALPHA(NO) S OK=1
. I '$$ALPHA(NO) S OK=1 ; Need punctuation...
Q $C(NO)
;
ALPHA(NO) ; Is it ALPHA character?
N X
S X=$A($$UP^XLFSTR($C(NO))) QUIT:X>64&(X<91) 1 ;->
Q ""
;
ASKDIR(CHOICES,DEFAULT) ; Ask user what to do...
; CODE,CODEXP,EXPNOW -- req
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,HOLD,PCE,TXT,X,Y
S DIR(0)="S^",DIR("A")="Select ACTION"
F PCE=1:1:$L(CHOICES,"~") D
. S TXT=$P(CHOICES,"~",+PCE) QUIT:TXT']"" ;->
. S TAG=$P(TXT,U),PMT=$P(TXT,U,2)
. S DIR(0)=DIR(0)_$S(DIR(0)'="S^":";",1:"")_PCE_":"_PMT
. S HOLD(PCE)=TAG
QUIT:DIR(0)="S^" "" ;->
I $G(DEFAULT)]"" S DIR("B")=DEFAULT
D ^DIR
S X=$G(HOLD(+Y)) QUIT:X]"" X ;->
Q ""
;
EOR ;HLEVSRV3 - Event Monitor SERVER ;5/16/03 14:42
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLEVSRV3 7311 printed Oct 16, 2024@17:58:44 Page 2
HLEVSRV3 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
OPENMAIL ; Grant license to remote requesters...
+1 NEW ANS,CODE,CODEXP,EXPNOW,IOINHI,IOINORM,NOW,X,XTMP
+2 ;
+3 SET XTMP="HLEV REMOTE LICENSE"
+4 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+5 SET NOW=$$NOW^XLFDT
+6 ;
+7 DO HDM
+8 DO EXM
+9 FOR
if ($Y+3)>IOSL
QUIT
WRITE !
+10 if $$BTE^HLCSMON("Press RETURN to continue, or '^' to exit... ")
QUIT
+11 ;
+12 DO HDM
+13 ;
+14 ; Default to no current license...
SET (CODE,CODEXP,EXPNOW)=""
+15 ;
+16 ; Current license? Show details of current (maybe expired) license.
+17 SET CODE=$GET(^XTMP(XTMP,"CODE"))
IF CODE]""
Begin DoDot:1
+18 SET CODEXP=$PIECE(CODE,U)
SET CODE=$PIECE(CODE,U,2)
+19 ; Is license expired?
SET EXPNOW=$SELECT(CODEXP<NOW:1,1:0)
+20 DO SHOWLIC
End DoDot:1
+21 ;
+22 IF CODE']""
WRITE !!,"No current license exists..."
+23 ;
+24 ; OK. License and expiration date exist...
+25 ; Is license expired?
SET EXPNOW=$SELECT(CODEXP<NOW:1,1:0)
+26 ;
+27 FOR
Begin DoDot:1
+28 NEW STR
+29 SET STR=$SELECT($DATA(^XTMP(XTMP)):1,1:0)
+30 IF STR
SET STR(1)="LICEXT^Change cutoff date/time~LICUSER^Add requesters~LICNEW^Create new license"_$SELECT(CODE]"":" (and cancel old license)",1:"")_"~LICAN^Cancel current license~EXIT^Exit"
+31 IF 'STR
SET STR(1)="LICNEW^Create new license~EXIT^Exit"
+32 SET ACTION=$$ASKDIR(STR(1),$$DEFAULT)
+33 if ACTION']""
SET ACTION="EXIT"
+34 ;->
if ACTION="EXIT"
QUIT
+35 SET ACTION=ACTION_"^HLEVSRV4"
+36 DO @ACTION
+37 DO SHOWLIC
End DoDot:1
if ACTION="EXIT"
QUIT
+38 ;
+39 ;->
IF '$DATA(^XTMP(XTMP))
QUIT
+40 ;
+41 IF $ORDER(^XTMP(XTMP,"USER",""))']""
Begin DoDot:1
+42 WRITE !!,"No requesters have been created under this license. So, even thought a"
+43 WRITE !,"license exists, no one can make use of the license. To enter requesters, you"
+44 WRITE !,"must reinvoke this option and enter one or more requesters."
End DoDot:1
+45 ;
+46 IF EXPNOW
WRITE !!,"The current license is expired!"
+47 ;
+48 IF $ORDER(^XTMP(XTMP,"USER",""))']""!(EXPNOW)
Begin DoDot:1
+49 WRITE !
+50 SET X=$$BTE^HLCSMON("Press RETURN to exit...")
End DoDot:1
+51 ;
+52 QUIT
+53 ;
DEFAULT() ; What would most users do under circumstances?
+1 ; CODE,CODEXP,EXPNOW,XTMP -- req
+2 ;->
IF CODE']""!('$DATA(^XTMP(XTMP)))
QUIT "Create new license"
+3 ;->
IF EXPNOW
QUIT "Change cutoff date/time"
+4 ;->
IF $ORDER(^XTMP(XTMP,"USER",""))']""
QUIT "Add requesters"
+5 QUIT "Exit"
+6 ;
SHOWLIC ; Show license and expiration date...
+1 ; CODE,CODEXP,EXPNOW,IOINHI,IOINORM,XTMP -- req
+2 NEW HOLD,NO,USER
+3 ;
+4 ;->
IF '$DATA(^XTMP(XTMP))
Begin DoDot:1
+5 WRITE !!,$$CJ^XLFSTR("---------------- No License Exists ----------------",IOM)
End DoDot:1
QUIT
+6 ;
+7 WRITE !!,$$CJ^XLFSTR("---------------- Current License - "_CODE_" ["_$SELECT(EXPNOW:IOINHI,1:"")_$$SDT^HLEVX001(CODEXP)_IOINORM_"] ----------------",IOM)
+8 ;
+9 SET NO=0
SET USER=""
+10 FOR
SET USER=$ORDER(^XTMP(XTMP,"USER",USER))
if USER']""
QUIT
Begin DoDot:1
+11 SET NO=NO+1
SET HOLD(USER)=""
End DoDot:1
+12 ;
+13 ;->
IF NO'>0
WRITE !,$$CJ^XLFSTR("No current users exist!",IOM)
QUIT
+14 ;
+15 WRITE !,$$CJ^XLFSTR("----- Licensed Requesters ------",IOM)
+16 SET USER=""
+17 FOR
SET USER=$ORDER(HOLD(USER))
if USER']""
QUIT
Begin DoDot:1
+18 WRITE !,$$CJ^XLFSTR(USER,IOM)
End DoDot:1
+19 ;
+20 QUIT
+21 ;
SETLIC(CODE) ; Set license...
+1 ; XTMP -- req
+2 NEW CUT
+3 SET CUT=+CODE
+4 ;
+5 ; Remove all old data...
KILL ^XTMP(XTMP)
+6 ;
+7 ; Set vaporization date to 7 days after cutoff time...
+8 SET ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
+9 ;
+10 ; Cutoff date/time ^ Code
SET ^XTMP(XTMP,"CODE")=CODE
+11 SET ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
+12 ;
+13 QUIT
+14 ;
HDM ; Header for option...
+1 ; IOINHI,IOINORM,XTMP -- req
+2 NEW CODE,NOW
+3 WRITE @IOF,$$CJ^XLFSTR("Grant License to Remote Requesters",IOM)
+4 SET CODE=$GET(^XTMP(XTMP,"CODE"))
IF CODE]""
Begin DoDot:1
+5 SET CUT=+CODE
SET CODE=$PIECE(CODE,U,2,999)
+6 ;->
IF CUT<$$NOW^XLFDT
Begin DoDot:2
+7 WRITE !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_IOINHI_$$FMTE^XLFDT(CUT)_IOINORM,IOM+$LENGTH(IOINHI)+$LENGTH(IOINORM))
End DoDot:2
QUIT
+8 WRITE !,$$CJ^XLFSTR("License: "_CODE_" Cutoff: "_$$FMTE^XLFDT(CUT),IOM)
End DoDot:1
+9 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+10 QUIT
+11 ;
EXM NEW I,T
FOR I=1:1
SET T=$TEXT(EXM+I)
if T'[";;"
QUIT
WRITE !,$PIECE(T,";;",2,99)
+1 ;;Mailman server requests can be sent to your site requesting HL7 data be
+2 ;;returned to the VistA HL7 team. These requests are normally only sent to
+3 ;;the VistA HL7 team. However, from time to time, support personnel will have
+4 ;;legitimate need to retrieve critical VistA HL7 data. In order to receive
+5 ;;return data, anyone not on the VistA HL7 team needs a license. This option
+6 ;;will generate a license that must be communicated to those (not on the VistA
+7 ;;HL7 team) requesting remote query rights.
+8 ;;
+9 ;;Note: Notification of every remote server request is automatically sent to
+10 ;; the VistA HL7 team. And, this includes the messages sent remotely
+11 ;; to non-VistA HL7 recipients (using the license you are about to grant.)
+12 QUIT
+13 ;
GRANT() ; Get date and license...
+1 NEW CODE,CONT,CUT,FUTURE,LICENSE
+2 ;
+3 ;->
SET CODE=$GET(^XTMP(XTMP,"CODE"))
IF CODE]""
Begin DoDot:1
+4 SET CONT=1
+5 WRITE !!,"License# ",IOINHI,$PIECE(CODE,U,2),IOINORM," exists and has a cutoff time of ",$$FMTE^XLFDT($PIECE(CODE,U)),"."
+6 WRITE !
+7 ;->
IF $$YN^HLCSRPT4("Terminate license now","No")
Begin DoDot:2
+8 KILL ^XTMP(XTMP)
+9 WRITE " done..."
+10 SET CONT=""
End DoDot:2
if 'CONT
QUIT
+11 WRITE !
+12 ;->
if '$$YN^HLCSRPT4("Keep license and extend time","Yes")
QUIT
+13 WRITE !!,"Defaulting 'NOW + 7 days' below..."
+14 WRITE !
+15 ;->
SET CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$PIECE($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2))
if 'CUT
QUIT
+16 SET $PIECE(^XTMP(XTMP,"CODE"),U)=CUT
+17 SET ^XTMP(XTMP,0)=CUT_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
+18 SET ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
+19 WRITE " updated..."
+20 SET CONT=0
End DoDot:1
if 'CONT
QUIT ""
+21 ;
+22 SET FUTURE=$$FMADD^XLFDT($$NOW^XLFDT,0,1)
+23 WRITE !!,"Enter a future cutoff date/time now after which no remote requests by"
+24 WRITE !,"non-VistA HL7 team message recipients will be honored."
+25 WRITE !!,"Defaulting 'NOW + 7 days' below..."
+26 WRITE !
G1 ;->
SET CUT=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$PIECE($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2))
if 'CUT
QUIT "NO"
+1 ;->
IF CUT<FUTURE
Begin DoDot:1
+2 WRITE " enter time one hour or more in future..."
End DoDot:1
GOTO G1
+3 SET LICENSE=$$CODE
+4 WRITE !!,"License# ",IOINHI,LICENSE,IOINORM," generated..."
+5 QUIT "SET^"_CUT_U_LICENSE
+6 ;
CODE() ; Return license code...
+1 NEW CODE,EX,NOP,TYPE
+2 FOR EX=39,44,95,96
SET EX(EX)=""
+3 SET CODE=""
SET NOP=0
+4 FOR EX=1:1:6
Begin DoDot:1
+5 SET TYPE=$PIECE("A^P",U,$RANDOM(2)+1)
+6 ; Must be at least one punctuation
IF EX=6
IF NOP=0
SET TYPE="P"
+7 IF TYPE="P"
SET NOP=NOP+1
+8 if NOP>1
SET TYPE="A"
+9 SET CODE=CODE_$$RNO(TYPE)
+10 IF EX=3
SET CODE=CODE_"-"
End DoDot:1
+11 QUIT CODE
+12 ;
RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
+1 ; NOP -- req
+2 NEW NO,OK
+3 FOR
SET NO=$RANDOM(89)+33
Begin DoDot:1
+4 SET OK=0
+5 ;-> Is it in exclusion list?
IF $DATA(EX(NO))
QUIT
+6 ;-> Is it an alpha character
IF TYPE="A"
Begin DoDot:2
+7 IF $$ALPHA(NO)
SET OK=1
End DoDot:2
QUIT
+8 ; Need punctuation...
IF '$$ALPHA(NO)
SET OK=1
End DoDot:1
if OK
QUIT
+9 QUIT $CHAR(NO)
+10 ;
ALPHA(NO) ; Is it ALPHA character?
+1 NEW X
+2 ;->
SET X=$ASCII($$UP^XLFSTR($CHAR(NO)))
if X>64&(X<91)
QUIT 1
+3 QUIT ""
+4 ;
ASKDIR(CHOICES,DEFAULT) ; Ask user what to do...
+1 ; CODE,CODEXP,EXPNOW -- req
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,HOLD,PCE,TXT,X,Y
+3 SET DIR(0)="S^"
SET DIR("A")="Select ACTION"
+4 FOR PCE=1:1:$LENGTH(CHOICES,"~")
Begin DoDot:1
+5 ;->
SET TXT=$PIECE(CHOICES,"~",+PCE)
if TXT']""
QUIT
+6 SET TAG=$PIECE(TXT,U)
SET PMT=$PIECE(TXT,U,2)
+7 SET DIR(0)=DIR(0)_$SELECT(DIR(0)'="S^":";",1:"")_PCE_":"_PMT
+8 SET HOLD(PCE)=TAG
End DoDot:1
+9 ;->
if DIR(0)="S^"
QUIT ""
+10 IF $GET(DEFAULT)]""
SET DIR("B")=DEFAULT
+11 DO ^DIR
+12 ;->
SET X=$GET(HOLD(+Y))
if X]""
QUIT X
+13 QUIT ""
+14 ;
EOR ;HLEVSRV3 - Event Monitor SERVER ;5/16/03 14:42
