IBTRHLU ;ALB/JWS - Receive and store 278 Response message ;05-JUN-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;
;
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=-1,IS=0
F S ISCT=$O(^TMP($J,"IBTRHLI",HCT,ISCT)) Q:ISCT="" D
. S IS=IS+1
. S ISDATA(IS)=$G(^TMP($J,"IBTRHLI",HCT,ISCT))
. I $O(^TMP($J,"IBTRHLI",HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
. S ISPEC(IS)=$L(ISDATA(IS),HLFS)
. Q
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")))
. I II=0,IBSEG(0)="MSH" S II=II+1,IBSEG(1)="|"
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[HIBTRHLU 1630 printed Apr 09, 2024@21:35:41 Page 2
IBTRHLU ;ALB/JWS - Receive and store 278 Response message ;05-JUN-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
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=-1
SET IS=0
+17 FOR
SET ISCT=$ORDER(^TMP($JOB,"IBTRHLI",HCT,ISCT))
if ISCT=""
QUIT
Begin DoDot:1
+18 SET IS=IS+1
+19 SET ISDATA(IS)=$GET(^TMP($JOB,"IBTRHLI",HCT,ISCT))
+20 IF $ORDER(^TMP($JOB,"IBTRHLI",HCT,ISCT))=""
SET ISDATA(IS)=ISDATA(IS)_HLFS
+21 SET ISPEC(IS)=$LENGTH(ISDATA(IS),HLFS)
+22 QUIT
End DoDot:1
+23 SET IM=0
SET LSDATA=""
LP ;**
+1 SET IM=IM+1
if IM>IS
QUIT
+2 SET LSDATA=LSDATA_ISDATA(IM)
SET NPC=ISPEC(IM)
+3 FOR IJ=1:1:NPC-1
Begin DoDot:1
+4 SET II=II+1
SET IBSEG(II)=$$CLNSTR($PIECE(LSDATA,HLFS,IJ),$EXTRACT(HL("ECH"),1,2)_$EXTRACT(HL("ECH"),4),$EXTRACT(HL("ECH")))
+5 IF II=0
IF IBSEG(0)="MSH"
SET II=II+1
SET IBSEG(1)="|"
End DoDot:1
+6 SET LSDATA=$PIECE(LSDATA,HLFS,NPC)
+7 GOTO LP
CLNSTR(STRING,CHARS,SUBSEP) ;** Remove extra trailing components and subcomponents in the HL7 seg
+1 NEW NUMPEC,PEC,RTSTRING
+2 SET RTSTRING=$$RTRIMCH(STRING,CHARS)
+3 ; Now we have string w/o trailing chars, remove from subs
+4 SET NUMPEC=$LENGTH(RTSTRING,SUBSEP)
+5 FOR PEC=1:1:NUMPEC
SET $PIECE(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($PIECE(RTSTRING,SUBSEP,PEC),CHARS)
+6 QUIT RTSTRING
+7 ;
RTRIMCH(STR,CHRS) ;** Remove the trailing chars from string
+1 NEW R,L
+2 SET L=1
SET CHRS=$GET(CHRS," ")
+3 FOR R=$LENGTH(STR):-1:1
if CHRS'[$EXTRACT(STR,R)
QUIT
+4 IF L=R
IF (CHRS[$EXTRACT(STR))
SET STR=""
+5 QUIT $EXTRACT(STR,L,R)
+6 ;
