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

HLOASUB1.m

Go to the documentation of this file. 
  1. HLOASUB1 ;IRMFO-ALB/CJM - Subscription Registry (continued) ;03/24/2004  14:43
  1.  ;;1.6;HEALTH LEVEL SEVEN;**126**;Oct 13, 1995;
  1.  ;
  1. INDEX(IEN,PARMARY) ;
  1.  ;Description: This allows an application to build an index of its
  1.  ;subscriptions.  This is optional, but using this function allows the
  1.  ;application to easily find subscriptions without storing the ien.
  1.  ;
  1.  ;Input:
  1.  ;  IEN - ien of the entry in the Subscription Registry
  1.  ;  PARMARY - **pass by reference** an array of parameters with which to build the index.  The format is: PARMARY(1)=<first parameter>, PARMARY(2)=<second parameter>  If PARMARY(i)=null, the parameter will be translated to a single space.
  1.  ;Output:
  1.  ;  function returns 1 on success, 0 otherwise
  1.  ;  PARMARY - left undefined
  1.  ;
  1.  N OK S OK=0
  1.  D
  1.  .Q:'$G(IEN)
  1.  .N OWNER,INDEX,I
  1.  .S OWNER=$P($G(^HLD(779.4,IEN,0)),"^",2)
  1.  .Q:'$L(OWNER)
  1.  .Q:'$D(PARMARY)
  1.  .S INDEX="^HLD(779.4,""AH"",OWNER,"
  1.  .S I=0
  1.  .F  S I=$O(PARMARY(I)) Q:'I  S INDEX=INDEX_""""_$S($L(PARMARY(I)):PARMARY(I),1:" ")_""","
  1.  .S INDEX=$E(INDEX,1,$L(INDEX)-1)_")"
  1.  .S @INDEX=IEN
  1.  .S ^HLD(779.4,"AH KILL",IEN,""""_OWNER_""","_$P(INDEX,"^HLD(779.4,""AH"",OWNER,",2))=""
  1.  .S OK=1
  1.  K PARMARY
  1.  Q OK
  1.  ;
  1. KILLAH(IEN) ;kills the AH x~ref on file 779.4 for a particular subscription registry entry=ien
  1.  Q:'$G(IEN)
  1.  N NEXT,LOCATION
  1.  S NEXT=""
  1.  F  S NEXT=$O(^HLD(779.4,"AH KILL",IEN,NEXT)) Q:'$L(NEXT)  D
  1.  .S LOCATION="^HLD(779.4,""AH"","_NEXT
  1.  .K @LOCATION
  1.  K ^HLD(779.4,"AH KILL",IEN)
  1.  Q
  1.  ;
  1. FIND(OWNER,PARMARY) ;
  1.  ;Description: This allows an application to find a subscription
  1.  ;list.  The application must maintain a private index in order to
  1.  ;utilize this function, via $$INDEX^HLOASUB()
  1.  ;
  1.  ;Input:
  1.  ;  OWNER - owning application name
  1.  ;  PARMARY  **pass by reference** an array of parameters with which the index was built.  The format is: PARMARY(1)=<first parameter>, PARMARY(2)=<second parameter>  If PARMARY(i)=null, the parameter will be translated to a single space.
  1.  ;Output:
  1.  ;  function returns the ien of the subscription list if found, 0 otherwise
  1.  ; PARMARY - left undefined
  1.  ;
  1.  N OK S OK=0
  1.  ;
  1.  D
  1.  .Q:'$D(PARMARY)
  1.  .Q:'$L($G(OWNER))
  1.  .N INDEX,I
  1.  .S INDEX="^HLD(779.4,""AH"",OWNER,"
  1.  .S I=0
  1.  .F  S I=$O(PARMARY(I)) Q:'I  S INDEX=INDEX_""""_$S($L(PARMARY(I)):PARMARY(I),1:" ")_""","
  1.  .S INDEX=$E(INDEX,1,$L(INDEX)-1)_")"
  1.  .S OK=+$G(@INDEX)
  1.  K PARMARY
  1.  Q OK
  1.  ;
  1. UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
  1.  ; Input:
  1.  ;   FILE - File or sub-file number
  1.  ;   DA - Traditional DA array, with same meaning.
  1.  ;            Pass by reference.
  1.  ;   DATA - Data array to file (pass by reference)
  1.  ;          Format: DATA(<field #>)=<value>
  1.  ;
  1.  ; Output:
  1.  ;  Function Value -     0=error and 1=no error
  1.  ;  ERROR - optional error message - if needed, pass by reference
  1.  ;
  1.  ; Example: To update a record in subfile 2.0361 in record with ien=353,
  1.  ;          subrecord ien=68, with the field .01 value = 21:
  1.  ;    S DATA(.01)=21,DA=68,DA(1)=353 I $$UPDS(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
  1.  ;
  1.  N FDA,FIELD,IENS,ERRORS
  1.  ;
  1.  ;IENS - Internal Entry Number String defined by FM
  1.  ;FDA - the FDA array as defined by FM
  1.  ;
  1.  I '$G(DA) S ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED" Q 0
  1.  S IENS=$$IENS^DILF(.DA)
  1.  S FIELD=0
  1.  F  S FIELD=$O(DATA(FIELD)) Q:'FIELD  D
  1.  .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
  1.  D FILE^DIE("","FDA","ERRORS(1)")
  1.  I +$G(DIERR) D
  1.  .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
  1.  E  D
  1.  .S ERROR=""
  1.  ;
  1.  D CLEAN^DILF
  1.  Q $S(+$G(DIERR):0,1:1)
  1.  ;
  1. ADD(FILE,DA,DATA,ERROR,IEN) ;
  1.  ;Description: Creates a new record and files the data.
  1.  ; Input:
  1.  ;   FILE - File or sub-file number
  1.  ;   DA - Traditional FileMan DA array with same
  1.  ;            meaning. Pass by reference.  Only needed if adding to a
  1.  ;            subfile.
  1.  ;   DATA - Data array to file, pass by reference
  1.  ;          Format: DATA(<field #>)=<value>
  1.  ;   IEN - internal entry number to use (optional)
  1.  ;
  1.  ; Output:
  1.  ;   Function Value - If no error then it returns the ien of the created record, else returns NULL.
  1.  ;  DA - returns the ien of the new record, NULL if none created.  If needed, pass by reference.
  1.  ;  ERROR - optional error message - if needed, pass by reference
  1.  ;
  1.  ; Example: To add a record in subfile 2.0361 in the record with ien=353
  1.  ;          with the field .01 value = 21:
  1.  ;  S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
  1.  ;
  1.  ; Example: If creating a record not in a subfile, would look like this:
  1.  ;          S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
  1.  ;
  1.  N FDA,FIELD,IENA,IENS,ERRORS
  1.  ;
  1.  ;IENS - Internal Entry Number String defined by FM
  1.  ;IENA - the Internal Entry Number Array defined by FM
  1.  ;FDA - the FDA array defined by FM
  1.  ;IEN - the ien of the new record
  1.  ;
  1.  S DA="+1"
  1.  S IENS=$$IENS^DILF(.DA)
  1.  S FIELD=0
  1.  F  S FIELD=$O(DATA(FIELD)) Q:'FIELD  D
  1.  .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
  1.  I $G(IEN) S IENA(1)=IEN
  1.  D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
  1.  I +$G(DIERR) D
  1.  .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
  1.  .S IEN=""
  1.  E  D
  1.  .S IEN=IENA(1)
  1.  .S ERROR=""
  1.  D CLEAN^DILF
  1.  S DA=IEN
  1.  Q IEN
  1.  ;
  1. DELETE(FILE,DA,ERROR)   ;Delete an existing record.
  1.  N DATA
  1.  S DATA(.01)="@"
  1.  Q $$UPD^HLEMU(FILE,.DA,.DATA,.ERROR)
  1.  Q
  1.  ;
  1. STATNUM(IEN) ;
  1.  ;Description:  Given an ien to the Institution file, returns as the function value the station number. If IEN is NOT passed in, it assumes the local site.  Returns "" on failure.
  1.  ;
  1.  N STATION,RETURN
  1.  S RETURN=""
  1.  I $G(IEN) D
  1.  .Q:'$D(^DIC(4,IEN,0))
  1.  .S STATION=$P($$NNT^XUAF4(IEN),"^",2)
  1.  .S RETURN=$S(+STATION:STATION,1:"")
  1.  E  D
  1.  .S RETURN=$P($$SITE^VASITE(),"^",3)
  1.  Q RETURN
  1.  ;
  1. CHECKWHO(WHO,PARMS,ERROR) ;
  1.  ;Checks the parameters provided in WHO() (see $$ADD).  They must resolve
  1.  ;the link, receiving app and receiving facility.
  1.  ;INPUT:
  1.  ;  WHO - (required, pass by reference) - see $$ADD.
  1.  ;
  1.  ;  WHO("PORT") - if this is valued, it will be used as the remote port
  1.  ;    to connect with rather than the port associated with the link
  1.  ;Output:
  1.  ;  Function returns 1 if the input is resolved successfully, 0 otherwise
  1.  ;    PARMS - (pass by reference)  These subscripts are returned:
  1.  ;     "LINK IEN" - ien of the link 
  1.  ;     "LINK NAME" - name of the link
  1.  ;     "RECEIVING APPLICATION"  - name of the receiving app
  1.  ;     "RECEIVING FACILITY",1)  - component 1
  1.  ;     "RECEIVING FACILITY",2) - component 2
  1.  ;     "RECEIVING FACILITY",3) - component 3
  1.  ;   ERROR - (pass by reference) - if unsuccessful, an error message is returned.
  1.  ;
  1.  N OK
  1.  K ERROR
  1.  S OK=1
  1.  S PARMS("LINK IEN")="",PARMS("LINK NAME")=""
  1.  ;must identify the receiving app
  1.  ;
  1.  D
  1.  .N LEN
  1.  .S LEN=$L($G(WHO("RECEIVING APPLICATION")))
  1.  .I 'LEN S OK=0
  1.  .E  I LEN>60 S OK=0
  1.  .S:'OK ERROR="RECEIVING APPLICATION NOT VALID"
  1.  .S PARMS("RECEIVING APPLICATION")=$G(WHO("RECEIVING APPLICATION"))
  1.  ;
  1.  ;find the station # if Institution ien known
  1.  S:$G(WHO("INSTITUTION IEN")) WHO("STATION NUMBER")=$$STATNUM^HLOASUB1(WHO("INSTITUTION IEN"))
  1.  ;
  1.  ;if destination link specified by name, get its ien
  1.  I '$G(WHO("FACILITY LINK IEN")),$L($G(WHO("FACILITY LINK NAME"))) S WHO("FACILITY LINK IEN")=$O(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
  1.  ;
  1.  ;if destination link not specified, find it based on station #
  1.  I +$G(WHO("STATION NUMBER")),'$G(WHO("FACILITY LINK IEN")) S WHO("FACILITY LINK IEN")=$$FINDLINK^HLOTLNK(WHO("STATION NUMBER"))
  1.  ;
  1.  ;if station # not known, find it based on destination link
  1.  I '$G(WHO("STATION NUMBER")),$G(WHO("FACILITY LINK IEN")) S WHO("STATION NUMBER")=$$STATNUM^HLOTLNK(WHO("FACILITY LINK IEN"))
  1.  ;
  1.  S PARMS("RECEIVING FACILITY",1)=$G(WHO("STATION NUMBER"))
  1.  ;
  1.  ;if the destination link is known, get the domain
  1.  S PARMS("RECEIVING FACILITY",2)=$S($G(WHO("FACILITY LINK IEN")):$$DOMAIN^HLOTLNK(WHO("FACILITY LINK IEN")),1:"")
  1.  ;
  1.  S PARMS("RECEIVING FACILITY",3)="DNS"
  1.  ;
  1.  ;find the link to send over - need name & ien
  1.  I $G(WHO("IE LINK IEN")) D
  1.  .S PARMS("LINK IEN")=WHO("IE LINK IEN")
  1.  .S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
  1.  .I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
  1.  E  I $L($G(WHO("IE LINK NAME"))) D
  1.  .S PARMS("LINK NAME")=WHO("IE LINK NAME")
  1.  .S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("IE LINK NAME"),0))
  1.  .I OK,'PARMS("LINK IEN") S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
  1.  E  I $G(WHO("FACILITY LINK IEN")) D
  1.  .S PARMS("LINK IEN")=WHO("FACILITY LINK IEN")
  1.  .S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
  1.  .I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
  1.  E  I $L($G(WHO("FACILITY LINK NAME"))) D
  1.  .S PARMS("LINK NAME")=WHO("FACILITY LINK NAME")
  1.  .S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
  1.  .I OK,'PARMS("LINK IEN") S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
  1.  I OK,(('PARMS("LINK IEN"))!(PARMS("LINK NAME")="")) S OK=0,ERROR="LOGICAL LINK TO TRANSMIT OVER NOT SPECIFIED"
  1.  ;
  1.  ;need the station # or domain for msg header
  1.  I OK,'$L(PARMS("RECEIVING FACILITY",2)),'PARMS("RECEIVING FACILITY",1) S OK=0,ERROR="RECEIVING FACILITY STATION # AND DOMAIN NOT SPECIFIED"
  1.  ;
  1.  ;append the port#
  1.  I '$G(WHO("PORT")) S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_$$PORT^HLOTLNK($G(WHO("FACILITY LINK IEN")))
  1.  E  S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_WHO("PORT")
  1.  ;
  1.  Q OK