93 lines
3.4 KiB
Mathematica
93 lines
3.4 KiB
Mathematica
HLOCVU ;DAOU/ALA-Conversion Utility ;03/15/2007
|
|
;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
|
|
;Per VHA Directive 2004-038, this routine should not be modified.
|
|
;
|
|
Q
|
|
;
|
|
APAR(HLOEID,APARMS,WHO,WHOTO,HLP,HLL) ; Set up PPARMS array from Protocols
|
|
;
|
|
; Input Parameter
|
|
; HLOEID = IEN of the event protocol
|
|
; HLP - "EXCLUDE SUBSCRIBER" subscript used to ignore specific subscribers
|
|
; HLL - dynamic addressing
|
|
;
|
|
; Output
|
|
; APARMS array
|
|
; WHO - correlates to WHOTO, providing <subscriber protocol ien>,<link ien> (pass by reference)
|
|
; WHOTO array
|
|
;
|
|
N CT,NODE,I
|
|
K APARMS,WHO,WHOTO
|
|
S CT=0
|
|
Q:'$G(HLOEID)
|
|
S NODE=$G(^ORD(101,HLOEID,770))
|
|
S APARMS("EVENT")=$P(NODE,"^",4),APARMS("EVENT")=$S(APARMS("EVENT"):$P($G(^HL(779.001,APARMS("EVENT"),0)),"^"),1:"")
|
|
S APARMS("MESSAGE TYPE")=$P(NODE,"^",3),APARMS("MESSAGE TYPE")=$S(APARMS("MESSAGE TYPE"):$P($G(^HL(771.2,APARMS("MESSAGE TYPE"),0)),"^"),1:"")
|
|
S APARMS("APP ACK TYPE")=$P(NODE,"^",9),APARMS("APP ACK TYPE")=$S(APARMS("APP ACK TYPE"):$P($G(^HL(779.003,APARMS("APP ACK TYPE"),0)),"^"),1:"")
|
|
S APARMS("ACCEPT ACK TYPE")=$P(NODE,"^",8),APARMS("ACCEPT ACK TYPE")=$S(APARMS("ACCEPT ACK TYPE"):$P($G(^HL(779.003,APARMS("ACCEPT ACK TYPE"),0)),"^"),1:"")
|
|
S APARMS("VERSION")=$P(NODE,"^",10),APARMS("VERSION")=$S(APARMS("VERSION"):$P($G(^HL(771.5,APARMS("VERSION"),0)),"^"),1:"")
|
|
S APARMS("SENDING APPLICATION")=$P(NODE,"^")
|
|
I APARMS("SENDING APPLICATION") D
|
|
.S APARMS("FIELD SEPARATOR")=$E($G(^HL(771,APARMS("SENDING APPLICATION"),"FS")),1)
|
|
.S:APARMS("FIELD SEPARATOR")="" APARMS("FIELD SEPARATOR")="^"
|
|
.S APARMS("ENCODING CHARACTERS")=$E($G(^HL(771,APARMS("SENDING APPLICATION"),"EC")),1,4)
|
|
.S:APARMS("ENCODING CHARACTERS")="" APARMS("ENCODING CHARACTERS")="~|\&"
|
|
.S APARMS("SENDING APPLICATION")=$P($G(^HL(771,APARMS("SENDING APPLICATION"),0)),"^")
|
|
.I APARMS("SENDING APPLICATION")'="",'$O(^HLD(779.2,"C",APARMS("SENDING APPLICATION"),0)) D
|
|
..;add the sending applcation to the registry
|
|
..N DATA,ERROR
|
|
..S DATA(.01)=APARMS("SENDING APPLICATION")
|
|
..S DATA(2)=$P($G(^ORD(101,HLOEID,0)),"^",12)
|
|
..I $$ADD^HLOASUB1(779.2,,.DATA,.ERROR) ;then will not generate an error
|
|
E D
|
|
.S APARMS("SENDING APPLICATION")=""
|
|
.S APARMS("FIELD SEPARATOR")="^"
|
|
.S APARMS("ENCODING CHARACTERS")="~|\&"
|
|
;
|
|
S APARMS("COUNTRY")="USA"
|
|
;
|
|
;get the subscribers
|
|
D
|
|
.N SUBIEN,HLOSID
|
|
.S SUBIEN=0
|
|
.F S SUBIEN=$O(^ORD(101,HLOEID,775,SUBIEN)) Q:'SUBIEN D
|
|
..N NODE,APP,LINK,EXCLUDE
|
|
..S NODE=$G(^ORD(101,HLOEID,775,SUBIEN,0))
|
|
..S HLOSID=$P(NODE,"^")
|
|
..Q:'HLOSID
|
|
..S NODE=$G(^ORD(101,HLOSID,770))
|
|
..S APP=$P(NODE,"^",2)
|
|
..Q:'APP
|
|
..S LINK=$P(NODE,"^",7)
|
|
..Q:'LINK
|
|
..;
|
|
..;excluded?
|
|
..S (EXCLUDE,I)=0
|
|
..F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLOSID S EXCLUDE=1 Q
|
|
..Q:EXCLUDE
|
|
..;
|
|
..S CT=CT+1
|
|
..S WHO(CT)=HLOSID_"^"_LINK
|
|
..S WHOTO(CT,"RECEIVING APPLICATION")=$P($G(^HL(771,APP,0)),"^")
|
|
..S WHOTO(CT,"FACILITY LINK NAME")=$P($G(^HLCS(870,LINK,0)),"^")
|
|
;
|
|
S I=0
|
|
F S I=$O(HLL("LINKS",I)) Q:'I D
|
|
.N LINK,PROTOCOL
|
|
.S CT=CT+1
|
|
.S PROTOCOL=$P(HLL("LINKS",I),"^")
|
|
.S LINK=$P(HLL("LINKS",I),"^",2)
|
|
.I PROTOCOL=+PROTOCOL D
|
|
..S WHO(CT)=PROTOCOL
|
|
..S PROTOCOL=$P($G(^ORD(101,PROTOCOL,0)),"^")
|
|
.E D
|
|
..S WHO(CT)=$O(^ORD(101,"B",PROTOCOL,0))
|
|
.I LINK=+LINK D
|
|
..S $P(WHO(CT),"^",2)=LINK
|
|
..S LINK=$P($G(^HLCS(870,LINK,0)),"^")
|
|
.E D
|
|
..S $P(WHO(CT),"^",2)=$O(^HLCS(870,"B",LINK,0))
|
|
.S WHOTO(CT,"RECEIVING APPLICATION")=PROTOCOL
|
|
.S WHOTO(CT,"FACILITY LINK NAME")=LINK
|
|
Q
|