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
PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8
+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 not for an employee, an HL7 message will be
+13 ; created and sent to the CMOP-NAT server.
+14 ;
+15 ;
HL7 ; Entry point for PBM processing - triggered by lab protocol
+1 ; LR7O ALL EVSEND RESULTS.
+2 ;
+3 NEW ARR,FIRST,LRDFN,PSUEXT,PSUHLFS,PSUHLECH,PSUHLCS
+4 ;
+5 ; OREMSG is the pointer reference to the global that contains the
+6 ; lab data and is passed in by the LR7O ALL EVSEND RESULTS protocol.
+7 ;
+8 IF '$DATA(@OREMSG)
QUIT
+9 ;
+10 ; Get Lab parameters
+11 ;
+12 DO INIT^HLFNC2("PSU-SITE-DRIVER",.PSUHL)
+13 ;
+14 ; Set up CS delimeter for the Pharmacy message
+15 ;
+16 SET PSUHL("CS")=$EXTRACT(PSUHL("ECH"),1)
+17 ;
+18 ; Set up segment processing parameters
+19 ;
+20 SET PSUEXT("PSUBUF")=$NAME(^TMP("HLS",$JOB))
+21 SET PSUEXT("PSUPTR")=0
+22 ;
+23 ; Get the delimiters that the passed in lab data is using
+24 ;
+25 DO PARAMS
+26 SET PSUHLECH=$GET(ARR("PSUHLECH"),"^~\&")
+27 SET PSUHLCS=$EXTRACT(PSUHLECH,1)
+28 ;
+29 ; Quit if no DFN
+30 ;
+31 IF '$DATA(ARR)
QUIT
+32 IF ARR("DFN")=0!(ARR("DFN")="")
QUIT
+33 ;
+34 ; Quit if patient is an employee
+35 ;
+36 IF $$EMPL^DGSEC4(ARR("DFN"),"PS")
QUIT
+37 ;
+38 ; Get Lab's equivalent of a DFN (LRDFN)
+39 ;
+40 ; DBIA 998 to get file #63 ien
SET LRDFN=$PIECE(^DPT(ARR("DFN"),"LR"),"^")
+41 ;
+42 ; Loop through the lab data
+43 ;
+44 SET FIRST=1
+45 DO LOOP
+46 ;
+47 ; Generate an HL7 if data exists to be sent
+48 ;
+49 IF 'FIRST
DO GENERATE
+50 ;
+51 KILL PSUHL,ERR,OPTNS,ERR
+52 ;
+53 QUIT
+54 ;
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 IF FIRST
DO PID
SET FIRST=0
+27 DO OBR(REC1)
+28 SET QUIT2=0
+29 FOR
IF QUIT2
QUIT
SET PREV2=CNT
SET CNT=$ORDER(@OREMSG@(CNT))
IF 'CNT
QUIT
Begin DoDot:3
+30 SET REC2=@OREMSG@(CNT)
+31 SET REC2=$$STRING(REC2,CNT)
+32 SET SEG2=$PIECE(REC2,PSUHLFS,1)
+33 IF SEG2="OBR"!(SEG2="ORC")
SET CNT=PREV2
SET QUIT2=1
QUIT
+34 IF SEG2'="OBX"
QUIT
+35 DO OBX(REC2)
End DoDot:3
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
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 ;
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=$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 SET ARR("PSUHLECH")=$PIECE(REC,PSUHLFS,2)
SET QUIT=QUIT+1
End DoDot:2
QUIT
+10 IF $PIECE(REC,PSUHLFS,1)="PID"
Begin DoDot:2
+11 SET ARR("DFN")=$PIECE(REC,PSUHLFS,4)
+12 SET QUIT=QUIT+1
End DoDot:2
QUIT
End DoDot:1
+13 QUIT
+14 ;
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
