Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLEVSRV4

HLEVSRV4.m

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