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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOCVU 3594 printed Nov 22, 2024@17:08:47 Page 2
HLOCVU ;DAOU/ALA-Conversion Utility ;03/15/2007
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
APAR(HLOEID,APARMS,WHO,WHOTO,HLP,HLL) ; Set up PPARMS array from Protocols
+1 ;
+2 ; Input Parameter
+3 ; HLOEID = IEN of the event protocol
+4 ; HLP - "EXCLUDE SUBSCRIBER" subscript used to ignore specific subscribers
+5 ; HLL - dynamic addressing
+6 ;
+7 ; Output
+8 ; APARMS array
+9 ; WHO - correlates to WHOTO, providing <subscriber protocol ien>,<link ien> (pass by reference)
+10 ; WHOTO array
+11 ;
+12 NEW CT,NODE,I
+13 KILL APARMS,WHO,WHOTO
+14 SET CT=0
+15 if '$GET(HLOEID)
QUIT
+16 SET NODE=$GET(^ORD(101,HLOEID,770))
+17 SET APARMS("EVENT")=$PIECE(NODE,"^",4)
SET APARMS("EVENT")=$SELECT(APARMS("EVENT"):$PIECE($GET(^HL(779.001,APARMS("EVENT"),0)),"^"),1:"")
+18 SET APARMS("MESSAGE TYPE")=$PIECE(NODE,"^",3)
SET APARMS("MESSAGE TYPE")=$SELECT(APARMS("MESSAGE TYPE"):$PIECE($GET(^HL(771.2,APARMS("MESSAGE TYPE"),0)),"^"),1:"")
+19 SET APARMS("APP ACK TYPE")=$PIECE(NODE,"^",9)
SET APARMS("APP ACK TYPE")=$SELECT(APARMS("APP ACK TYPE"):$PIECE($GET(^HL(779.003,APARMS("APP ACK TYPE"),0)),"^"),1:"")
+20 SET APARMS("ACCEPT ACK TYPE")=$PIECE(NODE,"^",8)
SET APARMS("ACCEPT ACK TYPE")=$SELECT(APARMS("ACCEPT ACK TYPE"):$PIECE($GET(^HL(779.003,APARMS("ACCEPT ACK TYPE"),0)),"^"),1:"")
+21 SET APARMS("VERSION")=$PIECE(NODE,"^",10)
SET APARMS("VERSION")=$SELECT(APARMS("VERSION"):$PIECE($GET(^HL(771.5,APARMS("VERSION"),0)),"^"),1:"")
+22 SET APARMS("SENDING APPLICATION")=$PIECE(NODE,"^")
+23 IF APARMS("SENDING APPLICATION")
Begin DoDot:1
+24 SET APARMS("FIELD SEPARATOR")=$EXTRACT($GET(^HL(771,APARMS("SENDING APPLICATION"),"FS")),1)
+25 if APARMS("FIELD SEPARATOR")=""
SET APARMS("FIELD SEPARATOR")="^"
+26 SET APARMS("ENCODING CHARACTERS")=$EXTRACT($GET(^HL(771,APARMS("SENDING APPLICATION"),"EC")),1,4)
+27 if APARMS("ENCODING CHARACTERS")=""
SET APARMS("ENCODING CHARACTERS")="~|\&"
+28 SET APARMS("SENDING APPLICATION")=$PIECE($GET(^HL(771,APARMS("SENDING APPLICATION"),0)),"^")
+29 IF APARMS("SENDING APPLICATION")'=""
IF '$ORDER(^HLD(779.2,"C",APARMS("SENDING APPLICATION"),0))
Begin DoDot:2
+30 ;add the sending applcation to the registry
+31 NEW DATA,ERROR
+32 SET DATA(.01)=APARMS("SENDING APPLICATION")
+33 SET DATA(2)=$PIECE($GET(^ORD(101,HLOEID,0)),"^",12)
+34 ;then will not generate an error
IF $$ADD^HLOASUB1(779.2,,.DATA,.ERROR)
End DoDot:2
End DoDot:1
+35 IF '$TEST
Begin DoDot:1
+36 SET APARMS("SENDING APPLICATION")=""
+37 SET APARMS("FIELD SEPARATOR")="^"
+38 SET APARMS("ENCODING CHARACTERS")="~|\&"
End DoDot:1
+39 ;
+40 SET APARMS("COUNTRY")="USA"
+41 ;
+42 ;get the subscribers
+43 Begin DoDot:1
+44 NEW SUBIEN,HLOSID
+45 SET SUBIEN=0
+46 FOR
SET SUBIEN=$ORDER(^ORD(101,HLOEID,775,SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:2
+47 NEW NODE,APP,LINK,EXCLUDE
+48 SET NODE=$GET(^ORD(101,HLOEID,775,SUBIEN,0))
+49 SET HLOSID=$PIECE(NODE,"^")
+50 if 'HLOSID
QUIT
+51 SET NODE=$GET(^ORD(101,HLOSID,770))
+52 SET APP=$PIECE(NODE,"^",2)
+53 if 'APP
QUIT
+54 SET LINK=$PIECE(NODE,"^",7)
+55 if 'LINK
QUIT
+56 ;
+57 ;excluded?
+58 SET (EXCLUDE,I)=0
+59 FOR
SET I=$ORDER(HLP("EXCLUDE SUBSCRIBER",I))
if 'I
QUIT
IF $GET(HLP("EXCLUDE SUBSCRIBER",I))=HLOSID
SET EXCLUDE=1
QUIT
+60 if EXCLUDE
QUIT
+61 ;
+62 SET CT=CT+1
+63 SET WHO(CT)=HLOSID_"^"_LINK
+64 SET WHOTO(CT,"RECEIVING APPLICATION")=$PIECE($GET(^HL(771,APP,0)),"^")
+65 SET WHOTO(CT,"FACILITY LINK NAME")=$PIECE($GET(^HLCS(870,LINK,0)),"^")
End DoDot:2
End DoDot:1
+66 ;
+67 SET I=0
+68 FOR
SET I=$ORDER(HLL("LINKS",I))
if 'I
QUIT
Begin DoDot:1
+69 NEW LINK,PROTOCOL
+70 SET CT=CT+1
+71 SET PROTOCOL=$PIECE(HLL("LINKS",I),"^")
+72 SET LINK=$PIECE(HLL("LINKS",I),"^",2)
+73 IF PROTOCOL=+PROTOCOL
Begin DoDot:2
+74 SET WHO(CT)=PROTOCOL
+75 SET PROTOCOL=$PIECE($GET(^ORD(101,PROTOCOL,0)),"^")
End DoDot:2
+76 IF '$TEST
Begin DoDot:2
+77 SET WHO(CT)=$ORDER(^ORD(101,"B",PROTOCOL,0))
End DoDot:2
+78 IF LINK=+LINK
Begin DoDot:2
+79 SET $PIECE(WHO(CT),"^",2)=LINK
+80 SET LINK=$PIECE($GET(^HLCS(870,LINK,0)),"^")
End DoDot:2
+81 IF '$TEST
Begin DoDot:2
+82 SET $PIECE(WHO(CT),"^",2)=$ORDER(^HLCS(870,"B",LINK,0))
End DoDot:2
+83 SET WHOTO(CT,"RECEIVING APPLICATION")=PROTOCOL
+84 SET WHOTO(CT,"FACILITY LINK NAME")=LINK
End DoDot:1
+85 QUIT
