260 lines
6.6 KiB
Mathematica
260 lines
6.6 KiB
Mathematica
PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am
|
|
;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8
|
|
;
|
|
; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol
|
|
; DBIA 998 to dig through ^DPT(i,"LR" go get the ien to file #63
|
|
; DBIA 91-A to dig through ^LAB(60 to get the name of the test
|
|
; DBIA 3630 to call the HL7 PID builder
|
|
; DBIA 4727 to call EN^HLOCNRT
|
|
; DBIA 3646 to call API: $$EMPL^DGSEC4
|
|
; DBIA 4658 to call API: $$TSTRES^LRRPU
|
|
;
|
|
; This program is called when a lab test is verified. If it is for a
|
|
; chemistry test, and not for an employee, an HL7 message will be
|
|
; created and sent to the CMOP-NAT server.
|
|
;
|
|
;
|
|
HL7 ; Entry point for PBM processing - triggered by lab protocol
|
|
; LR7O ALL EVSEND RESULTS.
|
|
;
|
|
N ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS
|
|
;
|
|
; OREMSG is the pointer reference to the global that contains the
|
|
; lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol.
|
|
;
|
|
I '$D(@OREMSG) Q
|
|
;
|
|
; Get Lab parameters
|
|
;
|
|
D INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL)
|
|
;
|
|
; Set up CS delimeter for the Pharmacy message
|
|
;
|
|
S PSUHL("CS")=$E(PSUHL("ECH"),1)
|
|
;
|
|
; Set up segment processing parameters
|
|
;
|
|
S PSUEXT("PSUBUF")=$NA(^TMP("HLS",$J))
|
|
S PSUEXT("PSUPTR")=0
|
|
;
|
|
; Get the delimiters that the passed in lab data is using
|
|
;
|
|
D PARAMS
|
|
S PSUHLECH=$G(ARR("PSUHLECH"),"^~\&")
|
|
S PSUHLCS=$E(PSUHLECH,1)
|
|
;
|
|
; Quit if no DFN
|
|
;
|
|
I '$D(ARR) Q
|
|
I ARR("DFN")=0!(ARR("DFN")="") Q
|
|
;
|
|
; Quit if patient is an employee
|
|
;
|
|
I $$EMPL^DGSEC4(ARR("DFN"),"PS") Q
|
|
;
|
|
; Get Lab's equivalent of a DFN (LRDFN)
|
|
;
|
|
S LRDFN=$P(^DPT(ARR("DFN"),"LR"),"^") ; DBIA 998 to get file #63 ien
|
|
;
|
|
; Loop through the lab data
|
|
;
|
|
S FIRST=1
|
|
D LOOP
|
|
;
|
|
; Generate an HL7 if data exists to be sent
|
|
;
|
|
I 'FIRST D GENERATE
|
|
;
|
|
K PSUHL,ERR,OPTNS,ERR
|
|
;
|
|
Q
|
|
;
|
|
LOOP ;
|
|
N CNT,LRIDT,LRSS,PREV1,PREV2,QUIT1,QUIT2,REC,REC1,REC2,SEG,SEG1,SEG2,STR1
|
|
K ^TMP("HLS",$J)
|
|
S CNT=0
|
|
F Q:CNT="" S CNT=$O(@OREMSG@(CNT)) Q:'CNT D
|
|
. S REC=@OREMSG@(CNT)
|
|
. S REC=$$STRING(REC,CNT)
|
|
. S SEG=$P(REC,PSUHLFS,1)
|
|
. I SEG'="ORC" Q
|
|
. S STR1=$P(REC,PSUHLFS,4)
|
|
. S STR1=$P(STR1,PSUHLCS,1)
|
|
. S LRSS=$P(STR1,";",4)
|
|
. ;
|
|
. ; Quit if data is not for Chemistry
|
|
. ;
|
|
. I LRSS'="CH" Q
|
|
. S LRIDT=$P(STR1,";",5)
|
|
. S QUIT1=0
|
|
. F Q:QUIT1!(CNT="") S PREV1=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D
|
|
. . S REC1=@OREMSG@(CNT)
|
|
. . S REC1=$$STRING(REC1,CNT)
|
|
. . S SEG1=$P(REC1,PSUHLFS,1)
|
|
. . I SEG1="ORC" S CNT=PREV1,QUIT1=1 Q
|
|
. . I SEG1'="OBR" Q
|
|
. . ; If this is the first OBR being processed i.e. this is valid
|
|
. . ; chemistry data set the PID segment
|
|
. . I FIRST D PID S FIRST=0
|
|
. . D OBR(REC1)
|
|
. . S QUIT2=0
|
|
. . F Q:QUIT2 S PREV2=CNT,CNT=$O(@OREMSG@(CNT)) Q:'CNT D
|
|
. . . S REC2=@OREMSG@(CNT)
|
|
. . . S REC2=$$STRING(REC2,CNT)
|
|
. . . S SEG2=$P(REC2,PSUHLFS,1)
|
|
. . . I SEG2="OBR"!(SEG2="ORC") S CNT=PREV2,QUIT2=1 Q
|
|
. . . I SEG2'="OBX" Q
|
|
. . . D OBX(REC2)
|
|
Q
|
|
;
|
|
PID ; Create the PID segment using the standard builder
|
|
;
|
|
N K1,NEWSEG,SEG
|
|
S SEG="SEG"
|
|
D BLDPID^VAFCQRY(ARR("DFN"),1,"1,2,3",.SEG,.PSUHL,.ERR)
|
|
;
|
|
; Loop through the returned array just in case the data is spread over
|
|
; more than one node
|
|
;
|
|
S K1="",NEWSEG=""
|
|
F S K1=$O(SEG(K1)) Q:'K1 D
|
|
. S NEWSEG=NEWSEG_SEG(K1)
|
|
;
|
|
; Set the data string into the PBM HL7 array
|
|
;
|
|
D SETSEG(NEWSEG)
|
|
;
|
|
Q
|
|
;
|
|
OBR(REC) ; Re-forms lab OBR to only send required data
|
|
;
|
|
N OBRSEG,SITE,SPECDATE
|
|
S OBRSEG="OBR"
|
|
S SPECDATE=$P(REC,PSUHLFS,8)
|
|
S SITE=$P(REC,PSUHLFS,16)
|
|
S SITE=$TR(SITE,PSUHLCS,PSUHL("CS"))
|
|
;
|
|
; Create new OBR Segment and pass to SETSEG
|
|
;
|
|
S $P(OBRSEG,PSUHL("FS"),8)=SPECDATE
|
|
S $P(OBRSEG,PSUHL("FS"),16)=SITE
|
|
;
|
|
; Set the data string into the PBM HL7 array
|
|
;
|
|
D SETSEG(OBRSEG)
|
|
;
|
|
Q
|
|
;
|
|
OBX(REC) ; Reforms lab OBX to only send the data needed
|
|
N CODES,HRANGE,LABS,LNAME,LR60,LRANGE,LRDN,LOINC,LOINCS,P2,P3,P12,RANGE,RES,RESULTS,SEG,UNITS
|
|
;
|
|
S P2=$P(REC,PSUHLFS,2)
|
|
S P3=$P(REC,PSUHLFS,3)
|
|
S P12=$P(REC,PSUHLFS,12)
|
|
S RESULTS=$P(REC,PSUHLFS,6)
|
|
S UNITS=$P(REC,PSUHLFS,7)
|
|
S LABS=$P(REC,PSUHLFS,4)
|
|
S LR60=$P(LABS,"^",4)
|
|
I LR60']"" Q
|
|
S LRDN=$G(^LAB(60,LR60,0))
|
|
S LRDN=$P($P(LRDN,"^",5),";",2) ; DBIA 91 for data name
|
|
;
|
|
; Make the call to LRRPU to get the LOINC code for this test
|
|
;
|
|
I LRDN']"" Q
|
|
S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1)
|
|
;
|
|
S CODES=$P(RES,U,8),LOINCS=$P(CODES,"!",3)
|
|
S LOINC=$P(LOINCS,";",1),LNAME=$P(LOINCS,";",2)
|
|
S LRANGE=$P(RES,U,3),HRANGE=$P(RES,U,4)
|
|
S RANGE=LRANGE_"-"_HRANGE I RANGE="-" S RANGE=""
|
|
;
|
|
; Use the Pharmacy HL7 delimeters
|
|
;
|
|
S LABS=$TR(LABS,PSUHLCS,PSUHL("CS"))
|
|
;
|
|
; Add LOINC to the list of Labs if it exists
|
|
;
|
|
I LOINC'="" D
|
|
. ;
|
|
. ; Append the LOINC data using the pharmacy delimiters
|
|
. S LABS=LABS_PSUHL("CS")_LOINC_PSUHL("CS")_LNAME_PSUHL("CS")_"99LN"
|
|
;
|
|
; Put the data in the string
|
|
;
|
|
S SEG="OBX"
|
|
S $P(SEG,PSUHL("FS"),2)=P2
|
|
S $P(SEG,PSUHL("FS"),3)=P3
|
|
S $P(SEG,PSUHL("FS"),4)=LABS
|
|
S $P(SEG,PSUHL("FS"),6)=RESULTS
|
|
S $P(SEG,PSUHL("FS"),7)=UNITS
|
|
S $P(SEG,PSUHL("FS"),8)=RANGE
|
|
S $P(SEG,PSUHL("FS"),12)=P12
|
|
;
|
|
; Put the string into the PBM HL7 global
|
|
;
|
|
D SETSEG(SEG)
|
|
;
|
|
Q
|
|
;
|
|
STRING(HLSTR,CNT) ; Loops through sub nodes to create a full data string
|
|
N J
|
|
S J=""
|
|
F S J=$O(@OREMSG@(CNT,J)) Q:J="" S HLSTR=HLSTR_@OREMSG@(CNT,J)
|
|
Q HLSTR
|
|
;
|
|
PARAMS ; Get the delimiters used in the lab data
|
|
;
|
|
N CNT,ID,QUIT,REC,RES
|
|
K ARR
|
|
S (QUIT,CNT)=0,RES=""
|
|
F S CNT=$O(@OREMSG@(CNT)) Q:'CNT!(QUIT=2) D
|
|
. S REC=@OREMSG@(CNT)
|
|
. I $E(REC,1,3)="MSH" D Q
|
|
. . S PSUHLFS=$E(REC,4,4)
|
|
. . S ARR("PSUHLECH")=$P(REC,PSUHLFS,2),QUIT=QUIT+1
|
|
. I $P(REC,PSUHLFS,1)="PID" D Q
|
|
. . S ARR("DFN")=$P(REC,PSUHLFS,4)
|
|
. . S QUIT=QUIT+1
|
|
Q
|
|
;
|
|
GENERATE ; Generate HL7 message
|
|
;
|
|
; D GENERATE^HLMA("PSU-SITE-DRIVER","GM",1,.RESULT,"",.OPTNS)
|
|
S OPTNS("QUEUE")="PBM LAB"
|
|
S RESULT=$$EN^HLOCNRT("PSU-SITE-DRIVER","GM",.OPTNS)
|
|
I +RESULT'=RESULT D
|
|
. S ^XTMP("PBM/HLO",DT,$J)=RESULT
|
|
K ^TMP("HLS",$J)
|
|
Q
|
|
;
|
|
;
|
|
SETSEG(SEG) ;
|
|
;
|
|
;***** STORES THE SEGMENT INTO THE ^TMP("HLS",$J) BUFFER
|
|
;
|
|
; SEG HL7 segment
|
|
;
|
|
; The SETSEG procedure stores the HL7 segment into the
|
|
; standard HL7 buffer ^TMP("HLS",$J). The <TAB>, <CR> and <LF>
|
|
; characters are replaced with spaces. Long segments are split among
|
|
; sub-nodes of the main segment node.
|
|
;
|
|
; The PSUEXT array must be initialized before
|
|
; calling this function.
|
|
;
|
|
N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
|
|
S NODE=PSUEXT("PSUBUF"),PTR=$G(PSUEXT("PSUPTR"))+1
|
|
S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR)
|
|
;--- Store the segment
|
|
S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ")
|
|
;
|
|
;--- Split the segment into sub-nodes if necessary
|
|
D:SL>MAXLEN
|
|
. S I2=MAXLEN
|
|
. F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D
|
|
. . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ")
|
|
;--- Save the pointer
|
|
S PSUEXT("PSUPTR")=PTR
|
|
Q
|