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