HLOASUB1 ;IRMFO-ALB/CJM/RBN - Subscription Registry (continued) ;07/12/2012
;;1.6;HEALTH LEVEL SEVEN;**126,134,138,146,147,158**;Oct 13, 1995;Build 14
;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 overwhich to transmit (could be middleware)
; "LINK NAME" - name of the link
; "LINK PORT" - port #
; "RECEIVING APPLICATION" - name of the receiving app
; "RECEIVING FACILITY",1) - component 1
; "RECEIVING FACILITY",2) - component 2
; "RECEIVING FACILITY",3) - component 3
; "RECEIVING FACILITY","LINK IEN") - ien of facility
; 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 $L($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 '$L($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:"")
;
;**P146 START CJM
S PARMS("RECEIVING FACILITY","LINK IEN")=$G(WHO("FACILITY LINK IEN"))
;**P146 END CJM
;
S PARMS("RECEIVING FACILITY",3)="DNS"
;
;find the link to send over - need name & ien
I $G(WHO("MIDDLEWARE LINK IEN")) S WHO("IE LINK IEN")=WHO("MIDDLEWARE LINK IEN")
I $L($G(WHO("MIDDLEWARE LINK NAME"))) S WHO("IE LINK NAME")=WHO("MIDDLEWARE LINK NAME")
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="MIDDLEWARE 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="MIDDLEWARE 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))
.;; ** Start HL*1.6*138 - RBN **
.;I OK,'PARMS("LINK IEN") S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
.I OK,'PARMS("LINK IEN") S OK=0,ERROR="NEITHER THE RECEIVING FACILITY STATION # NOR THE DOMAIN IS SPECIFIED. AT LEAST ONE OR THE OTHER MUST BE SPECIFIED."
.;; ** Start HL*1.6*138 - RBN **
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
ZB25 I OK,'$L(PARMS("RECEIVING FACILITY",2)),'PARMS("RECEIVING FACILITY",1) S OK=0,ERROR="NEITHER THE RECEIVING FACILITY STATION # NOR THE DOMAIN IS SPECIFIED. AT LEAST ONE OR THE OTHER MUST BE 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")
;**P158 START **
I $G(WHO("PORT")) S PARMS("LINK PORT")=WHO("PORT")
E I $G(PARMS("LINK IEN")) S PARMS("LINK PORT")=$$PORT^HLOTLNK(PARMS("LINK IEN"))
;**P158 END **
;
Q OK
;
;**P146 START CJM
ONLIST(IEN,WHO) ;
;Description:
; Determines if a recipient is already on the subscriber list
;
;Input:
; IEN - ien of subscription
; WHO (pass by reference) Identifies the recipient. The allows
; subscripts are the same as in ADD^HLOASUB.
;
;Output:
; Function returns 0 if not on the subscription list, otherwise
; returns the ien of the subscriber on the subscription list.
;
N PARMS,SUBIEN,TLINK
S SUBIEN=0
;
;resolve input parameters
I '$$CHECKWHO(.WHO,.PARMS) Q 0
;
;check the "AE" xref
S SUBIEN=$O(^HLD(779.4,IEN,2,"AE",PARMS("RECEIVING APPLICATION"),+$G(PARMS("RECEIVING FACILITY","LINK IEN")),+$G(PARMS("LINK IEN")),0))
I SUBIEN Q SUBIEN
I PARMS("RECEIVING FACILITY","LINK IEN")=PARMS("LINK IEN") S SUBIEN=$O(^HLD(779.4,IEN,2,"AE",PARMS("RECEIVING APPLICATION"),+$G(PARMS("RECEIVING FACILITY","LINK IEN")),0,0))
I SUBIEN Q SUBIEN
;
;check the "AD" xref
I PARMS("LINK IEN"),PARMS("LINK IEN")'=PARMS("RECEIVING FACILITY","LINK IEN") D
.S TLINK=PARMS("LINK IEN")
E S TLINK=PARMS("RECEIVING FACILITY","LINK IEN")
;
Q +$O(^HLD(779.4,IEN,2,"AD",PARMS("RECEIVING APPLICATION"),+TLINK,PARMS("RECEIVING FACILITY",1)_PARMS("RECEIVING FACILITY",2)_PARMS("RECEIVING FACILITY",3),0))
;
;**P146 END CJM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOASUB1 12119 printed Dec 13, 2024@01:58:34 Page 2
HLOASUB1 ;IRMFO-ALB/CJM/RBN - Subscription Registry (continued) ;07/12/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,134,138,146,147,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
INDEX(IEN,PARMARY) ;
+1 ;Allows an application to optionally index its subscriptions.
+2 ;so that it can find find them without storing the ien.
+3 ;
+4 ;Input:
+5 ; IEN - ien of the entry
+6 ; PARMARY (pass by reference) An array of up to 6 lookup values with
+7 ;which to build the index. The format is: PARMARY(1)=<first parameter>,
+8 ; up to PARMARY(6)
+9 ;Output:
+10 ; function returns 1 on success, 0 otherwise
+11 ; PARMARY - left undefined
+12 ;
+13 NEW OWNER,I,NODE
+14 if '$GET(IEN)
QUIT 0
+15 SET OWNER=$PIECE($GET(^HLD(779.4,IEN,0)),"^",2)
+16 if '$LENGTH(OWNER)
QUIT 0
+17 DO KILLAH(IEN)
+18 FOR I=1:1:6
if '$LENGTH($GET(PARMARY(I)))
SET PARMARY(I)=" "
+19 DO SETAH(IEN,OWNER,.PARMARY)
+20 SET NODE=""
+21 FOR I=1:1:6
SET NODE=NODE_$GET(PARMARY(I))_"^"
+22 SET ^HLD(779.4,IEN,3)=NODE
+23 KILL PARMARY
+24 QUIT 1
+25 ;
SETAH(IEN,OWNER,PARMS) ;
+1 if '$GET(IEN)
QUIT
+2 if '$LENGTH($GET(OWNER))
QUIT
+3 NEW INDEX
+4 SET INDEX="^HLD(779.4,""AH"",OWNER,"
+5 FOR I=1:1:6
Begin DoDot:1
+6 if '$LENGTH($GET(PARMS(I)))
SET PARMS(I)=" "
+7 SET INDEX=INDEX_""""_PARMS(I)_""","
End DoDot:1
+8 SET INDEX=$EXTRACT(INDEX,1,$LENGTH(INDEX)-1)_")"
+9 SET @INDEX=IEN
+10 QUIT
+11 ;
SETAH1(DA,OWNER,X1,X2,X3,X4,X5,X6) ;
+1 if '$GET(DA)
QUIT
+2 if '$LENGTH($GET(OWNER))
QUIT
+3 NEW PARMS,I
+4 FOR I=1:1:6
IF $LENGTH($GET(@("X"_I)))
SET PARMS(I)=@("X"_I)
+5 DO SETAH(DA,OWNER,.PARMS)
+6 QUIT
+7 ;
KILLAH1(OWNER,LOOKUP1,LOOKUP2,LOOKUP3,LOOKUP4,LOOKUP5,LOOKUP6) ;
+1 if '$LENGTH(OWNER)
QUIT
+2 NEW I,INDEX
+3 SET INDEX="^HLD(779.4,""AH"",OWNER"
+4 FOR I=1:1:6
Begin DoDot:1
+5 if '$LENGTH($GET(@("LOOKUP"_I)))
SET @("LOOKUP"_I)=" "
+6 SET INDEX=INDEX_","_""""_@("LOOKUP"_I)_""""
End DoDot:1
+7 SET INDEX=INDEX_")"
+8 KILL @INDEX
+9 QUIT
+10 ;
KILLAH(IEN) ;kills the AH x~ref on file 779.4 for a particular subscription registry entry=ien
+1 if '$GET(IEN)
QUIT
+2 NEW OWNER,X1,X2,X3,X4,X5,X6,I,NODE
+3 SET OWNER=$PIECE($GET(^HLD(779.4,IEN,0)),"^",2)
+4 if '$LENGTH(OWNER)
QUIT
+5 SET NODE=$GET(^HLD(779.4,IEN,3))
+6 FOR I=1:1:6
IF $LENGTH($PIECE(NODE,"^",I))
SET @("X"_I)=$PIECE(NODE,"^",I)
+7 DO KILLAH1(OWNER,.X1,.X2,.X3,.X4,.X5,.X6)
+8 QUIT
+9 ;
FIND(OWNER,PARMARY) ;
+1 ;Allows an application to find a subscription
+2 ;list. The application must maintain a private index in order to
+3 ;utilize this function, via $$INDEX^HLOASUB()
+4 ;
+5 ;Input:
+6 ; OWNER - owning application name
+7 ; 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
+8 ;Output:
+9 ; function returns the ien of the subscription list if found, 0 otherwise
+10 ; PARMARY - left undefined
+11 ;
+12 NEW OK
SET OK=0
+13 ;
+14 Begin DoDot:1
+15 if '$DATA(PARMARY)
QUIT
+16 if '$LENGTH($GET(OWNER))
QUIT
+17 NEW INDEX,I
+18 SET INDEX="^HLD(779.4,""AH"",OWNER"
+19 FOR I=1:1:6
Begin DoDot:2
+20 if '$LENGTH($GET(PARMARY(I)))
SET PARMARY(I)=" "
+21 SET INDEX=INDEX_","_""""_PARMARY(I)_""""
End DoDot:2
+22 SET INDEX=INDEX_")"
+23 SET OK=+$GET(@INDEX)
End DoDot:1
+24 KILL PARMARY
+25 QUIT OK
+26 ;
UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
+1 ; Input:
+2 ; FILE - File or sub-file number
+3 ; DA - Traditional DA array, with same meaning.
+4 ; Pass by reference.
+5 ; DATA - Data array to file (pass by reference)
+6 ; Format: DATA(<field #>)=<value>
+7 ;
+8 ; Output:
+9 ; Function Value - 0=error and 1=no error
+10 ; ERROR - optional error message - if needed, pass by reference
+11 ;
+12 ; Example: To update a record in subfile 2.0361 in record with ien=353,
+13 ; subrecord ien=68, with the field .01 value = 21:
+14 ; S DATA(.01)=21,DA=68,DA(1)=353 I $$UPD(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
+15 ;
+16 NEW FDA,FIELD,IENS,ERRORS
+17 ;
+18 ;IENS - Internal Entry Number String defined by FM
+19 ;FDA - the FDA array as defined by FM
+20 ;
+21 IF '$GET(DA)
SET ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED"
QUIT 0
+22 SET IENS=$$IENS^DILF(.DA)
+23 SET FIELD=0
+24 FOR
SET FIELD=$ORDER(DATA(FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+25 SET FDA(FILE,IENS,FIELD)=$GET(DATA(FIELD))
End DoDot:1
+26 DO FILE^DIE("","FDA","ERRORS(1)")
+27 IF +$GET(DIERR)
Begin DoDot:1
+28 SET ERROR=$GET(ERRORS(1,"DIERR",1,"TEXT",1))
End DoDot:1
+29 IF '$TEST
Begin DoDot:1
+30 SET ERROR=""
End DoDot:1
+31 ;
+32 DO CLEAN^DILF
+33 QUIT $SELECT(+$GET(DIERR):0,1:1)
+34 ;
ADD(FILE,DA,DATA,ERROR,IEN) ;
+1 ;Description: Creates a new record and files the data.
+2 ; Input:
+3 ; FILE - File or sub-file number
+4 ; DA - Traditional FileMan DA array with same
+5 ; meaning. Pass by reference. Only needed if adding to a
+6 ; subfile.
+7 ; DATA - Data array to file, pass by reference
+8 ; Format: DATA(<field #>)=<value>
+9 ; IEN - internal entry number to use (optional)
+10 ;
+11 ; Output:
+12 ; Function Value - If no error then it returns the ien of the created record, else returns NULL.
+13 ; DA - returns the ien of the new record, NULL if none created. If needed, pass by reference.
+14 ; ERROR - optional error message - if needed, pass by reference
+15 ;
+16 ; Example: To add a record in subfile 2.0361 in the record with ien=353
+17 ; with the field .01 value = 21:
+18 ; S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
+19 ;
+20 ; Example: If creating a record not in a subfile, would look like this:
+21 ; S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
+22 ;
+23 NEW FDA,FIELD,IENA,IENS,ERRORS
+24 ;
+25 ;IENS - Internal Entry Number String defined by FM
+26 ;IENA - the Internal Entry Number Array defined by FM
+27 ;FDA - the FDA array defined by FM
+28 ;IEN - the ien of the new record
+29 ;
+30 SET DA="+1"
+31 SET IENS=$$IENS^DILF(.DA)
+32 SET FIELD=0
+33 FOR
SET FIELD=$ORDER(DATA(FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+34 SET FDA(FILE,IENS,FIELD)=$GET(DATA(FIELD))
End DoDot:1
+35 IF $GET(IEN)
SET IENA(1)=IEN
+36 DO UPDATE^DIE("","FDA","IENA","ERRORS(1)")
+37 IF +$GET(DIERR)
Begin DoDot:1
+38 SET ERROR=$GET(ERRORS(1,"DIERR",1,"TEXT",1))
+39 SET IEN=""
End DoDot:1
+40 IF '$TEST
Begin DoDot:1
+41 SET IEN=IENA(1)
+42 SET ERROR=""
End DoDot:1
+43 DO CLEAN^DILF
+44 SET DA=IEN
+45 QUIT IEN
+46 ;
DELETE(FILE,DA,ERROR) ;Delete an existing record.
+1 NEW DATA
+2 SET DATA(.01)="@"
+3 QUIT $$UPD(FILE,.DA,.DATA,.ERROR)
+4 QUIT
+5 ;
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.
+2 ;
+3 NEW STATION,RETURN
+4 SET RETURN=""
+5 IF $GET(IEN)
Begin DoDot:1
+6 if '$DATA(^DIC(4,IEN,0))
QUIT
+7 SET STATION=$PIECE($$NNT^XUAF4(IEN),"^",2)
+8 SET RETURN=$SELECT(+STATION:STATION,1:"")
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET RETURN=$PIECE($$SITE^VASITE(),"^",3)
End DoDot:1
+11 QUIT RETURN
+12 ;
CHECKWHO(WHO,PARMS,ERROR) ;
+1 ;Checks the parameters provided in WHO() (see $$ADD). They must resolve
+2 ;the link, receiving app and receiving facility.
+3 ;INPUT:
+4 ; WHO - (required, pass by reference) - see $$ADD.
+5 ;
+6 ; WHO("PORT") - if this is valued, it will be used as the remote port
+7 ; to connect with rather than the port associated with the link
+8 ;Output:
+9 ; Function returns 1 if the input is resolved successfully, 0 otherwise
+10 ; PARMS - (pass by reference) These subscripts are returned:
+11 ; "LINK IEN" - ien of the link overwhich to transmit (could be middleware)
+12 ; "LINK NAME" - name of the link
+13 ; "LINK PORT" - port #
+14 ; "RECEIVING APPLICATION" - name of the receiving app
+15 ; "RECEIVING FACILITY",1) - component 1
+16 ; "RECEIVING FACILITY",2) - component 2
+17 ; "RECEIVING FACILITY",3) - component 3
+18 ; "RECEIVING FACILITY","LINK IEN") - ien of facility
+19 ; ERROR - (pass by reference) - if unsuccessful, an error message is returned.
+20 ;
+21 NEW OK
+22 KILL ERROR
+23 SET OK=1
+24 SET PARMS("LINK IEN")=""
SET PARMS("LINK NAME")=""
+25 ;must identify the receiving app
+26 ;
+27 Begin DoDot:1
+28 NEW LEN
+29 SET LEN=$LENGTH($GET(WHO("RECEIVING APPLICATION")))
+30 IF 'LEN
SET OK=0
+31 IF '$TEST
IF LEN>60
SET OK=0
+32 if 'OK
SET ERROR="RECEIVING APPLICATION NOT VALID"
+33 SET PARMS("RECEIVING APPLICATION")=$GET(WHO("RECEIVING APPLICATION"))
End DoDot:1
+34 ;
+35 ;find the station # if Institution ien known
+36 if $GET(WHO("INSTITUTION IEN"))
SET WHO("STATION NUMBER")=$$STATNUM^HLOASUB1(WHO("INSTITUTION IEN"))
+37 ;
+38 ;if destination link specified by name, get its ien
+39 IF '$GET(WHO("FACILITY LINK IEN"))
IF $LENGTH($GET(WHO("FACILITY LINK NAME")))
SET WHO("FACILITY LINK IEN")=$ORDER(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
+40 ;
+41 ;if destination link not specified, find it based on station #
+42 IF $LENGTH($GET(WHO("STATION NUMBER")))
IF '$GET(WHO("FACILITY LINK IEN"))
SET WHO("FACILITY LINK IEN")=$$FINDLINK^HLOTLNK(WHO("STATION NUMBER"))
+43 ;
+44 ;if station # not known, find it based on destination link
+45 IF '$LENGTH($GET(WHO("STATION NUMBER")))
IF $GET(WHO("FACILITY LINK IEN"))
SET WHO("STATION NUMBER")=$$STATNUM^HLOTLNK(WHO("FACILITY LINK IEN"))
+46 ;
+47 SET PARMS("RECEIVING FACILITY",1)=$GET(WHO("STATION NUMBER"))
+48 ;
+49 ;if the destination link is known, get the domain
+50 SET PARMS("RECEIVING FACILITY",2)=$SELECT($GET(WHO("FACILITY LINK IEN")):$$DOMAIN^HLOTLNK(WHO("FACILITY LINK IEN")),1:"")
+51 ;
+52 ;**P146 START CJM
+53 SET PARMS("RECEIVING FACILITY","LINK IEN")=$GET(WHO("FACILITY LINK IEN"))
+54 ;**P146 END CJM
+55 ;
+56 SET PARMS("RECEIVING FACILITY",3)="DNS"
+57 ;
+58 ;find the link to send over - need name & ien
+59 IF $GET(WHO("MIDDLEWARE LINK IEN"))
SET WHO("IE LINK IEN")=WHO("MIDDLEWARE LINK IEN")
+60 IF $LENGTH($GET(WHO("MIDDLEWARE LINK NAME")))
SET WHO("IE LINK NAME")=WHO("MIDDLEWARE LINK NAME")
+61 IF $GET(WHO("IE LINK IEN"))
Begin DoDot:1
+62 SET PARMS("LINK IEN")=WHO("IE LINK IEN")
+63 SET PARMS("LINK NAME")=$PIECE($GET(^HLCS(870,PARMS("LINK IEN"),0)),"^")
+64 IF OK
IF '$LENGTH(PARMS("LINK NAME"))
SET OK=0
SET ERROR="MIDDLEWARE LOGICAL LINK PROVIDED BUT NOT FOUND"
End DoDot:1
+65 IF '$TEST
IF $LENGTH($GET(WHO("IE LINK NAME")))
Begin DoDot:1
+66 SET PARMS("LINK NAME")=WHO("IE LINK NAME")
+67 SET PARMS("LINK IEN")=$ORDER(^HLCS(870,"B",WHO("IE LINK NAME"),0))
+68 IF OK
IF 'PARMS("LINK IEN")
SET OK=0
SET ERROR="MIDDLEWARE LOGICAL LINK PROVIDED BUT NOT FOUND"
End DoDot:1
+69 IF '$TEST
IF $GET(WHO("FACILITY LINK IEN"))
Begin DoDot:1
+70 SET PARMS("LINK IEN")=WHO("FACILITY LINK IEN")
+71 SET PARMS("LINK NAME")=$PIECE($GET(^HLCS(870,PARMS("LINK IEN"),0)),"^")
+72 IF OK
IF '$LENGTH(PARMS("LINK NAME"))
SET OK=0
SET ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
End DoDot:1
+73 IF '$TEST
IF $LENGTH($GET(WHO("FACILITY LINK NAME")))
Begin DoDot:1
+74 SET PARMS("LINK NAME")=WHO("FACILITY LINK NAME")
+75 SET PARMS("LINK IEN")=$ORDER(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
+76 ;; ** Start HL*1.6*138 - RBN **
+77 ;I OK,'PARMS("LINK IEN") S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
+78 IF OK
IF 'PARMS("LINK IEN")
SET OK=0
SET ERROR="NEITHER THE RECEIVING FACILITY STATION # NOR THE DOMAIN IS SPECIFIED. AT LEAST ONE OR THE OTHER MUST BE SPECIFIED."
+79 ;; ** Start HL*1.6*138 - RBN **
End DoDot:1
+80 IF OK
IF (('PARMS("LINK IEN"))!(PARMS("LINK NAME")=""))
SET OK=0
SET ERROR="LOGICAL LINK TO TRANSMIT OVER NOT SPECIFIED"
+81 ;
+82 ;need the station # or domain for msg header
ZB25 IF OK
IF '$LENGTH(PARMS("RECEIVING FACILITY",2))
IF 'PARMS("RECEIVING FACILITY",1)
SET OK=0
SET ERROR="NEITHER THE RECEIVING FACILITY STATION # NOR THE DOMAIN IS SPECIFIED. AT LEAST ONE OR THE OTHER MUST BE SPECIFIED."
+1 ;
+2 ;append the port#
+3 IF '$GET(WHO("PORT"))
SET PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_$$PORT^HLOTLNK($GET(WHO("FACILITY LINK IEN")))
+4 IF '$TEST
SET PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_WHO("PORT")
+5 ;**P158 START **
+6 IF $GET(WHO("PORT"))
SET PARMS("LINK PORT")=WHO("PORT")
+7 IF '$TEST
IF $GET(PARMS("LINK IEN"))
SET PARMS("LINK PORT")=$$PORT^HLOTLNK(PARMS("LINK IEN"))
+8 ;**P158 END **
+9 ;
+10 QUIT OK
+11 ;
+12 ;**P146 START CJM
ONLIST(IEN,WHO) ;
+1 ;Description:
+2 ; Determines if a recipient is already on the subscriber list
+3 ;
+4 ;Input:
+5 ; IEN - ien of subscription
+6 ; WHO (pass by reference) Identifies the recipient. The allows
+7 ; subscripts are the same as in ADD^HLOASUB.
+8 ;
+9 ;Output:
+10 ; Function returns 0 if not on the subscription list, otherwise
+11 ; returns the ien of the subscriber on the subscription list.
+12 ;
+13 NEW PARMS,SUBIEN,TLINK
+14 SET SUBIEN=0
+15 ;
+16 ;resolve input parameters
+17 IF '$$CHECKWHO(.WHO,.PARMS)
QUIT 0
+18 ;
+19 ;check the "AE" xref
+20 SET SUBIEN=$ORDER(^HLD(779.4,IEN,2,"AE",PARMS("RECEIVING APPLICATION"),+$GET(PARMS("RECEIVING FACILITY","LINK IEN")),+$GET(PARMS("LINK IEN")),0))
+21 IF SUBIEN
QUIT SUBIEN
+22 IF PARMS("RECEIVING FACILITY","LINK IEN")=PARMS("LINK IEN")
SET SUBIEN=$ORDER(^HLD(779.4,IEN,2,"AE",PARMS("RECEIVING APPLICATION"),+$GET(PARMS("RECEIVING FACILITY","LINK IEN")),0,0))
+23 IF SUBIEN
QUIT SUBIEN
+24 ;
+25 ;check the "AD" xref
+26 IF PARMS("LINK IEN")
IF PARMS("LINK IEN")'=PARMS("RECEIVING FACILITY","LINK IEN")
Begin DoDot:1
+27 SET TLINK=PARMS("LINK IEN")
End DoDot:1
+28 IF '$TEST
SET TLINK=PARMS("RECEIVING FACILITY","LINK IEN")
+29 ;
+30 QUIT +$ORDER(^HLD(779.4,IEN,2,"AD",PARMS("RECEIVING APPLICATION"),+TLINK,PARMS("RECEIVING FACILITY",1)_PARMS("RECEIVING FACILITY",2)_PARMS("RECEIVING FACILITY",3),0))
+31 ;
+32 ;**P146 END CJM
