source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRU.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1RAHLRU ;HISC/SWM - utilities for HL7 messaging ;03/16/98 11:03
2 ;;5.0;Radiology/Nuclear Medicine;**10,25,81**;Mar 16, 1998;Build 12
3 ;
4 ;IA 2701 used to store ICN in PID-3 ($$GETICN^MPIF001)
5 ;IA 3630 used to build the PID segment for our ORM & ORU HL7 messages
6 ;
7OBX11 ; set OBX-11, = 12th piece of string where piece 1 is "OBX"
8 N RARPTIEN,Y
9 S RARPTIEN=+$G(RARPT)
10 S Y=$P($G(^RARPT(RARPTIEN,0)),U,5)
11 S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",Y="V":"F",1:"I")
12 I $D(^RARPT(RARPTIEN,"ERR")) D Q
13 .S $P(HLA("HLS",RAN),HLFS,12)="C"
14 Q
15 ;
16ESCAPE(XDTA) ;apply the appropriate escape sequence to a string of data
17 ; Insert a escape sequence place holder, then swap the escape sequence
18 ; place holder with the real escape sequence. This action requires two
19 ; passes because the escape sequence uses the escape ("\") character.
20 ; Input: XDTA=data string to be escaped (if necessary)
21 ; HLFS=field separator (global scope; set in INIT^RAHLR)
22 ; HLECH=encoding characters (global scope; set in INIT^RAHLR)
23 ; Return: XDTA=an escaped data string
24 ;
25 N UFS,UCS,URS,UEC,USS ;field, component, repetition, escape, & subcomponent
26 S UFS=HLFS,UCS=$E(HLECH),URS=$E(HLECH,2),UEC=$E(HLECH,3),USS=$E(HLECH,4)
27 F Q:XDTA'[UFS S XDTA=$P(XDTA,UFS)_$C(1)_$P(XDTA,UFS,2,999)
28 F Q:XDTA'[UCS S XDTA=$P(XDTA,UCS)_$C(2)_$P(XDTA,UCS,2,999)
29 F Q:XDTA'[URS S XDTA=$P(XDTA,URS)_$C(3)_$P(XDTA,URS,2,999)
30 F Q:XDTA'[UEC S XDTA=$P(XDTA,UEC)_$C(4)_$P(XDTA,UEC,2,999)
31 F Q:XDTA'[USS S XDTA=$P(XDTA,USS)_$C(5)_$P(XDTA,USS,2,999)
32 F Q:XDTA'[$C(1) S XDTA=$P(XDTA,$C(1))_UEC_"F"_UEC_$P(XDTA,$C(1),2,999)
33 F Q:XDTA'[$C(2) S XDTA=$P(XDTA,$C(2))_UEC_"S"_UEC_$P(XDTA,$C(2),2,999)
34 F Q:XDTA'[$C(3) S XDTA=$P(XDTA,$C(3))_UEC_"R"_UEC_$P(XDTA,$C(3),2,999)
35 F Q:XDTA'[$C(4) S XDTA=$P(XDTA,$C(4))_UEC_"E"_UEC_$P(XDTA,$C(4),2,999)
36 F Q:XDTA'[$C(5) S XDTA=$P(XDTA,$C(5))_UEC_"T"_UEC_$P(XDTA,$C(5),2,999)
37 Q XDTA
38 ;
39 ;
40 ;ESCAPE(STR) ;'Escape out' the formatting codes in data strings...
41 ; Input: Where STR is the data string to 'escape out'.
42 ; ex: "this is a test case^"
43 ;Output: "this is a test case\S\"
44 ;
45 ;assuming the following as our encoding characters (HLECH): "^~\&"
46 ;encoding character position, character representations, & escape seq
47 ;1) component separator "^" \S\
48 ;2) repetition separator "~" \R\
49 ;3) escape character "\" \E\
50 ;4) subcomponent separator "&" \T\
51 ;
52 ;assuming the following as our field separator (HLFS): "|" the escape
53 ;sequence is: \F\. All of the following can be embedded in data, so
54 ;field separator and encoding characters have to be converted to the
55 ;correct formatting codes (escape sequences). We'll accomplish this by
56 ;concatenating the field separator string to the encoding character
57 ;string (ENCDE).
58 ;
59 ;Q:STR="" STR ;no string to escape...
60 ;N BUF,ESC,CH,I1,I2,ENCDE S ENCDE=HLFS_HLECH
61 ;--- Find all occurences of field separator & encoding
62 ;--- characters; save their positions to a local array
63 ;F I1=1:1:5 D
64 ;. S CH=$E(ENCDE,I1),I2=1
65 ;. F S I2=$F(STR,CH,I2) Q:'I2 S BUF(I2-1)=I1
66 ;Q:$D(BUF)<10 STR
67 ;--- Replace HL7 field separator & encoding chars with formatting codes
68 ;S (BUF,I2)="",ESC=$E(HLECH,3) S:ESC="" ESC="\"
69 ;F S I1=I2,I2=$O(BUF(I2)) Q:I2="" D
70 ;. S BUF=BUF_$E(STR,I1+1,I2-1)_ESC_$E("FSRET",BUF(I2))_ESC
71 ;Q BUF_$E(STR,I1+1,$L(STR))
72 ;
73OBXPRC ;Compile 'OBX' Segment for Procedure
74 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$P(RACN0,"^",2)
75 S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_X_$E(HLECH)_"L" D OBX11
76 ; Replace above with following when Imaging can cope with ESC chars
77 ; S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$$ESCAPE(X)_$E(HLECH)_"L" D OBX11
78 Q
79OBXMOD ; Compile 'OBX' segments for both types of modifiers
80 ; Procedure modifiers
81 N X3
82 D MODS^RAUTL2 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"_HLFS_HLFS_Y D OBX11
83 Q:Y(1)="None"
84 ; CPT Modifiers
85 F RAI=1:1 S X0=$P(Y(1),", ",RAI),X1=$P(Y(2),", ",RAI) Q:X0="" D
86 . S RAN=RAN+1
87 . S X3=$$BASICMOD^RACPTMSC(X1,DT)
88 . S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
89 . ; Replace above with following when Imaging can cope with ESC chars
90 . ;S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
91 . I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
92 . ; Replace above with following when Imaging can cope with ESC chars
93 . ;I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
94 . D OBX11
95 . Q
96 Q
97 ;
98OBXTCM ; Compile 'OBX' segment for latest TECH COMMENT
99 ;
100 ; Only Released version of Imaging 2.5 able to handle Tech Comments
101 Q:'($$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5))
102 ;
103 N X4,X3
104 S X4=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
105 Q:X4=""
106 S RAN=RAN+1
107 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"_HLFS_HLFS
108 D OBX11
109 I $L(X4)+$L(HLA("HLS",RAN))'>245 D Q
110 .S $P(HLA("HLS",RAN),HLFS,6)=X4
111 ;
112 ; If Tech Comment is v. long it will need to be
113 ; split into two parts. Do not split words if possible....
114 ;
115 S X3=$E(X4,1,245-$L(HLA("HLS",RAN)))
116 I $L(X3," ")>1 S X3=$P(X3," ",1,$L(X3," ")-1)
117 S X4=$P(X4,X3,2)
118 S $P(HLA("HLS",RAN),HLFS,6)=X3
119 S HLA("HLS",RAN,1)=X4_HLFS_$P(HLA("HLS",RAN),HLFS,7,12)
120 S HLA("HLS",RAN)=$P(HLA("HLS",RAN),HLFS,1,6)
121 Q
122 ;
123INIT ; initialize HL7 variables; called from RAHLR & RAHLRPT
124 Q:'$G(RAEID) ;undefined server application
125 S HLDT=$$NOW^XLFDT(),HLDT1=$$HLDATE^HLFNC(HLDT),EID=RAEID
126 S HL="HLS(""HLS"")",INT=1
127 D INIT^HLFNC2(EID,.HL,INT)
128 Q:'$D(HL("Q")) ;improperly defined server application
129 S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") K EID,INT
130 Q
131 ;
132DOB(X) ;strip off trailing "0"'s from the date of birth
133 I $E(X,5,6)="00" S X=$E(X,1,4) ;if no month then no day, return year
134 E I $E(X,7,8)="00" S X=$E(X,1,6) ;if month & no day, return month/year
135 Q X
136 ;
137CPTMOD(RAIEN,HLECH,DT) ;return OBX-5 as it pertains to CPT Modifiers
138 ;called from: RAHLRPT1 & RAHLR2
139 ;input: RAIEN=IEN of the record in file 81.3
140 ; HLECH=HL7 encoding characters
141 ; DT=today's date
142 N X S X=$$BASICMOD^RACPTMSC(RAIEN,DT)
143 ;1st piece=IEN #81.3; 3rd piece=versioned name; 5th piece=coding sys
144 Q RAIEN_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_$P(X,U,5)
145GETSFLAG(SAN,MTN,ETN,VER) ;Return HL nessage flag (79.721,1)
146 Q:'$L(SAN)!'$L(MTN)!'$L(ETN)!'$L(VER) 0
147 S SAN=$O(^HL(771,"B",SAN,0)) Q:'SAN 0
148 S MTN=$O(^HL(771.2,"B",MTN,0)) Q:'MTN 0
149 S ETN=$O(^HL(779.001,"B",ETN,0)) Q:'ETN 0
150 S VER=$O(^HL(771.5,"B",VER,0)) Q:'VER 0
151 Q +$P($G(^RA(79.7,SAN,1,MTN,1,ETN,1,VER,0)),U,2)
Note: See TracBrowser for help on using the repository browser.