source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLBMS.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1RAHLBMS ;HIRMFO/REL,GJC-Bridge, MedSpeak compatible to HL7 v1.6 ;11/18/97 12:12
2 ;;5.0;Radiology/Nuclear Medicine;**4**;Mar 16, 1998
3EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
4 ; message from HL7.
5 S RASUB=HL("MID") K RAERR
6 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7
7 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
8 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
9 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")="IBM/MEDSPEAK"
10 F I=1:1 X HLNEXT Q:HLQUIT'>0 S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J)
11 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))
12PID ; Pick data off the 'PID' segment.
13 I $P(SEGMNT,HL("FS"))="PID" D
14 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
15 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D
16 .. S ^TMP("RARPT-REC",$J,RASUB,"RADFN")=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))
17 .. Q
18 . I $P(SEGMNT,HL("FS"),19)]"" D
19 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)
20 .. Q
21 . Q
22 E S RAERR="Missing PID segment" D XIT Q
23 ; Save off E-Sig information (if it exists)
24 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
25 ;
26OBR ; Pick data off the 'OBR' segment.
27 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR" ; find the 'OBR' segment
28 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q
29 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
30 I $P(SEGMNT,HL("FS"),3)]"" D
31 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
32 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" ^TMP("RARPT-REC",$J,RASUB,"RADTI")=$P($P(RADTCN,$E(HL("ECH"))),"-")
33 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" ^TMP("RARPT-REC",$J,RASUB,"RACNI")=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
34 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
35 . Q
36 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
37 I RAHLD="" S RAERR="Missing Report Status" D XIT Q
38 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q
39 S ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=RAHLD
40 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
41 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q
42 S RAVERF=RAHLD
43 ; ----- Check the validity of the provider name -----
44 I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200
45 . D VFIER ; if one partial match found, return the entry ien
46 . Q
47 E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
48 . S RAVERF=$O(^VA(200,"B",RAVERF,0))
49 . S:'RAVERF RAERR="Invalid Provider Name"
50 . Q
51 I $D(RAERR) D XIT Q
52 ; can't get resident info from medspeak
53 S ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=RAVERF,^("RATRANSCRIPT")=RAVERF,^("RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
54 ;
55OBX ; Pick data off the 'OBX' segments
56 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX" Q:$D(RAERR)
57 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
58 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
59 . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&")) S:OBXTYP="" OBXTYP=" "
60 . I "IDR"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
61 . D RPT Q
62XIT ; Clean up environment, quit
63 D INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) ;field separators must be cleared and reset prior to sending ACK to prevent mixed/wrong separators in ACK
64 I $D(RAERR) D GENACK G XIT1
65 I $D(^TMP("RARPT-REC",$J)) D EN1^RAHLO I $D(RAERR) D GENACK
66XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
67 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
68 K CNT,OBXTYPE,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RANODE,RARCNT
69 K RAVERF,RASUB,SEGMNT
70 Q
71RPT ; Save off Report Text data.
72 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
73 S X=$P(SEGMNT,HL("FS"),5) D PAR
74 F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR
75 I X=""!(LIN'="") S L=999 D P2
76 Q
77PAR ; Build text paragraph
78 S LIN=LIN_X
79P1 I $L(LIN)<80 Q
80 F L=80:-1:1 Q:$E(LIN,L)=" "
81 D P2 S LIN=$E(LIN,L+1,999) G P1
82P2 ; Set node
83 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
84 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) Q
85 ;
86GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
87 S HLA("HLA",1)="MSA"_HL("FS")_$S($D(RAERR):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
88 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID")
89 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)
90 Q
91VFIER ; Check if the RAVERF string is a partial match to an entry in file
92 ; 200. If if is, check to see that is a partial match to only ONE
93 ; active provider entry in file 200.
94 I '$L(RAVERF) S RAERR="Missing Provider information" Q
95 K RAVCNT,RAVIEN,RAVLGTH,RAVPS
96 S RAVLGTH=$L(RAVERF) ; length of the RAVERF string
97 S RAVCNT=0,RAVS1=RAVERF
98 F S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF) D Q:RAVCNT>1
99 . ; return subscripts that have the RAVERF string as the first
100 . ; 1 - RAVLGTH chars of RAVS1
101 . S RAVIEN=0
102 . F S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0 D Q:RAVCNT>1
103 .. S RAVPS=$G(^VA(200,RAVIEN,"PS"))
104 .. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1
105 .. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when
106 .. ; we find the first active provider save the provider ien off
107 .. ; in a local array.
108 .. Q
109 . Q
110 I RAVCNT=0 S RAERR="Invalid Provider Name" Q ; partial match not found
111 I RAVCNT>1 S RAERR="Non-Unique Provider Name" Q ; >1 partial match
112 S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error"
113 K RAVCNT,RAVIEN,RAVLGTH,RAVPS
114 Q
Note: See TracBrowser for help on using the repository browser.