HLEVSRV4 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
LICEXT ; Change license date... (Resets CODEXP,EXPNOW)
N CUT
W !
S CUT=$$ASKDATE^HLEVAPI2("Enter NEW CUTOFF DATE/TIME","EXT")
I CUT'?7N1"."1.N W " no action taken..." QUIT ;->
S $P(^XTMP(XTMP,"CODE"),U)=CUT
S ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
S ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
W !!,"The current license has been changed to "
W $$FMTE^XLFDT(CUT),"..."
S CODEXP=CUT,EXPNOW=$S(CUT>NOW:0,1:1)
D SETLIC^HLEVSRV3(CODEXP_U_CODE)
Q
;
LICUSER ; Enter new users now...
; IOINHI,IOINORM -- req
N POSX,USER
;
W !!,"Enter the email address of the recipient(s). (Enter the address of an"
W !,"existing user and they will be removed.)"
W !!,IOINHI,"Hint:",IOINORM," "
S POSX=8
W "You may enter ""something"" that is less exact than the complete"
W !,?POSX,"email address and not compromise security. For example, if"
W !,?POSX,"the remote requester is named 'John Doe' and will be sending"
W !,?POSX,"requests from the Buffalo VAMC, you still might not know"
W !,?POSX,"the exact email address to enter. (E.g., Should you enter"
W !,?POSX,"'JOHN.DOE@DOMAIN.EXT' or 'DOE.JOHN@BUFFALO.DOMAIN.EXT'?) And, this"
W !,?POSX,"is why it is often advantageous to enter something like"
W !,?POSX,"'DOE@BUFFALO' and also 'DOE@DOMAIN.EXT'. When a remote "
W !,?POSX,"request is received, as long as 'DOE' is in the sender's"
W !,?POSX,"name, and either 'BUFFALO' or 'DOMAIN.EXT' is in the"
W !,?POSX,"address, it will be honored."
W !
;
F D QUIT:USER']""
. S USER=$$FT^HLEVSRV2("Enter REMOTE ADDRESS","","O")
. I USER']""!(USER[U) S USER="" QUIT ;->
. I USER'?1.E1"@"1.E D QUIT ;->
. . W !!,?5,"No action taken! (Use 'NAME@ADDRESS' format.)"
. . W !
. S USER=$$UP^XLFSTR(USER)
. I $D(^XTMP(XTMP,"USER",USER)) D QUIT ;->
. . KILL ^XTMP(XTMP,"USER",USER)
. . W " removed..."
. S ^XTMP(XTMP,"USER",USER)=$$NOW^XLFDT_U_$G(DUZ)
. W " added..."
Q
;
LICNEW ; Create new license... (Creates CODE,CODEXP,EXPNOW)
;
I $G(^XTMP(XTMP,"CODE"))]"" D I '$$YN^HLCSRPT4("Continue","No") W " no action taken..." QUIT ;->
. W !!,IOINHI,"Warning!!",IOINORM
. W " The current license, along with all licensed requesters, will"
. W " be deleted if you continue."
. W !
;
S (CODEXP,EXPNOW)="",CODE=$$CODE^HLEVSRV3
W !!,"License '",IOINHI,CODE,IOINORM,"' will be used after you enter cutoff date..."
W !!,"Defaulting 'NOW + 7 days' below..."
W !
S CODEXP=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$P($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2))
I CODEXP'?7N1"."1.N S (CODE,CODEXP,EXPNOW)="" QUIT ;->
; Accept any date. For user will have opportunity to change later.
S EXPNOW=$S(CODEXP<NOW:1,1:0) ; Is license expired?
D SETLIC^HLEVSRV3(CODEXP_U_CODE)
;
Q
;
LICAN ; Cancel current license...
; XTMP -- req
;
; If no license exists...
I '$D(^XTMP(XTMP)) D QUIT ;->
. W !,"No license exists..."
;
W !!,"If you cancel license, the code and all requesters will be removed!"
W !
I '$$YN^HLCSRPT4("OK to cancel license","No") D QUIT ;->
. W " no action taken..."
;
KILL ^XTMP(XTMP)
W " license canceled..."
S (CODE,CODEXP,EXPNOW)=""
;
Q
;
CHKLIC(CODEXM,FROM) ; Called by server action to see if passed in license
; matches current license. If so, data will be returned to
; requester. If not, a refusal email will be returned to XMFROM.
N OXMZ,OXTMP
;
S OXMZ=$G(XMZ),OXTMP=$G(XTMP)
;
N CODE,CUT,NOW,XTMP
;
S XTMP="HLEV REMOTE LICENSE",NOW=$$NOW^XLFDT
S CODE=$G(^XTMP(XTMP,"CODE")),CUT=+CODE,CODE=$P(CODE,U,2,999)
;
; If no requester known...
I $G(XMFROM)']"" D QUIT ;->
. D REFUSE("requester unknown.")
;
; If no code exists...
I CODE']"" D QUIT ;->
. D REFUSE("no license exists.")
;
; License has expired...
I CUT<NOW D REFUSE("the current license has expired.") QUIT ;->
;
; Incorrect code sent by remote requester...
I CODEXM'=CODE D REFUSE("incorrect code received.") QUIT ;->
;
; Is remote requester licensed?
I '$$LICENSED($G(XMFROM)) D QUIT ;->
. D REFUSE("Requester is not licensed.")
;
; Set XMY so report returned to remote requester...
I $G(XMFROM)]"" S XMY(XMFROM)=""
;
D RECXTMP("Request# "_XMZ_" from "_$G(XMFROM)_" honored. ["_OXTMP_"]")
;
Q
;
LICENSED(FROM) ; Is requester licensed?
N OK,USER
S FROM=$$UP^XLFSTR(FROM)
S ADDR=$P(FROM,"@",2) QUIT:ADDR']"" "" ;->
S FROM=$P(FROM,"@") QUIT:FROM']"" "" ;->
S OK=0,USER=""
F S USER=$O(^XTMP(XTMP,"USER",USER)) Q:USER']""!(OK) D
. S FROM(1)=$P(USER,"@"),ADDR(1)=$P(USER,"@",2)
. QUIT:FROM'[FROM(1) ;-> License NAME not in XMFROM
. QUIT:ADDR'[ADDR(1) ;-> License ADDR not in XMFROM
. S OK=1
Q $S(OK:1,1:"")
;
REFUSE(REA) ; Send refusal email back to remote requester...
; XMFROM,XTMP -- req
N HOLD,NO,TEXT,XMDUZ,XMSUB,XMTEXT
;
D RECXTMP("Refused ("_REA_") Request# "_$G(XMZ)_" from "_$G(XMFROM))
;
N XMZ
S XMDUZ=.5,XMSUB="HL7 Remote Request Refusal: "_$G(XMFROM)
S XMTEXT="HOLD("
;
D MAILADD("The following remote request for VistA HL7 data has been refused.")
D MAILADD("Details are included below."),MAILADD("")
D MAILADD(" Requester: "_$G(XMFROM))
D MAILADD(" Message#: "_$G(OXMZ))
D MAILADD(" Reason: "_REA)
;
S XMY("HL7SystemMonitoring@domain.ext")=""
I $G(XMFROM)]"" S XMY(XMFROM)=""
;
D ^XMD
;
QUIT
;
MAILADD(T) S NO=$O(HOLD(":"),-1)+1,HOLD(NO)=T
Q
;
RECXTMP(TXT) ; Record in ^XTMP for remote requests...
; XTMP -- req
S NO=$O(^XTMP(XTMP,"REQ",":"),-1)+1
S ^XTMP(XTMP,"REQ",+NO)=TXT
Q
;
EOR ;HLEVSRV4 - Event Monitor SERVER ;5/16/03 14:42
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLEVSRV4 5899 printed Nov 22, 2024@17:08:05 Page 2
HLEVSRV4 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
LICEXT ; Change license date... (Resets CODEXP,EXPNOW)
+1 NEW CUT
+2 WRITE !
+3 SET CUT=$$ASKDATE^HLEVAPI2("Enter NEW CUTOFF DATE/TIME","EXT")
+4 ;->
IF CUT'?7N1"."1.N
WRITE " no action taken..."
QUIT
+5 SET $PIECE(^XTMP(XTMP,"CODE"),U)=CUT
+6 SET ^XTMP(XTMP,0)=$$FMADD^XLFDT(CUT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Remote Request License"
+7 SET ^XTMP(XTMP,"USER")=$$NOW^XLFDT_U_DUZ
+8 WRITE !!,"The current license has been changed to "
+9 WRITE $$FMTE^XLFDT(CUT),"..."
+10 SET CODEXP=CUT
SET EXPNOW=$SELECT(CUT>NOW:0,1:1)
+11 DO SETLIC^HLEVSRV3(CODEXP_U_CODE)
+12 QUIT
+13 ;
LICUSER ; Enter new users now...
+1 ; IOINHI,IOINORM -- req
+2 NEW POSX,USER
+3 ;
+4 WRITE !!,"Enter the email address of the recipient(s). (Enter the address of an"
+5 WRITE !,"existing user and they will be removed.)"
+6 WRITE !!,IOINHI,"Hint:",IOINORM," "
+7 SET POSX=8
+8 WRITE "You may enter ""something"" that is less exact than the complete"
+9 WRITE !,?POSX,"email address and not compromise security. For example, if"
+10 WRITE !,?POSX,"the remote requester is named 'John Doe' and will be sending"
+11 WRITE !,?POSX,"requests from the Buffalo VAMC, you still might not know"
+12 WRITE !,?POSX,"the exact email address to enter. (E.g., Should you enter"
+13 WRITE !,?POSX,"'JOHN.DOE@DOMAIN.EXT' or 'DOE.JOHN@BUFFALO.DOMAIN.EXT'?) And, this"
+14 WRITE !,?POSX,"is why it is often advantageous to enter something like"
+15 WRITE !,?POSX,"'DOE@BUFFALO' and also 'DOE@DOMAIN.EXT'. When a remote "
+16 WRITE !,?POSX,"request is received, as long as 'DOE' is in the sender's"
+17 WRITE !,?POSX,"name, and either 'BUFFALO' or 'DOMAIN.EXT' is in the"
+18 WRITE !,?POSX,"address, it will be honored."
+19 WRITE !
+20 ;
+21 FOR
Begin DoDot:1
+22 SET USER=$$FT^HLEVSRV2("Enter REMOTE ADDRESS","","O")
+23 ;->
IF USER']""!(USER[U)
SET USER=""
QUIT
+24 ;->
IF USER'?1.E1"@"1.E
Begin DoDot:2
+25 WRITE !!,?5,"No action taken! (Use 'NAME@ADDRESS' format.)"
+26 WRITE !
End DoDot:2
QUIT
+27 SET USER=$$UP^XLFSTR(USER)
+28 ;->
IF $DATA(^XTMP(XTMP,"USER",USER))
Begin DoDot:2
+29 KILL ^XTMP(XTMP,"USER",USER)
+30 WRITE " removed..."
End DoDot:2
QUIT
+31 SET ^XTMP(XTMP,"USER",USER)=$$NOW^XLFDT_U_$G(DUZ)
+32 WRITE " added..."
End DoDot:1
if USER']""
QUIT
+33 QUIT
+34 ;
LICNEW ; Create new license... (Creates CODE,CODEXP,EXPNOW)
+1 ;
+2 ;->
IF $GET(^XTMP(XTMP,"CODE"))]""
Begin DoDot:1
+3 WRITE !!,IOINHI,"Warning!!",IOINORM
+4 WRITE " The current license, along with all licensed requesters, will"
+5 WRITE " be deleted if you continue."
+6 WRITE !
End DoDot:1
IF '$$YN^HLCSRPT4("Continue","No")
WRITE " no action taken..."
QUIT
+7 ;
+8 SET (CODEXP,EXPNOW)=""
SET CODE=$$CODE^HLEVSRV3
+9 WRITE !!,"License '",IOINHI,CODE,IOINORM,"' will be used after you enter cutoff date..."
+10 WRITE !!,"Defaulting 'NOW + 7 days' below..."
+11 WRITE !
+12 SET CODEXP=$$ASKDATE^HLEVAPI2("Enter CUTOFF DATE","EXT",$PIECE($$FMTE^XLFDT(+$$FMADD^XLFDT($$NOW^XLFDT,7)),":",1,2))
+13 ;->
IF CODEXP'?7N1"."1.N
SET (CODE,CODEXP,EXPNOW)=""
QUIT
+14 ; Accept any date. For user will have opportunity to change later.
+15 ; Is license expired?
SET EXPNOW=$SELECT(CODEXP<NOW:1,1:0)
+16 DO SETLIC^HLEVSRV3(CODEXP_U_CODE)
+17 ;
+18 QUIT
+19 ;
LICAN ; Cancel current license...
+1 ; XTMP -- req
+2 ;
+3 ; If no license exists...
+4 ;->
IF '$DATA(^XTMP(XTMP))
Begin DoDot:1
+5 WRITE !,"No license exists..."
End DoDot:1
QUIT
+6 ;
+7 WRITE !!,"If you cancel license, the code and all requesters will be removed!"
+8 WRITE !
+9 ;->
IF '$$YN^HLCSRPT4("OK to cancel license","No")
Begin DoDot:1
+10 WRITE " no action taken..."
End DoDot:1
QUIT
+11 ;
+12 KILL ^XTMP(XTMP)
+13 WRITE " license canceled..."
+14 SET (CODE,CODEXP,EXPNOW)=""
+15 ;
+16 QUIT
+17 ;
CHKLIC(CODEXM,FROM) ; Called by server action to see if passed in license
+1 ; matches current license. If so, data will be returned to
+2 ; requester. If not, a refusal email will be returned to XMFROM.
+3 NEW OXMZ,OXTMP
+4 ;
+5 SET OXMZ=$GET(XMZ)
SET OXTMP=$GET(XTMP)
+6 ;
+7 NEW CODE,CUT,NOW,XTMP
+8 ;
+9 SET XTMP="HLEV REMOTE LICENSE"
SET NOW=$$NOW^XLFDT
+10 SET CODE=$GET(^XTMP(XTMP,"CODE"))
SET CUT=+CODE
SET CODE=$PIECE(CODE,U,2,999)
+11 ;
+12 ; If no requester known...
+13 ;->
IF $GET(XMFROM)']""
Begin DoDot:1
+14 DO REFUSE("requester unknown.")
End DoDot:1
QUIT
+15 ;
+16 ; If no code exists...
+17 ;->
IF CODE']""
Begin DoDot:1
+18 DO REFUSE("no license exists.")
End DoDot:1
QUIT
+19 ;
+20 ; License has expired...
+21 ;->
IF CUT<NOW
DO REFUSE("the current license has expired.")
QUIT
+22 ;
+23 ; Incorrect code sent by remote requester...
+24 ;->
IF CODEXM'=CODE
DO REFUSE("incorrect code received.")
QUIT
+25 ;
+26 ; Is remote requester licensed?
+27 ;->
IF '$$LICENSED($GET(XMFROM))
Begin DoDot:1
+28 DO REFUSE("Requester is not licensed.")
End DoDot:1
QUIT
+29 ;
+30 ; Set XMY so report returned to remote requester...
+31 IF $GET(XMFROM)]""
SET XMY(XMFROM)=""
+32 ;
+33 DO RECXTMP("Request# "_XMZ_" from "_$GET(XMFROM)_" honored. ["_OXTMP_"]")
+34 ;
+35 QUIT
+36 ;
LICENSED(FROM) ; Is requester licensed?
+1 NEW OK,USER
+2 SET FROM=$$UP^XLFSTR(FROM)
+3 ;->
SET ADDR=$PIECE(FROM,"@",2)
if ADDR']""
QUIT ""
+4 ;->
SET FROM=$PIECE(FROM,"@")
if FROM']""
QUIT ""
+5 SET OK=0
SET USER=""
+6 FOR
SET USER=$ORDER(^XTMP(XTMP,"USER",USER))
if USER']""!(OK)
QUIT
Begin DoDot:1
+7 SET FROM(1)=$PIECE(USER,"@")
SET ADDR(1)=$PIECE(USER,"@",2)
+8 ;-> License NAME not in XMFROM
if FROM'[FROM(1)
QUIT
+9 ;-> License ADDR not in XMFROM
if ADDR'[ADDR(1)
QUIT
+10 SET OK=1
End DoDot:1
+11 QUIT $SELECT(OK:1,1:"")
+12 ;
REFUSE(REA) ; Send refusal email back to remote requester...
+1 ; XMFROM,XTMP -- req
+2 NEW HOLD,NO,TEXT,XMDUZ,XMSUB,XMTEXT
+3 ;
+4 DO RECXTMP("Refused ("_REA_") Request# "_$GET(XMZ)_" from "_$GET(XMFROM))
+5 ;
+6 NEW XMZ
+7 SET XMDUZ=.5
SET XMSUB="HL7 Remote Request Refusal: "_$GET(XMFROM)
+8 SET XMTEXT="HOLD("
+9 ;
+10 DO MAILADD("The following remote request for VistA HL7 data has been refused.")
+11 DO MAILADD("Details are included below.")
DO MAILADD("")
+12 DO MAILADD(" Requester: "_$GET(XMFROM))
+13 DO MAILADD(" Message#: "_$GET(OXMZ))
+14 DO MAILADD(" Reason: "_REA)
+15 ;
+16 SET XMY("HL7SystemMonitoring@domain.ext")=""
+17 IF $GET(XMFROM)]""
SET XMY(XMFROM)=""
+18 ;
+19 DO ^XMD
+20 ;
+21 QUIT
+22 ;
MAILADD(T) SET NO=$ORDER(HOLD(":"),-1)+1
SET HOLD(NO)=T
+1 QUIT
+2 ;
RECXTMP(TXT) ; Record in ^XTMP for remote requests...
+1 ; XTMP -- req
+2 SET NO=$ORDER(^XTMP(XTMP,"REQ",":"),-1)+1
+3 SET ^XTMP(XTMP,"REQ",+NO)=TXT
+4 QUIT
+5 ;
EOR ;HLEVSRV4 - Event Monitor SERVER ;5/16/03 14:42
