IBRFIHLU ;TDM/DAL - HL7 Utilities ;24-AUG-2015 ; 1/8/16 1:14pm
;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
HLP(PROTOCOL) ; Find the Protocol IEN
Q +$O(^ORD(101,"B",PROTOCOL,0))
;
NAME(NM) ; Convert a name that isn't in standard VISTA format -
NEW LNM,FNM,MI
;
I NM?." " Q NM
; LastName,FirstName MI
I NM["," Q NM
;
; Remove double-spaces from name
F Q:$L(NM," ")<2 S NM=$P(NM," ",1)_" "_$P(NM," ",2,9999)
;
; Trim leading/trailing spaces
S NM=$$TRIM^XLFSTR(NM)
;
; Find number of spaces in name
S II=$L(NM," ")
;
I II>3 Q NM
I II=3 S FNM=$P(NM," ",1),MI=" "_$P(NM," ",2),LNM=$P(NM," ",3)
I II=2 S FNM=$P(NM," ",1),LNM=$P(NM," ",2),MI=""
I II<2 Q NM
Q LNM_","_FNM_MI
;
SPAR ; Segment Parsing
;
; This tag will parse the current segment referenced by the HCT index
; and place the results in the IBSEG array.
;
; Input Variables
; HCT
;
; Output Variables
; IBSEG (ARRAY of fields in segment)
;
N II,IJ,IK,IM,IS,ISBEG,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
;
;Reset IBSEG
K IBSEG
;
S ISCT="",II=0,IS=0
F S ISCT=$O(^TMP($J,"IBRFIHLI",HCT,ISCT)) Q:ISCT="" D
. S IS=IS+1
. S ISDATA(IS)=$G(^TMP($J,"IBRFIHLI",HCT,ISCT))
. I $E(ISDATA(IS),1)=$C(10) S ISDATA(IS)=$E(ISDATA(IS),2,($L(ISDATA(IS)))) ;Strip out Line Feed
. I $O(^TMP($J,"IBRFIHLI",HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
. S ISPEC(IS)=$L(ISDATA(IS),HLFS)
;
S IM=0,LSDATA=""
LP S IM=IM+1 Q:IM>IS
S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
F IJ=1:1:NPC-1 D
. S II=II+1,IBSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),$E(HL("ECH"),1,2)_$E(HL("ECH"),4),$E(HL("ECH")))
S LSDATA=$P(LSDATA,HLFS,NPC)
G LP
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents in the HL7 seg
;
N NUMPEC,PEC,RTSTRING
;
S RTSTRING=$$RTRIMCH(STRING,CHARS)
; Now we have string w/o trailing chars, remove from subs
S NUMPEC=$L(RTSTRING,SUBSEP)
F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
Q RTSTRING
;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
;
N R,L
;
S L=1,CHRS=$G(CHRS," ")
F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
I L=R,(CHRS[$E(STR)) S STR=""
Q $E(STR,L,R)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFIHLU 2298 printed Sep 23, 2025@20:03:07 Page 2
IBRFIHLU ;TDM/DAL - HL7 Utilities ;24-AUG-2015 ; 1/8/16 1:14pm
+1 ;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
HLP(PROTOCOL) ; Find the Protocol IEN
+1 QUIT +$ORDER(^ORD(101,"B",PROTOCOL,0))
+2 ;
NAME(NM) ; Convert a name that isn't in standard VISTA format -
+1 NEW LNM,FNM,MI
+2 ;
+3 IF NM?." "
QUIT NM
+4 ; LastName,FirstName MI
+5 IF NM[","
QUIT NM
+6 ;
+7 ; Remove double-spaces from name
+8 FOR
if $LENGTH(NM," ")<2
QUIT
SET NM=$PIECE(NM," ",1)_" "_$PIECE(NM," ",2,9999)
+9 ;
+10 ; Trim leading/trailing spaces
+11 SET NM=$$TRIM^XLFSTR(NM)
+12 ;
+13 ; Find number of spaces in name
+14 SET II=$LENGTH(NM," ")
+15 ;
+16 IF II>3
QUIT NM
+17 IF II=3
SET FNM=$PIECE(NM," ",1)
SET MI=" "_$PIECE(NM," ",2)
SET LNM=$PIECE(NM," ",3)
+18 IF II=2
SET FNM=$PIECE(NM," ",1)
SET LNM=$PIECE(NM," ",2)
SET MI=""
+19 IF II<2
QUIT NM
+20 QUIT LNM_","_FNM_MI
+21 ;
SPAR ; Segment Parsing
+1 ;
+2 ; This tag will parse the current segment referenced by the HCT index
+3 ; and place the results in the IBSEG array.
+4 ;
+5 ; Input Variables
+6 ; HCT
+7 ;
+8 ; Output Variables
+9 ; IBSEG (ARRAY of fields in segment)
+10 ;
+11 NEW II,IJ,IK,IM,IS,ISBEG,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
+12 ;
+13 ;Reset IBSEG
+14 KILL IBSEG
+15 ;
+16 SET ISCT=""
SET II=0
SET IS=0
+17 FOR
SET ISCT=$ORDER(^TMP($JOB,"IBRFIHLI",HCT,ISCT))
if ISCT=""
QUIT
Begin DoDot:1
+18 SET IS=IS+1
+19 SET ISDATA(IS)=$GET(^TMP($JOB,"IBRFIHLI",HCT,ISCT))
+20 ;Strip out Line Feed
IF $EXTRACT(ISDATA(IS),1)=$CHAR(10)
SET ISDATA(IS)=$EXTRACT(ISDATA(IS),2,($LENGTH(ISDATA(IS))))
+21 IF $ORDER(^TMP($JOB,"IBRFIHLI",HCT,ISCT))=""
SET ISDATA(IS)=ISDATA(IS)_HLFS
+22 SET ISPEC(IS)=$LENGTH(ISDATA(IS),HLFS)
End DoDot:1
+23 ;
+24 SET IM=0
SET LSDATA=""
LP SET IM=IM+1
if IM>IS
QUIT
+1 SET LSDATA=LSDATA_ISDATA(IM)
SET NPC=ISPEC(IM)
+2 FOR IJ=1:1:NPC-1
Begin DoDot:1
+3 SET II=II+1
SET IBSEG(II)=$$CLNSTR($PIECE(LSDATA,HLFS,IJ),$EXTRACT(HL("ECH"),1,2)_$EXTRACT(HL("ECH"),4),$EXTRACT(HL("ECH")))
End DoDot:1
+4 SET LSDATA=$PIECE(LSDATA,HLFS,NPC)
+5 GOTO LP
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents in the HL7 seg
+1 ;
+2 NEW NUMPEC,PEC,RTSTRING
+3 ;
+4 SET RTSTRING=$$RTRIMCH(STRING,CHARS)
+5 ; Now we have string w/o trailing chars, remove from subs
+6 SET NUMPEC=$LENGTH(RTSTRING,SUBSEP)
+7 FOR PEC=1:1:NUMPEC
SET $PIECE(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($PIECE(RTSTRING,SUBSEP,PEC),CHARS)
+8 QUIT RTSTRING
+9 ;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
+1 ;
+2 NEW R,L
+3 ;
+4 SET L=1
SET CHRS=$GET(CHRS," ")
+5 FOR R=$LENGTH(STR):-1:1
if CHRS'[$EXTRACT(STR,R)
QUIT
+6 IF L=R
IF (CHRS[$EXTRACT(STR))
SET STR=""
+7 QUIT $EXTRACT(STR,L,R)
