DGHTHL7 ;ALB/JAM - Home Telehealth Patient Sign-up HL7;10 January 2005 ; 9/25/07 10:18am
;;5.3;Registration;**644,1016**;Aug 13, 1993;Build 20
;
BLDHL7(DGHTH,MSG) ;Build HL7 Registration message for Home Telehealth
;Input : DGHTH - Arry with Home Telehealth transaction data
; MSG - Array to put message into (full global ref)
;Output: N - Last line number used, or
; 0 - no message built, or
; -1^ErrorText on error
; MSG will contain HL7 message
;Note : Insertion into MSG begins at next available line number
;
N DFN,VENDOR,CONSULT,COORD,EVENTDT,VALCHK,DGX,ERR,PROTNAME,VAFPID
N HLFS,HLECH,HLQ,HL,EVN,PID,PD1,PV1,LINE,X,Y
S ERR=0,X="" F S X=$O(DGHTH(X)) Q:X="" D I ERR Q
.I DGHTH(X)="" S VALCHK="-1^Bad Input ("_X_")",ERR=1 Q
.S @X=DGHTH(X)
I ERR Q $G(VALCHK)
I $G(MSG)="" Q "-1^Bad input variable (MSG)"
S PROTNAME="DG HOME TELEHEALTH ADT-A04 SERVER"
D INIT^HLFNC2(PROTNAME,.HL)
I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
S LINE=+$O(@MSG@(""),-1)
;
;EVN segment
S EVN=$$EVN("A04","A04",EVENTDT)
I $P(EVN,U)=-1 K @MSG Q EVN
S LINE=LINE+1 S @MSG@(LINE)=EVN
;
;PID segment
S PID=$$PID(DFN,.HL,.VAFPID)
I $P(PID,U)=-1 Q PID
D PIDVAL I ERR Q ERR
S DGX=$O(VAFPID(0)),LINE=LINE+1 S @MSG@(LINE)=VAFPID(DGX)
F S DGX=$O(VAFPID(DGX)) Q:'DGX D
.S @MSG@(LINE,DGX-1)=VAFPID(DGX)
;
;PD1 segment
S PD1=$$PD1(DFN,COORD)
I $P(PD1,U)=-1 Q PD1
S LINE=LINE+1 S @MSG@(LINE)=PD1
;
;PV1 segment
S $P(PV1,HLFS,1)=1,$P(PV1,HLFS,5)=CONSULT
S $P(PV1,HLFS,39)=$$STA^XUAF4(DUZ(2))
S PV1="PV1"_HLFS_PV1
S LINE=LINE+1 S @MSG@(LINE)=PV1
;
Q LINE
;
EVN(TYPE,FLAG,DGEVDT) ;Build EVN segment
;Input: TYPE - HL7 event type
; FLAG - HL7 Event Reason Code
; DGEVDT - Event Date/Time [Optional]
;Output: value - EVN segment
; -1^ErrorText on error
;
N USRNAM,USERID,COMP,SUBCOMP,EVN
I $G(TYPE)=""!($G(FLAG)="") Q "-1^Value missing to build message (EVN segment)"
S EVN=$$EVN^VAFHLEVN(TYPE,FLAG,DGEVDT)
I ($E(EVN,1,3)'="EVN") Q "-1^Error build message (EVN segment)"
;Add user and user's facility to EVN segment
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4)
S USRNAM=$$HLNAME^HLFNC($$GET1^DIQ(200,DUZ_",",.01),HL("ECH"))
S USERID=DUZ_COMP_$P(USRNAM,COMP)_COMP_$P(USRNAM,COMP,2)_COMP_COMP_COMP
S USERID=USERID_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"L"
S USERID=USERID_COMP_COMP_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP
S USERID=USERID_$P($$SITE^VASITE,"^",3)_SUBCOMP_"L"
S $P(EVN,HLFS,6)=USERID,$P(EVN,HLFS,8)=$P($$SITE^VASITE,HLFS,3)
Q EVN
;
PID(DFN,HL,DGPID) ;Build PID segment
;Input: DFN - Patient DFN
; HL - HL7 values
;Output: DGPIR - PID array segment
; 1 - PID segment build (no error)
; -1^ErrorText on error
;
N FLDS,DGX
I $G(DFN)="" Q "-1^Value missing to build message (PID segment)"
S FLDS=$$COMMANUM^VAFCADT2(1,9)_",10NTB,11,"
S FLDS=FLDS_$$COMMANUM^VAFCADT2(12,21)_",22B"
D BLDPID^VAFCQRY(DFN,"",FLDS,.DGPID,.HL)
S DGX=$O(DGPID(0)) I DGX S DGX=DGPID(DGX)
I $P(DGX,"^")'="PID" Q "-1^Error build message (PID segment)"
Q 1
;
PD1(DFN,COORD) ;Build PD1 segment
;Input: DFN - Patient DFN
; COOR - Care Coordinator
;Output: PD1 - PD1 segment
; -1^ErrorText on error
;
N PD1,DGNAME
I $G(DFN)=""!($G(COORD)="") Q "-1^Value missing to build message (PD1 segment)"
S PD1=$$EN^VAFHLPD1(DFN,3)
I ($E(PD1,1,3)'="PD1") Q "-1^Error build message (PD1 segment)"
S DGNAME("FILE")=200,DGNAME("IENS")=COORD,DGNAME("FIELD")=.01
S $P(PD1,HLFS,5)=COORD_$E(HLECH)_$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH))
Q PD1
;
PIDVAL ;validate PID segment
;locate the fields in variable FLDS in VAFPID array, check its not null
N NSTR,STR,FLN,FLDS,FLC,X,Y,Z
S FLDS="4^6^8^12^20",(FLN,FLN(0))=0,DGX=0
S STR="Patient Identifier list^Patient Name^Date of Birth^Patient address^SSN"
F S DGX=$O(VAFPID(DGX)) Q:'DGX D I ERR Q
.S FLN(DGX)=$L(VAFPID(DGX),"^")-1,FLC=FLN,FLN=FLN+FLN(DGX)
.F X=1:1 S Y=$P(FLDS,"^",X) Q:Y="" I Y'="C" D I ERR Q
..I Y'>FLN S $P(FLDS,"^",X)="C" D
...I FLN(DGX)=FLN S:($P(VAFPID(DGX),"^",Y-FLC)="")!($P(VAFPID(DGX),"^",Y-FLC)="""""") ERR="-1^Error in PID-"_(Y-1)_" field ("_$P(STR,"^",X)_")" Q
...S NSTR=$P(VAFPID(DGX-1),"^",FLN(DGX-1)+1)_VAFPID(DGX) I ($P(NSTR,"^",Y-FLC)="")!($P(NSTR,"^",Y-FLC)="""""") S ERR="-1^Error in PID-"_(Y-1)_" field ("_$P(STR,"^",X)_")" Q
Q
;
BLDHL7I(DFN,MSG) ;Build HL7 Registration message for telehealth
;Input : DFN - Pointer to PATIENT
; MSG - Array to put message into (full global ref)
;Output: Last line number used
; -1^ErrorText on error
; MSG will contain HL7 message
;Notes : Insertion into MSG begins at next available line number
I '$D(^DPT(DFN,0)) Q "-1^Bad input (DFN)"
I $G(MSG)="" Q "-1^Bad input variable (MSG)"
N HLFS,HLECH,HLQ,HL,EVN,VAFPID,PV1,LINE,FLDS,DGVEN,DGX
N EVNTDT,ERR,PROT4HL7,COMP,SUBCOMP,USRNAM,USERID
S PROT4HL7="DG HOME TELEHEALTH ADT-A03 SERVER"
D INIT^HLFNC2(PROT4HL7,.HL)
I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
S EVNTDT=$$NOW^XLFDT()
S LINE=+$O(@MSG@(""),-1)
;EVN segment
S EVN=$$EVN("A03","A03",EVNTDT)
I EVN<0 K @MSG Q "-1^Error build message (EVN segment)"
S LINE=LINE+1
S @MSG@(LINE)=EVN
;
;PID segment
N DGX
S PID=$$PID(DGDFN,.HL,.VAFPID)
I +PID'>0 S ERR=1 K @MSG Q "-1^Error build message (PID segment)"
S DGX=$O(VAFPID(0)),LINE=LINE+1 S @MSG@(LINE)=VAFPID(DGX)
F S DGX=$O(VAFPID(DGX)) Q:'DGX D
.S @MSG@(LINE,DGX-1)=VAFPID(DGX)
;Done
Q 1
SNDHL7(MSG,PTRRCV,PROTNAME) ;Send HL7 Home Telehealth message to server
;Input : MSG - Array containing HL7 message to transmit
; (full global reference)
; - Must be in format required for interaction
; with the HL7 package
; PTRRCV - Pointer for vendor receiving system
; PROTNAME - Protocol name
;Output: Message ID
; Message ID or 0^ErrorText on error
;Notes : The global array ^TMP("HLS",$J) will be KILLed if MSG
; does not use this global location
I $G(MSG)="" Q "-1^Bad input variable(MSG)"
I '$G(PTRRCV) Q "-1^Bad input variable for vendor (PTRRCV)"
I ($O(@MSG@(""))="") Q "-1^Message empty... can't send empty"
N DGARRAY,HL,HLL,HLFS,HLECH,HLQ,HLMTIEN,HLRESLT,HLP,KILLARRY,ARRY4HL7,APPINFO,DIC,CLPROT,SIEN,LINK
S ARRY4HL7=$NA(^TMP("HLS",$J))
D INIT^HLFNC2(PROTNAME,.HL)
I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
S APPINFO=$$APP4MSH(PTRRCV)
I APPINFO="" Q "-1^Unable to determine receiving system information"
;See if MSG is ^TMP("HLS",$J)
S KILLARRY=0
I (MSG'=ARRY4HL7) D
.;Make sure '$J' wasn't used
.Q:(MSG="^TMP(""HLS"",$J)")
.;Initialize ^TMP("HLS",$J) and merge XMITARRY into it
.K @ARRY4HL7
.M @ARRY4HL7=@MSG
.S KILLARRY=1
;Using dynamic MSH segment
S $P(HLP("SUBSCRIBER"),"^",2)="DG HOME TELEHEALTH"
S $P(HLP("SUBSCRIBER"),"^",3)=$P(APPINFO,"^",1)
S $P(HLP("SUBSCRIBER"),"^",4)="HTAPPL"
S $P(HLP("SUBSCRIBER"),"^",5)=$P(APPINFO,"^",2)
S HLP("PRIORITY")="I" ;Immediate priority
;Get subscriber protocol
S DIC="^ORD(101,",DIC(0)="B",X=PROTNAME D ^DIC
D GETS^DIQ(101,+Y,"775*","E","ARRAY1")
S CLPROT=ARRAY1(101.0775,$O(ARRAY1(101.0775,0)),.01,"E")
;Use inst file ien to retrieve logical link for dynamic addressing
D LINK^HLUTIL3(DGVEN,.DGARRAY,"")
S LINK=DGARRAY($O(DGARRAY(0)))
S HLL("LINKS",1)=CLPROT_U_LINK
D GENERATE^HLMA(PROTNAME,"GM",1,.HLRESLT,"",.HLP)
;S:('HLRESLT) HLRESLT=$P(HLRESLT,"^",2,3)
;Delete ^TMP("HLS",$J) if MSG was different
K:(KILLARRY) @ARRY4HL7
;Done
Q HLRESLT
;
APP4MSH(PTRRCV) ;Determine sending and receiving application for MSH segment
;Input : PTRRCV = Pointer to file #4 for receiving system
;Output: Sending Facility ^ Receiving Facility
; Null = Error/bad input
N SNDFAC,RCVFAC
I 'PTRRCV Q ""
I $$GET1^DIQ(4,PTRRCV,.01)="" Q ""
S SNDFAC=$P($$SITE^VASITE(),"^",3)_$E(HLECH)
S SNDFAC=SNDFAC_$$GET1^DIQ(4,$P($$SITE^VASITE(),"^"),60,"E")_$E(HLECH)
S SNDFAC=SNDFAC_"DNS"
S RCVFAC=$$GET1^DIQ(4,PTRRCV,99,"E")_$E(HLECH)
S RCVFAC=RCVFAC_$$GET1^DIQ(4,PTRRCV,60,"E")_$E(HLECH)_"DNS"
Q SNDFAC_"^"_RCVFAC
DGHTHL7 ;ALB/JAM - Home Telehealth Patient Sign-up HL7;10 January 2005 ; 9/25/07 10:18am
+1 ;;5.3;Registration;**644,1016**;Aug 13, 1993;Build 20
+2 ;
BLDHL7(DGHTH,MSG) ;Build HL7 Registration message for Home Telehealth
+1 ;Input : DGHTH - Arry with Home Telehealth transaction data
+2 ; MSG - Array to put message into (full global ref)
+3 ;Output: N - Last line number used, or
+4 ; 0 - no message built, or
+5 ; -1^ErrorText on error
+6 ; MSG will contain HL7 message
+7 ;Note : Insertion into MSG begins at next available line number
+8 ;
+9 NEW DFN,VENDOR,CONSULT,COORD,EVENTDT,VALCHK,DGX,ERR,PROTNAME,VAFPID
+10 NEW HLFS,HLECH,HLQ,HL,EVN,PID,PD1,PV1,LINE,X,Y
+11 SET ERR=0
SET X=""
FOR
SET X=$ORDER(DGHTH(X))
IF X=""
QUIT
Begin DoDot:1
+12 IF DGHTH(X)=""
SET VALCHK="-1^Bad Input ("_X_")"
SET ERR=1
QUIT
+13 SET @X=DGHTH(X)
End DoDot:1
IF ERR
QUIT
+14 IF ERR
QUIT $GET(VALCHK)
+15 IF $GET(MSG)=""
QUIT "-1^Bad input variable (MSG)"
+16 SET PROTNAME="DG HOME TELEHEALTH ADT-A04 SERVER"
+17 DO INIT^HLFNC2(PROTNAME,.HL)
+18 IF ($ORDER(HL(""))="")
QUIT "-1^Unable to initialize HL7 variables"
+19 SET LINE=+$ORDER(@MSG@(""),-1)
+20 ;
+21 ;EVN segment
+22 SET EVN=$$EVN("A04","A04",EVENTDT)
+23 IF $PIECE(EVN,U)=-1
KILL @MSG
QUIT EVN
+24 SET LINE=LINE+1
SET @MSG@(LINE)=EVN
+25 ;
+26 ;PID segment
+27 SET PID=$$PID(DFN,.HL,.VAFPID)
+28 IF $PIECE(PID,U)=-1
QUIT PID
+29 DO PIDVAL
IF ERR
QUIT ERR
+30 SET DGX=$ORDER(VAFPID(0))
SET LINE=LINE+1
SET @MSG@(LINE)=VAFPID(DGX)
+31 FOR
SET DGX=$ORDER(VAFPID(DGX))
IF 'DGX
QUIT
Begin DoDot:1
+32 SET @MSG@(LINE,DGX-1)=VAFPID(DGX)
End DoDot:1
+33 ;
+34 ;PD1 segment
+35 SET PD1=$$PD1(DFN,COORD)
+36 IF $PIECE(PD1,U)=-1
QUIT PD1
+37 SET LINE=LINE+1
SET @MSG@(LINE)=PD1
+38 ;
+39 ;PV1 segment
+40 SET $PIECE(PV1,HLFS,1)=1
SET $PIECE(PV1,HLFS,5)=CONSULT
+41 SET $PIECE(PV1,HLFS,39)=$$STA^XUAF4(DUZ(2))
+42 SET PV1="PV1"_HLFS_PV1
+43 SET LINE=LINE+1
SET @MSG@(LINE)=PV1
+44 ;
+45 QUIT LINE
+46 ;
EVN(TYPE,FLAG,DGEVDT) ;Build EVN segment
+1 ;Input: TYPE - HL7 event type
+2 ; FLAG - HL7 Event Reason Code
+3 ; DGEVDT - Event Date/Time [Optional]
+4 ;Output: value - EVN segment
+5 ; -1^ErrorText on error
+6 ;
+7 NEW USRNAM,USERID,COMP,SUBCOMP,EVN
+8 IF $GET(TYPE)=""!($GET(FLAG)="")
QUIT "-1^Value missing to build message (EVN segment)"
+9 SET EVN=$$EVN^VAFHLEVN(TYPE,FLAG,DGEVDT)
+10 IF ($EXTRACT(EVN,1,3)'="EVN")
QUIT "-1^Error build message (EVN segment)"
+11 ;Add user and user's facility to EVN segment
+12 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+13 SET USRNAM=$$HLNAME^HLFNC($$GET1^DIQ(200,DUZ_",",.01),HL("ECH"))
+14 SET USERID=DUZ_COMP_$PIECE(USRNAM,COMP)_COMP_$PIECE(USRNAM,COMP,2)_COMP_COMP_COMP
+15 SET USERID=USERID_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"L"
+16 SET USERID=USERID_COMP_COMP_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP
+17 SET USERID=USERID_$PIECE($$SITE^VASITE,"^",3)_SUBCOMP_"L"
+18 SET $PIECE(EVN,HLFS,6)=USERID
SET $PIECE(EVN,HLFS,8)=$PIECE($$SITE^VASITE,HLFS,3)
+19 QUIT EVN
+20 ;
PID(DFN,HL,DGPID) ;Build PID segment
+1 ;Input: DFN - Patient DFN
+2 ; HL - HL7 values
+3 ;Output: DGPIR - PID array segment
+4 ; 1 - PID segment build (no error)
+5 ; -1^ErrorText on error
+6 ;
+7 NEW FLDS,DGX
+8 IF $GET(DFN)=""
QUIT "-1^Value missing to build message (PID segment)"
+9 SET FLDS=$$COMMANUM^VAFCADT2(1,9)_",10NTB,11,"
+10 SET FLDS=FLDS_$$COMMANUM^VAFCADT2(12,21)_",22B"
+11 DO BLDPID^VAFCQRY(DFN,"",FLDS,.DGPID,.HL)
+12 SET DGX=$ORDER(DGPID(0))
IF DGX
SET DGX=DGPID(DGX)
+13 IF $PIECE(DGX,"^")'="PID"
QUIT "-1^Error build message (PID segment)"
+14 QUIT 1
+15 ;
PD1(DFN,COORD) ;Build PD1 segment
+1 ;Input: DFN - Patient DFN
+2 ; COOR - Care Coordinator
+3 ;Output: PD1 - PD1 segment
+4 ; -1^ErrorText on error
+5 ;
+6 NEW PD1,DGNAME
+7 IF $GET(DFN)=""!($GET(COORD)="")
QUIT "-1^Value missing to build message (PD1 segment)"
+8 SET PD1=$$EN^VAFHLPD1(DFN,3)
+9 IF ($EXTRACT(PD1,1,3)'="PD1")
QUIT "-1^Error build message (PD1 segment)"
+10 SET DGNAME("FILE")=200
SET DGNAME("IENS")=COORD
SET DGNAME("FIELD")=.01
+11 SET $PIECE(PD1,HLFS,5)=COORD_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.DGNAME,"",$EXTRACT(HLECH))
+12 QUIT PD1
+13 ;
PIDVAL ;validate PID segment
+1 ;locate the fields in variable FLDS in VAFPID array, check its not null
+2 NEW NSTR,STR,FLN,FLDS,FLC,X,Y,Z
+3 SET FLDS="4^6^8^12^20"
SET (FLN,FLN(0))=0
SET DGX=0
+4 SET STR="Patient Identifier list^Patient Name^Date of Birth^Patient address^SSN"
+5 FOR
SET DGX=$ORDER(VAFPID(DGX))
IF 'DGX
QUIT
Begin DoDot:1
+6 SET FLN(DGX)=$LENGTH(VAFPID(DGX),"^")-1
SET FLC=FLN
SET FLN=FLN+FLN(DGX)
+7 FOR X=1:1
SET Y=$PIECE(FLDS,"^",X)
IF Y=""
QUIT
IF Y'="C"
Begin DoDot:2
+8 IF Y'>FLN
SET $PIECE(FLDS,"^",X)="C"
Begin DoDot:3
+9 IF FLN(DGX)=FLN
IF ($PIECE(VAFPID(DGX),"^",Y-FLC)="")!($PIECE(VAFPID(DGX),"^",Y-FLC)="""""")
SET ERR="-1^Error in PID-"_(Y-1)_" field ("_$PIECE(STR,"^",X)_")"
QUIT
+10 SET NSTR=$PIECE(VAFPID(DGX-1),"^",FLN(DGX-1)+1)_VAFPID(DGX)
IF ($PIECE(NSTR,"^",Y-FLC)="")!($PIECE(NSTR,"^",Y-FLC)="""""")
SET ERR="-1^Error in PID-"_(Y-1)_" field ("_$PIECE(STR,"^",X)_")"
QUIT
End DoDot:3
End DoDot:2
IF ERR
QUIT
End DoDot:1
IF ERR
QUIT
+11 QUIT
+12 ;
BLDHL7I(DFN,MSG) ;Build HL7 Registration message for telehealth
+1 ;Input : DFN - Pointer to PATIENT
+2 ; MSG - Array to put message into (full global ref)
+3 ;Output: Last line number used
+4 ; -1^ErrorText on error
+5 ; MSG will contain HL7 message
+6 ;Notes : Insertion into MSG begins at next available line number
+7 IF '$DATA(^DPT(DFN,0))
QUIT "-1^Bad input (DFN)"
+8 IF $GET(MSG)=""
QUIT "-1^Bad input variable (MSG)"
+9 NEW HLFS,HLECH,HLQ,HL,EVN,VAFPID,PV1,LINE,FLDS,DGVEN,DGX
+10 NEW EVNTDT,ERR,PROT4HL7,COMP,SUBCOMP,USRNAM,USERID
+11 SET PROT4HL7="DG HOME TELEHEALTH ADT-A03 SERVER"
+12 DO INIT^HLFNC2(PROT4HL7,.HL)
+13 IF ($ORDER(HL(""))="")
QUIT "-1^Unable to initialize HL7 variables"
+14 SET EVNTDT=$$NOW^XLFDT()
+15 SET LINE=+$ORDER(@MSG@(""),-1)
+16 ;EVN segment
+17 SET EVN=$$EVN("A03","A03",EVNTDT)
+18 IF EVN<0
KILL @MSG
QUIT "-1^Error build message (EVN segment)"
+19 SET LINE=LINE+1
+20 SET @MSG@(LINE)=EVN
+21 ;
+22 ;PID segment
+23 NEW DGX
+24 SET PID=$$PID(DGDFN,.HL,.VAFPID)
+25 IF +PID'>0
SET ERR=1
KILL @MSG
QUIT "-1^Error build message (PID segment)"
+26 SET DGX=$ORDER(VAFPID(0))
SET LINE=LINE+1
SET @MSG@(LINE)=VAFPID(DGX)
+27 FOR
SET DGX=$ORDER(VAFPID(DGX))
IF 'DGX
QUIT
Begin DoDot:1
+28 SET @MSG@(LINE,DGX-1)=VAFPID(DGX)
End DoDot:1
+29 ;Done
+30 QUIT 1
SNDHL7(MSG,PTRRCV,PROTNAME) ;Send HL7 Home Telehealth message to server
+1 ;Input : MSG - Array containing HL7 message to transmit
+2 ; (full global reference)
+3 ; - Must be in format required for interaction
+4 ; with the HL7 package
+5 ; PTRRCV - Pointer for vendor receiving system
+6 ; PROTNAME - Protocol name
+7 ;Output: Message ID
+8 ; Message ID or 0^ErrorText on error
+9 ;Notes : The global array ^TMP("HLS",$J) will be KILLed if MSG
+10 ; does not use this global location
+11 IF $GET(MSG)=""
QUIT "-1^Bad input variable(MSG)"
+12 IF '$GET(PTRRCV)
QUIT "-1^Bad input variable for vendor (PTRRCV)"
+13 IF ($ORDER(@MSG@(""))="")
QUIT "-1^Message empty... can't send empty"
+14 NEW DGARRAY,HL,HLL,HLFS,HLECH,HLQ,HLMTIEN,HLRESLT,HLP,KILLARRY,ARRY4HL7,APPINFO,DIC,CLPROT,SIEN,LINK
+15 SET ARRY4HL7=$NAME(^TMP("HLS",$JOB))
+16 DO INIT^HLFNC2(PROTNAME,.HL)
+17 IF ($ORDER(HL(""))="")
QUIT "-1^Unable to initialize HL7 variables"
+18 SET APPINFO=$$APP4MSH(PTRRCV)
+19 IF APPINFO=""
QUIT "-1^Unable to determine receiving system information"
+20 ;See if MSG is ^TMP("HLS",$J)
+21 SET KILLARRY=0
+22 IF (MSG'=ARRY4HL7)
Begin DoDot:1
+23 ;Make sure '$J' wasn't used
+24 IF (MSG="^TMP(""HLS"",$J)")
QUIT
+25 ;Initialize ^TMP("HLS",$J) and merge XMITARRY into it
+26 KILL @ARRY4HL7
+27 MERGE @ARRY4HL7=@MSG
+28 SET KILLARRY=1
End DoDot:1
+29 ;Using dynamic MSH segment
+30 SET $PIECE(HLP("SUBSCRIBER"),"^",2)="DG HOME TELEHEALTH"
+31 SET $PIECE(HLP("SUBSCRIBER"),"^",3)=$PIECE(APPINFO,"^",1)
+32 SET $PIECE(HLP("SUBSCRIBER"),"^",4)="HTAPPL"
+33 SET $PIECE(HLP("SUBSCRIBER"),"^",5)=$PIECE(APPINFO,"^",2)
+34 ;Immediate priority
SET HLP("PRIORITY")="I"
+35 ;Get subscriber protocol
+36 SET DIC="^ORD(101,"
SET DIC(0)="B"
SET X=PROTNAME
DO ^DIC
+37 DO GETS^DIQ(101,+Y,"775*","E","ARRAY1")
+38 SET CLPROT=ARRAY1(101.0775,$ORDER(ARRAY1(101.0775,0)),.01,"E")
+39 ;Use inst file ien to retrieve logical link for dynamic addressing
+40 DO LINK^HLUTIL3(DGVEN,.DGARRAY,"")
+41 SET LINK=DGARRAY($ORDER(DGARRAY(0)))
+42 SET HLL("LINKS",1)=CLPROT_U_LINK
+43 DO GENERATE^HLMA(PROTNAME,"GM",1,.HLRESLT,"",.HLP)
+44 ;S:('HLRESLT) HLRESLT=$P(HLRESLT,"^",2,3)
+45 ;Delete ^TMP("HLS",$J) if MSG was different
+46 IF (KILLARRY)
KILL @ARRY4HL7
+47 ;Done
+48 QUIT HLRESLT
+49 ;
APP4MSH(PTRRCV) ;Determine sending and receiving application for MSH segment
+1 ;Input : PTRRCV = Pointer to file #4 for receiving system
+2 ;Output: Sending Facility ^ Receiving Facility
+3 ; Null = Error/bad input
+4 NEW SNDFAC,RCVFAC
+5 IF 'PTRRCV
QUIT ""
+6 IF $$GET1^DIQ(4,PTRRCV,.01)=""
QUIT ""
+7 SET SNDFAC=$PIECE($$SITE^VASITE(),"^",3)_$EXTRACT(HLECH)
+8 SET SNDFAC=SNDFAC_$$GET1^DIQ(4,$PIECE($$SITE^VASITE(),"^"),60,"E")_$EXTRACT(HLECH)
+9 SET SNDFAC=SNDFAC_"DNS"
+10 SET RCVFAC=$$GET1^DIQ(4,PTRRCV,99,"E")_$EXTRACT(HLECH)
+11 SET RCVFAC=RCVFAC_$$GET1^DIQ(4,PTRRCV,60,"E")_$EXTRACT(HLECH)_"DNS"
+12 QUIT SNDFAC_"^"_RCVFAC
