source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCVU.m@ 1427

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