Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSULRHL1

PSULRHL1.m

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