279 lines
9.4 KiB
Mathematica
279 lines
9.4 KiB
Mathematica
HLOASUB1 ;IRMFO-ALB/CJM - Subscription Registry (continued) ;02/26/2007
|
|
;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
INDEX(IEN,PARMARY) ;
|
|
;Allows an application to optionally index its subscriptions.
|
|
;so that it can find find them without storing the ien.
|
|
;
|
|
;Input:
|
|
; IEN - ien of the entry
|
|
; PARMARY (pass by reference) An array of up to 6 lookup values with
|
|
;which to build the index. The format is: PARMARY(1)=<first parameter>,
|
|
; up to PARMARY(6)
|
|
;Output:
|
|
; function returns 1 on success, 0 otherwise
|
|
; PARMARY - left undefined
|
|
;
|
|
N OWNER,I,NODE
|
|
Q:'$G(IEN) 0
|
|
S OWNER=$P($G(^HLD(779.4,IEN,0)),"^",2)
|
|
Q:'$L(OWNER) 0
|
|
D KILLAH(IEN)
|
|
F I=1:1:6 S:'$L($G(PARMARY(I))) PARMARY(I)=" "
|
|
D SETAH(IEN,OWNER,.PARMARY)
|
|
S NODE=""
|
|
F I=1:1:6 S NODE=NODE_$G(PARMARY(I))_"^"
|
|
S ^HLD(779.4,IEN,3)=NODE
|
|
K PARMARY
|
|
Q 1
|
|
;
|
|
SETAH(IEN,OWNER,PARMS) ;
|
|
Q:'$G(IEN)
|
|
Q:'$L($G(OWNER))
|
|
N INDEX
|
|
S INDEX="^HLD(779.4,""AH"",OWNER,"
|
|
F I=1:1:6 D
|
|
.S:'$L($G(PARMS(I))) PARMS(I)=" "
|
|
.S INDEX=INDEX_""""_PARMS(I)_""","
|
|
S INDEX=$E(INDEX,1,$L(INDEX)-1)_")"
|
|
S @INDEX=IEN
|
|
Q
|
|
;
|
|
SETAH1(DA,OWNER,X1,X2,X3,X4,X5,X6) ;
|
|
Q:'$G(DA)
|
|
Q:'$L($G(OWNER))
|
|
N PARMS,I
|
|
F I=1:1:6 I $L($G(@("X"_I))) S PARMS(I)=@("X"_I)
|
|
D SETAH(DA,OWNER,.PARMS)
|
|
Q
|
|
;
|
|
KILLAH1(OWNER,LOOKUP1,LOOKUP2,LOOKUP3,LOOKUP4,LOOKUP5,LOOKUP6) ;
|
|
Q:'$L(OWNER)
|
|
N I,INDEX
|
|
S INDEX="^HLD(779.4,""AH"",OWNER"
|
|
F I=1:1:6 D
|
|
.S:'$L($G(@("LOOKUP"_I))) @("LOOKUP"_I)=" "
|
|
.S INDEX=INDEX_","_""""_@("LOOKUP"_I)_""""
|
|
S INDEX=INDEX_")"
|
|
K @INDEX
|
|
Q
|
|
;
|
|
KILLAH(IEN) ;kills the AH x~ref on file 779.4 for a particular subscription registry entry=ien
|
|
Q:'$G(IEN)
|
|
N OWNER,X1,X2,X3,X4,X5,X6,I,NODE
|
|
S OWNER=$P($G(^HLD(779.4,IEN,0)),"^",2)
|
|
Q:'$L(OWNER)
|
|
S NODE=$G(^HLD(779.4,IEN,3))
|
|
F I=1:1:6 I $L($P(NODE,"^",I)) S @("X"_I)=$P(NODE,"^",I)
|
|
D KILLAH1(OWNER,.X1,.X2,.X3,.X4,.X5,.X6)
|
|
Q
|
|
;
|
|
FIND(OWNER,PARMARY) ;
|
|
;Allows an application to find a subscription
|
|
;list. The application must maintain a private index in order to
|
|
;utilize this function, via $$INDEX^HLOASUB()
|
|
;
|
|
;Input:
|
|
; OWNER - owning application name
|
|
; PARMARY **pass by reference** an array of up to 6 lookup value 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 ignored
|
|
;Output:
|
|
; function returns the ien of the subscription list if found, 0 otherwise
|
|
; PARMARY - left undefined
|
|
;
|
|
N OK S OK=0
|
|
;
|
|
D
|
|
.Q:'$D(PARMARY)
|
|
.Q:'$L($G(OWNER))
|
|
.N INDEX,I
|
|
.S INDEX="^HLD(779.4,""AH"",OWNER"
|
|
.F I=1:1:6 D
|
|
..S:'$L($G(PARMARY(I))) PARMARY(I)=" "
|
|
..S INDEX=INDEX_","_""""_PARMARY(I)_""""
|
|
.S INDEX=INDEX_")"
|
|
.S OK=+$G(@INDEX)
|
|
K PARMARY
|
|
Q OK
|
|
;
|
|
UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
|
|
; Input:
|
|
; FILE - File or sub-file number
|
|
; DA - Traditional DA array, with same meaning.
|
|
; Pass by reference.
|
|
; DATA - Data array to file (pass by reference)
|
|
; Format: DATA(<field #>)=<value>
|
|
;
|
|
; Output:
|
|
; Function Value - 0=error and 1=no error
|
|
; ERROR - optional error message - if needed, pass by reference
|
|
;
|
|
; Example: To update a record in subfile 2.0361 in record with ien=353,
|
|
; subrecord ien=68, with the field .01 value = 21:
|
|
; S DATA(.01)=21,DA=68,DA(1)=353 I $$UPD(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
|
|
;
|
|
N FDA,FIELD,IENS,ERRORS
|
|
;
|
|
;IENS - Internal Entry Number String defined by FM
|
|
;FDA - the FDA array as defined by FM
|
|
;
|
|
I '$G(DA) S ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED" Q 0
|
|
S IENS=$$IENS^DILF(.DA)
|
|
S FIELD=0
|
|
F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
|
|
.S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
|
|
D FILE^DIE("","FDA","ERRORS(1)")
|
|
I +$G(DIERR) D
|
|
.S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
|
|
E D
|
|
.S ERROR=""
|
|
;
|
|
D CLEAN^DILF
|
|
Q $S(+$G(DIERR):0,1:1)
|
|
;
|
|
ADD(FILE,DA,DATA,ERROR,IEN) ;
|
|
;Description: Creates a new record and files the data.
|
|
; Input:
|
|
; FILE - File or sub-file number
|
|
; DA - Traditional FileMan DA array with same
|
|
; meaning. Pass by reference. Only needed if adding to a
|
|
; subfile.
|
|
; DATA - Data array to file, pass by reference
|
|
; Format: DATA(<field #>)=<value>
|
|
; IEN - internal entry number to use (optional)
|
|
;
|
|
; Output:
|
|
; Function Value - If no error then it returns the ien of the created record, else returns NULL.
|
|
; DA - returns the ien of the new record, NULL if none created. If needed, pass by reference.
|
|
; ERROR - optional error message - if needed, pass by reference
|
|
;
|
|
; Example: To add a record in subfile 2.0361 in the record with ien=353
|
|
; with the field .01 value = 21:
|
|
; S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
|
|
;
|
|
; Example: If creating a record not in a subfile, would look like this:
|
|
; S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
|
|
;
|
|
N FDA,FIELD,IENA,IENS,ERRORS
|
|
;
|
|
;IENS - Internal Entry Number String defined by FM
|
|
;IENA - the Internal Entry Number Array defined by FM
|
|
;FDA - the FDA array defined by FM
|
|
;IEN - the ien of the new record
|
|
;
|
|
S DA="+1"
|
|
S IENS=$$IENS^DILF(.DA)
|
|
S FIELD=0
|
|
F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
|
|
.S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
|
|
I $G(IEN) S IENA(1)=IEN
|
|
D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
|
|
I +$G(DIERR) D
|
|
.S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
|
|
.S IEN=""
|
|
E D
|
|
.S IEN=IENA(1)
|
|
.S ERROR=""
|
|
D CLEAN^DILF
|
|
S DA=IEN
|
|
Q IEN
|
|
;
|
|
DELETE(FILE,DA,ERROR) ;Delete an existing record.
|
|
N DATA
|
|
S DATA(.01)="@"
|
|
Q $$UPD(FILE,.DA,.DATA,.ERROR)
|
|
Q
|
|
;
|
|
STATNUM(IEN) ;
|
|
;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.
|
|
;
|
|
N STATION,RETURN
|
|
S RETURN=""
|
|
I $G(IEN) D
|
|
.Q:'$D(^DIC(4,IEN,0))
|
|
.S STATION=$P($$NNT^XUAF4(IEN),"^",2)
|
|
.S RETURN=$S(+STATION:STATION,1:"")
|
|
E D
|
|
.S RETURN=$P($$SITE^VASITE(),"^",3)
|
|
Q RETURN
|
|
;
|
|
CHECKWHO(WHO,PARMS,ERROR) ;
|
|
;Checks the parameters provided in WHO() (see $$ADD). They must resolve
|
|
;the link, receiving app and receiving facility.
|
|
;INPUT:
|
|
; WHO - (required, pass by reference) - see $$ADD.
|
|
;
|
|
; WHO("PORT") - if this is valued, it will be used as the remote port
|
|
; to connect with rather than the port associated with the link
|
|
;Output:
|
|
; Function returns 1 if the input is resolved successfully, 0 otherwise
|
|
; PARMS - (pass by reference) These subscripts are returned:
|
|
; "LINK IEN" - ien of the link
|
|
; "LINK NAME" - name of the link
|
|
; "RECEIVING APPLICATION" - name of the receiving app
|
|
; "RECEIVING FACILITY",1) - component 1
|
|
; "RECEIVING FACILITY",2) - component 2
|
|
; "RECEIVING FACILITY",3) - component 3
|
|
; ERROR - (pass by reference) - if unsuccessful, an error message is returned.
|
|
;
|
|
N OK
|
|
K ERROR
|
|
S OK=1
|
|
S PARMS("LINK IEN")="",PARMS("LINK NAME")=""
|
|
;must identify the receiving app
|
|
;
|
|
D
|
|
.N LEN
|
|
.S LEN=$L($G(WHO("RECEIVING APPLICATION")))
|
|
.I 'LEN S OK=0
|
|
.E I LEN>60 S OK=0
|
|
.S:'OK ERROR="RECEIVING APPLICATION NOT VALID"
|
|
.S PARMS("RECEIVING APPLICATION")=$G(WHO("RECEIVING APPLICATION"))
|
|
;
|
|
;find the station # if Institution ien known
|
|
S:$G(WHO("INSTITUTION IEN")) WHO("STATION NUMBER")=$$STATNUM^HLOASUB1(WHO("INSTITUTION IEN"))
|
|
;
|
|
;if destination link specified by name, get its ien
|
|
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))
|
|
;
|
|
;if destination link not specified, find it based on station #
|
|
I +$G(WHO("STATION NUMBER")),'$G(WHO("FACILITY LINK IEN")) S WHO("FACILITY LINK IEN")=$$FINDLINK^HLOTLNK(WHO("STATION NUMBER"))
|
|
;
|
|
;if station # not known, find it based on destination link
|
|
I '$G(WHO("STATION NUMBER")),$G(WHO("FACILITY LINK IEN")) S WHO("STATION NUMBER")=$$STATNUM^HLOTLNK(WHO("FACILITY LINK IEN"))
|
|
;
|
|
S PARMS("RECEIVING FACILITY",1)=$G(WHO("STATION NUMBER"))
|
|
;
|
|
;if the destination link is known, get the domain
|
|
S PARMS("RECEIVING FACILITY",2)=$S($G(WHO("FACILITY LINK IEN")):$$DOMAIN^HLOTLNK(WHO("FACILITY LINK IEN")),1:"")
|
|
;
|
|
S PARMS("RECEIVING FACILITY",3)="DNS"
|
|
;
|
|
;find the link to send over - need name & ien
|
|
I $G(WHO("IE LINK IEN")) D
|
|
.S PARMS("LINK IEN")=WHO("IE LINK IEN")
|
|
.S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
|
|
.I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
|
|
E I $L($G(WHO("IE LINK NAME"))) D
|
|
.S PARMS("LINK NAME")=WHO("IE LINK NAME")
|
|
.S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("IE LINK NAME"),0))
|
|
.I OK,'PARMS("LINK IEN") S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
|
|
E I $G(WHO("FACILITY LINK IEN")) D
|
|
.S PARMS("LINK IEN")=WHO("FACILITY LINK IEN")
|
|
.S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
|
|
.I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
|
|
E I $L($G(WHO("FACILITY LINK NAME"))) D
|
|
.S PARMS("LINK NAME")=WHO("FACILITY LINK NAME")
|
|
.S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
|
|
.I OK,'PARMS("LINK IEN") S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
|
|
I OK,(('PARMS("LINK IEN"))!(PARMS("LINK NAME")="")) S OK=0,ERROR="LOGICAL LINK TO TRANSMIT OVER NOT SPECIFIED"
|
|
;
|
|
;need the station # or domain for msg header
|
|
I OK,'$L(PARMS("RECEIVING FACILITY",2)),'PARMS("RECEIVING FACILITY",1) S OK=0,ERROR="RECEIVING FACILITY STATION # AND DOMAIN NOT SPECIFIED"
|
|
;
|
|
;append the port#
|
|
I '$G(WHO("PORT")) S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_$$PORT^HLOTLNK($G(WHO("FACILITY LINK IEN")))
|
|
E S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_WHO("PORT")
|
|
;
|
|
Q OK
|