Routine: HLOCVU

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.

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

 .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

HLOCVU.m