source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGHTHL7.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1DGHTHL7 ;ALB/JAM - Home Telehealth Patient Sign-up HL7;10 January 2005 ; 9/25/07 10:18am
2 ;;5.3;Registration;**644**;Aug 13, 1993;Build 11
3 ;
4BLDHL7(DGHTH,MSG) ;Build HL7 Registration message for Home Telehealth
5 ;Input : DGHTH - Arry with Home Telehealth transaction data
6 ; MSG - Array to put message into (full global ref)
7 ;Output: N - Last line number used, or
8 ; 0 - no message built, or
9 ; -1^ErrorText on error
10 ; MSG will contain HL7 message
11 ;Note : Insertion into MSG begins at next available line number
12 ;
13 N DFN,VENDOR,CONSULT,COORD,EVENTDT,VALCHK,DGX,ERR,PROTNAME,VAFPID
14 N HLFS,HLECH,HLQ,HL,EVN,PID,PD1,PV1,LINE,X,Y
15 S ERR=0,X="" F S X=$O(DGHTH(X)) Q:X="" D I ERR Q
16 .I DGHTH(X)="" S VALCHK="-1^Bad Input ("_X_")",ERR=1 Q
17 .S @X=DGHTH(X)
18 I ERR Q $G(VALCHK)
19 I $G(MSG)="" Q "-1^Bad input variable (MSG)"
20 S PROTNAME="DG HOME TELEHEALTH ADT-A04 SERVER"
21 D INIT^HLFNC2(PROTNAME,.HL)
22 I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
23 S LINE=+$O(@MSG@(""),-1)
24 ;
25 ;EVN segment
26 S EVN=$$EVN("A04","A04",EVENTDT)
27 I $P(EVN,U)=-1 K @MSG Q EVN
28 S LINE=LINE+1 S @MSG@(LINE)=EVN
29 ;
30 ;PID segment
31 S PID=$$PID(DFN,.HL,.VAFPID)
32 I $P(PID,U)=-1 Q PID
33 D PIDVAL I ERR Q ERR
34 S DGX=$O(VAFPID(0)),LINE=LINE+1 S @MSG@(LINE)=VAFPID(DGX)
35 F S DGX=$O(VAFPID(DGX)) Q:'DGX D
36 .S @MSG@(LINE,DGX-1)=VAFPID(DGX)
37 ;
38 ;PD1 segment
39 S PD1=$$PD1(DFN,COORD)
40 I $P(PD1,U)=-1 Q PD1
41 S LINE=LINE+1 S @MSG@(LINE)=PD1
42 ;
43 ;PV1 segment
44 S $P(PV1,HLFS,1)=1,$P(PV1,HLFS,5)=CONSULT
45 S $P(PV1,HLFS,39)=$$STA^XUAF4(DUZ(2))
46 S PV1="PV1"_HLFS_PV1
47 S LINE=LINE+1 S @MSG@(LINE)=PV1
48 ;
49 Q LINE
50 ;
51EVN(TYPE,FLAG,DGEVDT) ;Build EVN segment
52 ;Input: TYPE - HL7 event type
53 ; FLAG - HL7 Event Reason Code
54 ; DGEVDT - Event Date/Time [Optional]
55 ;Output: value - EVN segment
56 ; -1^ErrorText on error
57 ;
58 N USRNAM,USERID,COMP,SUBCOMP,EVN
59 I $G(TYPE)=""!($G(FLAG)="") Q "-1^Value missing to build message (EVN segment)"
60 S EVN=$$EVN^VAFHLEVN(TYPE,FLAG,DGEVDT)
61 I ($E(EVN,1,3)'="EVN") Q "-1^Error build message (EVN segment)"
62 ;Add user and user's facility to EVN segment
63 S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4)
64 S USRNAM=$$HLNAME^HLFNC($$GET1^DIQ(200,DUZ_",",.01),HL("ECH"))
65 S USERID=DUZ_COMP_$P(USRNAM,COMP)_COMP_$P(USRNAM,COMP,2)_COMP_COMP_COMP
66 S USERID=USERID_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"L"
67 S USERID=USERID_COMP_COMP_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP
68 S USERID=USERID_$P($$SITE^VASITE,"^",3)_SUBCOMP_"L"
69 S $P(EVN,HLFS,6)=USERID,$P(EVN,HLFS,8)=$P($$SITE^VASITE,HLFS,3)
70 Q EVN
71 ;
72PID(DFN,HL,DGPID) ;Build PID segment
73 ;Input: DFN - Patient DFN
74 ; HL - HL7 values
75 ;Output: DGPIR - PID array segment
76 ; 1 - PID segment build (no error)
77 ; -1^ErrorText on error
78 ;
79 N FLDS,DGX
80 I $G(DFN)="" Q "-1^Value missing to build message (PID segment)"
81 S FLDS=$$COMMANUM^VAFCADT2(1,9)_",10NTB,11,"
82 S FLDS=FLDS_$$COMMANUM^VAFCADT2(12,21)_",22B"
83 D BLDPID^VAFCQRY(DFN,"",FLDS,.DGPID,.HL)
84 S DGX=$O(DGPID(0)) I DGX S DGX=DGPID(DGX)
85 I $P(DGX,"^")'="PID" Q "-1^Error build message (PID segment)"
86 Q 1
87 ;
88PD1(DFN,COORD) ;Build PD1 segment
89 ;Input: DFN - Patient DFN
90 ; COOR - Care Coordinator
91 ;Output: PD1 - PD1 segment
92 ; -1^ErrorText on error
93 ;
94 N PD1,DGNAME
95 I $G(DFN)=""!($G(COORD)="") Q "-1^Value missing to build message (PD1 segment)"
96 S PD1=$$EN^VAFHLPD1(DFN,3)
97 I ($E(PD1,1,3)'="PD1") Q "-1^Error build message (PD1 segment)"
98 S DGNAME("FILE")=200,DGNAME("IENS")=COORD,DGNAME("FIELD")=.01
99 S $P(PD1,HLFS,5)=COORD_$E(HLECH)_$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH))
100 Q PD1
101 ;
102PIDVAL ;validate PID segment
103 ;locate the fields in variable FLDS in VAFPID array, check its not null
104 N NSTR,STR,FLN,FLDS,FLC,X,Y,Z
105 S FLDS="4^6^8^12^20",(FLN,FLN(0))=0,DGX=0
106 S STR="Patient Identifier list^Patient Name^Date of Birth^Patient address^SSN"
107 F S DGX=$O(VAFPID(DGX)) Q:'DGX D I ERR Q
108 .S FLN(DGX)=$L(VAFPID(DGX),"^")-1,FLC=FLN,FLN=FLN+FLN(DGX)
109 .F X=1:1 S Y=$P(FLDS,"^",X) Q:Y="" I Y'="C" D I ERR Q
110 ..I Y'>FLN S $P(FLDS,"^",X)="C" D
111 ...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
112 ...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
113 Q
114 ;
115BLDHL7I(DFN,MSG) ;Build HL7 Registration message for telehealth
116 ;Input : DFN - Pointer to PATIENT
117 ; MSG - Array to put message into (full global ref)
118 ;Output: Last line number used
119 ; -1^ErrorText on error
120 ; MSG will contain HL7 message
121 ;Notes : Insertion into MSG begins at next available line number
122 I '$D(^DPT(DFN,0)) Q "-1^Bad input (DFN)"
123 I $G(MSG)="" Q "-1^Bad input variable (MSG)"
124 N HLFS,HLECH,HLQ,HL,EVN,VAFPID,PV1,LINE,FLDS,DGVEN,DGX
125 N EVNTDT,ERR,PROT4HL7,COMP,SUBCOMP,USRNAM,USERID
126 S PROT4HL7="DG HOME TELEHEALTH ADT-A03 SERVER"
127 D INIT^HLFNC2(PROT4HL7,.HL)
128 I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
129 S EVNTDT=$$NOW^XLFDT()
130 S LINE=+$O(@MSG@(""),-1)
131 ;EVN segment
132 S EVN=$$EVN("A03","A03",EVNTDT)
133 I EVN<0 K @MSG Q "-1^Error build message (EVN segment)"
134 S LINE=LINE+1
135 S @MSG@(LINE)=EVN
136 ;
137 ;PID segment
138 N DGX
139 S PID=$$PID(DGDFN,.HL,.VAFPID)
140 I +PID'>0 S ERR=1 K @MSG Q "-1^Error build message (PID segment)"
141 S DGX=$O(VAFPID(0)),LINE=LINE+1 S @MSG@(LINE)=VAFPID(DGX)
142 F S DGX=$O(VAFPID(DGX)) Q:'DGX D
143 .S @MSG@(LINE,DGX-1)=VAFPID(DGX)
144 ;Done
145 Q 1
146SNDHL7(MSG,PTRRCV,PROTNAME) ;Send HL7 Home Telehealth message to server
147 ;Input : MSG - Array containing HL7 message to transmit
148 ; (full global reference)
149 ; - Must be in format required for interaction
150 ; with the HL7 package
151 ; PTRRCV - Pointer for vendor receiving system
152 ; PROTNAME - Protocol name
153 ;Output: Message ID
154 ; Message ID or 0^ErrorText on error
155 ;Notes : The global array ^TMP("HLS",$J) will be KILLed if MSG
156 ; does not use this global location
157 I $G(MSG)="" Q "-1^Bad input variable(MSG)"
158 I '$G(PTRRCV) Q "-1^Bad input variable for vendor (PTRRCV)"
159 I ($O(@MSG@(""))="") Q "-1^Message empty... can't send empty"
160 N DGARRAY,HL,HLL,HLFS,HLECH,HLQ,HLMTIEN,HLRESLT,HLP,KILLARRY,ARRY4HL7,APPINFO,DIC,CLPROT,SIEN,LINK
161 S ARRY4HL7=$NA(^TMP("HLS",$J))
162 D INIT^HLFNC2(PROTNAME,.HL)
163 I ($O(HL(""))="") Q "-1^Unable to initialize HL7 variables"
164 S APPINFO=$$APP4MSH(PTRRCV)
165 I APPINFO="" Q "-1^Unable to determine receiving system information"
166 ;See if MSG is ^TMP("HLS",$J)
167 S KILLARRY=0
168 I (MSG'=ARRY4HL7) D
169 .;Make sure '$J' wasn't used
170 .Q:(MSG="^TMP(""HLS"",$J)")
171 .;Initialize ^TMP("HLS",$J) and merge XMITARRY into it
172 .K @ARRY4HL7
173 .M @ARRY4HL7=@MSG
174 .S KILLARRY=1
175 ;Using dynamic MSH segment
176 S $P(HLP("SUBSCRIBER"),"^",2)="DG HOME TELEHEALTH"
177 S $P(HLP("SUBSCRIBER"),"^",3)=$P(APPINFO,"^",1)
178 S $P(HLP("SUBSCRIBER"),"^",4)="HTAPPL"
179 S $P(HLP("SUBSCRIBER"),"^",5)=$P(APPINFO,"^",2)
180 S HLP("PRIORITY")="I" ;Immediate priority
181 ;Get subscriber protocol
182 S DIC="^ORD(101,",DIC(0)="B",X=PROTNAME D ^DIC
183 D GETS^DIQ(101,+Y,"775*","E","ARRAY1")
184 S CLPROT=ARRAY1(101.0775,$O(ARRAY1(101.0775,0)),.01,"E")
185 ;Use inst file ien to retrieve logical link for dynamic addressing
186 D LINK^HLUTIL3(DGVEN,.DGARRAY,"")
187 S LINK=DGARRAY($O(DGARRAY(0)))
188 S HLL("LINKS",1)=CLPROT_U_LINK
189 D GENERATE^HLMA(PROTNAME,"GM",1,.HLRESLT,"",.HLP)
190 ;S:('HLRESLT) HLRESLT=$P(HLRESLT,"^",2,3)
191 ;Delete ^TMP("HLS",$J) if MSG was different
192 K:(KILLARRY) @ARRY4HL7
193 ;Done
194 Q HLRESLT
195 ;
196APP4MSH(PTRRCV) ;Determine sending and receiving application for MSH segment
197 ;Input : PTRRCV = Pointer to file #4 for receiving system
198 ;Output: Sending Facility ^ Receiving Facility
199 ; Null = Error/bad input
200 N SNDFAC,RCVFAC
201 I 'PTRRCV Q ""
202 I $$GET1^DIQ(4,PTRRCV,.01)="" Q ""
203 S SNDFAC=$P($$SITE^VASITE(),"^",3)_$E(HLECH)
204 S SNDFAC=SNDFAC_$$GET1^DIQ(4,$P($$SITE^VASITE(),"^"),60,"E")_$E(HLECH)
205 S SNDFAC=SNDFAC_"DNS"
206 S RCVFAC=$$GET1^DIQ(4,PTRRCV,99,"E")_$E(HLECH)
207 S RCVFAC=RCVFAC_$$GET1^DIQ(4,PTRRCV,60,"E")_$E(HLECH)_"DNS"
208 Q SNDFAC_"^"_RCVFAC
Note: See TracBrowser for help on using the repository browser.