- 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 Mar 13, 2025@21:31:48 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)
