BAR50P01 ; IHS/SD/LSL - EDI PARSING ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,3,21,26**;OCT 26, 2005;Build 17
;;
; IHS/ASDS/LSL - O6/15/2001 - V1.5 Patch 1 - HQW-0201-100027 - FM 22 issue. Modified to include E in DIC(0).
;
; IHS/SD/LSL - 08/19/2002 - V1.7 Patch 4 - HIPAA - Modified FILE and LOOP to accomodate X12 loops on segments with the same ID.
;
;IHS/SD/POT - 1.8*26 - HEAT158770 04/09/2014 Allow more than 1 SVC segment per claim to avoid <SUBSCRIPT>IDENT+32^BAR50P01 *SEGID("SVC","")
; *********************************************************************
;
EN(TRDA,IMPDA) ; EP -- Process the file loaded into Image
S VALMBCK="R"
D PARSE(TRDA,IMPDA)
D FILE(TRDA,IMPDA)
W " ",COUNT
Q
; ********************************************************************
;
PARSE(TRDA,IMPDA) ;
; parse image in ^TMP($J,"I", into segments "S"
; Separators S-Segment, E-Element, SE-Sub Element
K ^TMP($J,"I"),^TMP($J,"S")
D SEP(TRDA,IMPDA) ; find separators
S BARTMP=0
F S BARTMP=$O(^BAREDI("I",DUZ(2),IMPDA,10,BARTMP)) Q:'+BARTMP S ^TMP($J,"I",10,BARTMP)=^BAREDI("I",DUZ(2),IMPDA,10,BARTMP,0)
;
; remove trailing spaces if any (because control char were replaced
; spaces when the file was read into a global)
S A="^TMP($J,""I"",10)"
S B="^TMP($J,""S"")"
S LC=$O(@A@(""),-1)
F I=1:1:LC S X=@A@(I) D S @A@(I)=X
. F S L=$L(X) Q:$E(X,L)'=" " S X=$E(X,1,L-1)
S X=""
S L1=1,L2=1
;
; the following uses GO commands to simplify the logic loops
; have to combine lines of the import and pull out the records
; uniquely into seperate segments
;
W !,"Splitting image into Segments",!
S COUNT=1
;
ADD ;add image lines to X till it has a seperator
G:'$D(@A@(L1)) LAST
G:@A@(L1)="" LAST
S X=X_@A@(L1)
S L1=L1+1
I X[S G STORE
G ADD
; ********************************************************************
;
STORE ;
; store segment & store more if X has several segments in it
W:'(COUNT#10) "."
W:'(COUNT#500) " ",COUNT,!
S COUNT=COUNT+1
S Y=$P(X,S)
S X=$P(X,S,2,999)
S @B@(L2)=Y
S L2=L2+1
I X[S G STORE
G ADD
; ********************************************************************
;
LAST ;store last
S X=$$STRIP^BAR50IUT(X)
S:$L(X) @B@(L2)=X
S Z=$O(@B@(""),-1)
K ^BAREDI("I",DUZ(2),IMPDA,15)
F I=1:1:Z S ^BAREDI("I",DUZ(2),IMPDA,15,I,0)=@B@(I)
S ^BAREDI("I",DUZ(2),IMPDA,15,0)="^^"_Z_"^"_Z_"^"_DT
Q
; ********************************************************************
;
SEP(TRDA,IMPDA) ;
; FIND SEPERATORS
;TRANSPORT - TRDA, IMPORT DA - IMPDA
;store S=Segment,E=Element,SE=Subelement
S ROU=$$GET1^DIQ(90056.01,TRDA,.02)
S ROU=$TR(ROU,"|","^")
Q:'$L(ROU)
D @ROU
Q
; ********************************************************************
;
FILE(TRDA,IMPDA) ;
; Take field 15 Image by Segment, find its segment and
; store in segments multiple(s) ready for spliting & conversion
;
W !,"Identifying Segments Uniquely",!
S COUNT=1
;pull image by segment into @SEG@
K ^TMP($J,"SEG")
;
; build SEGID array for assignments
; SEGID(ID,SEGMENT)=USE ; ie SEGID("CAS","2-090-CAS")=99
;
K SEGI,SESGID
D ENPM^XBDIQ1(90056.0101,"TRDA,0",".01;.02;.06","SEGI(")
S I=0 F S I=$O(SEGI(I)) Q:I'>0 S SEGID(SEGI(I,.02),SEGI(I,.01))=SEGI(I,.06)
;
; Pull & build loop id array LOOP(ID)=SEGMENT
; If Mark(ID) then segment sets its own last segment level
; If BARLOOP("DUP"), then Segment Id is LOOPed more than once
;
K DIC,LOOP,LOP
S DIC=$$DIC^XBDIQ1(90056.0101)
S DIC("S")="I +$P(^(0),U,5)"
D ENPM^XBDIQ1(.DIC,"TRDA,0",".01;.02","LOP(")
K BARLOOP
S I=0
F S I=$O(LOP(I)) Q:I'>0 D
. S:$D(LOOP(LOP(I,.02))) BARLOOP("DUP",LOP(I,.02))=1
. S LOOP(LOP(I,.02))=LOP(I,.01)
K LOP
;
; initialize current & last ID, SEGMENT, USE
S (LSTID,LSTSEG,LSTUSE,CURID,CURSEG,CURUSE)=""
;
K ^BAREDI("I",DUZ(2),20) ; clear Records
S SEGDA=0
F S SEGDA=$O(^BAREDI("I",DUZ(2),IMPDA,15,SEGDA)) Q:SEGDA'>0 S SEGX=^(SEGDA,0) D
.S LSTSEG=CURSEG
. S LSTID=CURID
. S LSTUSE=CURUSE
. D IDENT
. Q:CURID="NTE" ;BAR*1.8*3 IM25273 CANNOT HANDLE NTE SEGMENTS
.; SRS TO BE WRITTEN FOR SPECIFICATIONS
. D FILE1
Q
; ********************************************************************
;
IDENT ; logic to locate segment from ID
S CURID=$P(SEGX,E)
Q:CURID="NTE" ;BAR*1.8*3 IM25273 CANNOT HANDLE NTE SEGMENTS
; SRS TO BE WRITTEN FOR SPECIFICATIONS
I CURID'=LSTID D Q
. I $D(LOOP(CURID)) D I 1
. . I $D(BARLOOP("DUP",CURID)) D Q
. . . I TRNAME["HIPAA",CURID="N1" D
. . . . S:$P(SEGX,E,2)="PR" CURSEG="2-080.A-N1"
. . . . S:$P(SEGX,E,2)="PE" CURSEG="2-080.B-N1"
. . . I TRNAME["3041.4A",CURID="N1" D
. . . . S:$P(SEGX,E,2)="PR" CURSEG="1-080.A-N1"
. . . . S:$P(SEGX,E,2)="PE" CURSEG="1-080.B-N1"
. . S CURSEG=LOOP(CURID)
. E D ;S CURSEG=$O(SEGID(CURID,LSTSEG)) ;BAR*1.8*1 SRS PATCH 1 ADDENDUM
. . ;CHANGE MADE BECAUSE ALGORYTHM DID NOT HANDLE GOING FROM THE B TO NEXT B SEGMENTS
. . ;IT WOULD SKIP TO THE PREVIOUS A-XXX SEGMENT
. . S TEMPSEG=LSTSEG
. . S LOOPID1=$P($P(LSTSEG,".",2),"-")
. . S CURSEG=$O(SEGID(CURID,LSTSEG))
. . S LOOPID2=$P($P(CURSEG,".",2),"-")
. . S:LOOPID1="B"&(LOOPID2="A") CURSEG=$O(SEGID(CURID,CURSEG))
. . ;END BAR*1.8*1 SRS PATCH 1 ADDENDUM
. ;IHS/SD/TPF 12/16/2005 IM19044
. I $G(CURSEG)="",($G(CURID)="ISA") W !,"File contains more than one ISA/IEA pair at "_$G(^BAREDI("I",DUZ(2),IMPDA,15,SEGDA))_" . Inform payor and request new file." H 3 Q
. S CURUSE=SEGID(CURID,CURSEG)
;
I LSTUSE>1 D Q
. S CURSEG=LSTSEG
. S CURUSE=LSTUSE
;
I CURID="SVC" Q ;bar*1.8*26 IHS/SD/POT HEAT158770
S CURSEG=$O(SEGID(CURID,LSTSEG))
S CURUSE=SEGID(CURID,CURSEG)
Q
; ********************************************************************
;
FILE1 ;
;FM HAS ISSUE WITH ^ IN FREE TEXT FIELD
I $E(SEGX,1,3)="ISA",($E(SEGX,83)="^") S $E(SEGX,83)="U" ;IHS/SD/TPF 8/24/2011 BAR*1.8*21
W:'(COUNT#10) "."
W:'(COUNT#500) " ",COUNT,!
S COUNT=COUNT+1
K DIC,DR,DD,DO,DA
S DIC=$$DIC^XBDIQ1(90056.0101)
S X=CURSEG
S DIC(0)="X"
S DA(1)=TRDA
D ^DIC
N SEGLNK
S SEGLNK=TRDA_","_+Y
K DIC,DR,DD,DO,DA
S DA(1)=IMPDA
S DIC("P")="90056.0202A"
S DIC=$$DIC^XBDIQ1(90056.0202)
S DLAYGO=90056
S DIC(0)="FZE"
S X=SEGDA
S DIC("DR")=".02///^S X=CURID"
S DIC("DR")=DIC("DR")_";.03///^S X=CURSEG"
S DIC("DR")=DIC("DR")_";.04///^S X=SEGLNK"
S DIC("DR")=DIC("DR")_";1.01///^S X=SEGX"
D FILE^DICN
K DIC,DR,DD,DO
Q
; ********************************************************************
;
CLEAR(IMPDA) ; kill nodes 15 & 20 for a rerun
K ^BAREDI("I",DUZ(2),IMPDA,15)
K ^BAREDI("I",DUZ(2),IMPDA,20)
Q
BAR50P01 ; IHS/SD/LSL - EDI PARSING ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,3,21,26**;OCT 26, 2005;Build 17
+2 ;;
+3 ; IHS/ASDS/LSL - O6/15/2001 - V1.5 Patch 1 - HQW-0201-100027 - FM 22 issue. Modified to include E in DIC(0).
+4 ;
+5 ; IHS/SD/LSL - 08/19/2002 - V1.7 Patch 4 - HIPAA - Modified FILE and LOOP to accomodate X12 loops on segments with the same ID.
+6 ;
+7 ;IHS/SD/POT - 1.8*26 - HEAT158770 04/09/2014 Allow more than 1 SVC segment per claim to avoid <SUBSCRIPT>IDENT+32^BAR50P01 *SEGID("SVC","")
+8 ; *********************************************************************
+9 ;
EN(TRDA,IMPDA) ; EP -- Process the file loaded into Image
+1 SET VALMBCK="R"
+2 DO PARSE(TRDA,IMPDA)
+3 DO FILE(TRDA,IMPDA)
+4 WRITE " ",COUNT
+5 QUIT
+6 ; ********************************************************************
+7 ;
PARSE(TRDA,IMPDA) ;
+1 ; parse image in ^TMP($J,"I", into segments "S"
+2 ; Separators S-Segment, E-Element, SE-Sub Element
+3 KILL ^TMP($JOB,"I"),^TMP($JOB,"S")
+4 ; find separators
DO SEP(TRDA,IMPDA)
+5 SET BARTMP=0
+6 FOR
SET BARTMP=$ORDER(^BAREDI("I",DUZ(2),IMPDA,10,BARTMP))
IF '+BARTMP
QUIT
SET ^TMP($JOB,"I",10,BARTMP)=^BAREDI("I",DUZ(2),IMPDA,10,BARTMP,0)
+7 ;
+8 ; remove trailing spaces if any (because control char were replaced
+9 ; spaces when the file was read into a global)
+10 SET A="^TMP($J,""I"",10)"
+11 SET B="^TMP($J,""S"")"
+12 SET LC=$ORDER(@A@(""),-1)
+13 FOR I=1:1:LC
SET X=@A@(I)
Begin DoDot:1
+14 FOR
SET L=$LENGTH(X)
IF $EXTRACT(X,L)'=" "
QUIT
SET X=$EXTRACT(X,1,L-1)
End DoDot:1
SET @A@(I)=X
+15 SET X=""
+16 SET L1=1
SET L2=1
+17 ;
+18 ; the following uses GO commands to simplify the logic loops
+19 ; have to combine lines of the import and pull out the records
+20 ; uniquely into seperate segments
+21 ;
+22 WRITE !,"Splitting image into Segments",!
+23 SET COUNT=1
+24 ;
ADD ;add image lines to X till it has a seperator
+1 IF '$DATA(@A@(L1))
GOTO LAST
+2 IF @A@(L1)=""
GOTO LAST
+3 SET X=X_@A@(L1)
+4 SET L1=L1+1
+5 IF X[S
GOTO STORE
+6 GOTO ADD
+7 ; ********************************************************************
+8 ;
STORE ;
+1 ; store segment & store more if X has several segments in it
+2 IF '(COUNT#10)
WRITE "."
+3 IF '(COUNT#500)
WRITE " ",COUNT,!
+4 SET COUNT=COUNT+1
+5 SET Y=$PIECE(X,S)
+6 SET X=$PIECE(X,S,2,999)
+7 SET @B@(L2)=Y
+8 SET L2=L2+1
+9 IF X[S
GOTO STORE
+10 GOTO ADD
+11 ; ********************************************************************
+12 ;
LAST ;store last
+1 SET X=$$STRIP^BAR50IUT(X)
+2 IF $LENGTH(X)
SET @B@(L2)=X
+3 SET Z=$ORDER(@B@(""),-1)
+4 KILL ^BAREDI("I",DUZ(2),IMPDA,15)
+5 FOR I=1:1:Z
SET ^BAREDI("I",DUZ(2),IMPDA,15,I,0)=@B@(I)
+6 SET ^BAREDI("I",DUZ(2),IMPDA,15,0)="^^"_Z_"^"_Z_"^"_DT
+7 QUIT
+8 ; ********************************************************************
+9 ;
SEP(TRDA,IMPDA) ;
+1 ; FIND SEPERATORS
+2 ;TRANSPORT - TRDA, IMPORT DA - IMPDA
+3 ;store S=Segment,E=Element,SE=Subelement
+4 SET ROU=$$GET1^DIQ(90056.01,TRDA,.02)
+5 SET ROU=$TRANSLATE(ROU,"|","^")
+6 IF '$LENGTH(ROU)
QUIT
+7 DO @ROU
+8 QUIT
+9 ; ********************************************************************
+10 ;
FILE(TRDA,IMPDA) ;
+1 ; Take field 15 Image by Segment, find its segment and
+2 ; store in segments multiple(s) ready for spliting & conversion
+3 ;
+4 WRITE !,"Identifying Segments Uniquely",!
+5 SET COUNT=1
+6 ;pull image by segment into @SEG@
+7 KILL ^TMP($JOB,"SEG")
+8 ;
+9 ; build SEGID array for assignments
+10 ; SEGID(ID,SEGMENT)=USE ; ie SEGID("CAS","2-090-CAS")=99
+11 ;
+12 KILL SEGI,SESGID
+13 DO ENPM^XBDIQ1(90056.0101,"TRDA,0",".01;.02;.06","SEGI(")
+14 SET I=0
FOR
SET I=$ORDER(SEGI(I))
IF I'>0
QUIT
SET SEGID(SEGI(I,.02),SEGI(I,.01))=SEGI(I,.06)
+15 ;
+16 ; Pull & build loop id array LOOP(ID)=SEGMENT
+17 ; If Mark(ID) then segment sets its own last segment level
+18 ; If BARLOOP("DUP"), then Segment Id is LOOPed more than once
+19 ;
+20 KILL DIC,LOOP,LOP
+21 SET DIC=$$DIC^XBDIQ1(90056.0101)
+22 SET DIC("S")="I +$P(^(0),U,5)"
+23 DO ENPM^XBDIQ1(.DIC,"TRDA,0",".01;.02","LOP(")
+24 KILL BARLOOP
+25 SET I=0
+26 FOR
SET I=$ORDER(LOP(I))
IF I'>0
QUIT
Begin DoDot:1
+27 IF $DATA(LOOP(LOP(I,.02)))
SET BARLOOP("DUP",LOP(I,.02))=1
+28 SET LOOP(LOP(I,.02))=LOP(I,.01)
End DoDot:1
+29 KILL LOP
+30 ;
+31 ; initialize current & last ID, SEGMENT, USE
+32 SET (LSTID,LSTSEG,LSTUSE,CURID,CURSEG,CURUSE)=""
+33 ;
+34 ; clear Records
KILL ^BAREDI("I",DUZ(2),20)
+35 SET SEGDA=0
+36 FOR
SET SEGDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,15,SEGDA))
IF SEGDA'>0
QUIT
SET SEGX=^(SEGDA,0)
Begin DoDot:1
+37 SET LSTSEG=CURSEG
+38 SET LSTID=CURID
+39 SET LSTUSE=CURUSE
+40 DO IDENT
+41 ;BAR*1.8*3 IM25273 CANNOT HANDLE NTE SEGMENTS
IF CURID="NTE"
QUIT
+42 ; SRS TO BE WRITTEN FOR SPECIFICATIONS
+43 DO FILE1
End DoDot:1
+44 QUIT
+45 ; ********************************************************************
+46 ;
IDENT ; logic to locate segment from ID
+1 SET CURID=$PIECE(SEGX,E)
+2 ;BAR*1.8*3 IM25273 CANNOT HANDLE NTE SEGMENTS
IF CURID="NTE"
QUIT
+3 ; SRS TO BE WRITTEN FOR SPECIFICATIONS
+4 IF CURID'=LSTID
Begin DoDot:1
+5 IF $DATA(LOOP(CURID))
Begin DoDot:2
+6 IF $DATA(BARLOOP("DUP",CURID))
Begin DoDot:3
+7 IF TRNAME["HIPAA"
IF CURID="N1"
Begin DoDot:4
+8 IF $PIECE(SEGX,E,2)="PR"
SET CURSEG="2-080.A-N1"
+9 IF $PIECE(SEGX,E,2)="PE"
SET CURSEG="2-080.B-N1"
End DoDot:4
+10 IF TRNAME["3041.4A"
IF CURID="N1"
Begin DoDot:4
+11 IF $PIECE(SEGX,E,2)="PR"
SET CURSEG="1-080.A-N1"
+12 IF $PIECE(SEGX,E,2)="PE"
SET CURSEG="1-080.B-N1"
End DoDot:4
End DoDot:3
QUIT
+13 SET CURSEG=LOOP(CURID)
End DoDot:2
IF 1
+14 ;S CURSEG=$O(SEGID(CURID,LSTSEG)) ;BAR*1.8*1 SRS PATCH 1 ADDENDUM
IF '$TEST
Begin DoDot:2
+15 ;CHANGE MADE BECAUSE ALGORYTHM DID NOT HANDLE GOING FROM THE B TO NEXT B SEGMENTS
+16 ;IT WOULD SKIP TO THE PREVIOUS A-XXX SEGMENT
+17 SET TEMPSEG=LSTSEG
+18 SET LOOPID1=$PIECE($PIECE(LSTSEG,".",2),"-")
+19 SET CURSEG=$ORDER(SEGID(CURID,LSTSEG))
+20 SET LOOPID2=$PIECE($PIECE(CURSEG,".",2),"-")
+21 IF LOOPID1="B"&(LOOPID2="A")
SET CURSEG=$ORDER(SEGID(CURID,CURSEG))
+22 ;END BAR*1.8*1 SRS PATCH 1 ADDENDUM
End DoDot:2
+23 ;IHS/SD/TPF 12/16/2005 IM19044
+24 IF $GET(CURSEG)=""
IF ($GET(CURID)="ISA")
WRITE !,"File contains more than one ISA/IEA pair at "_$GET(^BAREDI("I",DUZ(2),IMPDA,15,SEGDA))_" . Inform payor and request new file."
HANG 3
QUIT
+25 SET CURUSE=SEGID(CURID,CURSEG)
End DoDot:1
QUIT
+26 ;
+27 IF LSTUSE>1
Begin DoDot:1
+28 SET CURSEG=LSTSEG
+29 SET CURUSE=LSTUSE
End DoDot:1
QUIT
+30 ;
+31 ;bar*1.8*26 IHS/SD/POT HEAT158770
IF CURID="SVC"
QUIT
+32 SET CURSEG=$ORDER(SEGID(CURID,LSTSEG))
+33 SET CURUSE=SEGID(CURID,CURSEG)
+34 QUIT
+35 ; ********************************************************************
+36 ;
FILE1 ;
+1 ;FM HAS ISSUE WITH ^ IN FREE TEXT FIELD
+2 ;IHS/SD/TPF 8/24/2011 BAR*1.8*21
IF $EXTRACT(SEGX,1,3)="ISA"
IF ($EXTRACT(SEGX,83)="^")
SET $EXTRACT(SEGX,83)="U"
+3 IF '(COUNT#10)
WRITE "."
+4 IF '(COUNT#500)
WRITE " ",COUNT,!
+5 SET COUNT=COUNT+1
+6 KILL DIC,DR,DD,DO,DA
+7 SET DIC=$$DIC^XBDIQ1(90056.0101)
+8 SET X=CURSEG
+9 SET DIC(0)="X"
+10 SET DA(1)=TRDA
+11 DO ^DIC
+12 NEW SEGLNK
+13 SET SEGLNK=TRDA_","_+Y
+14 KILL DIC,DR,DD,DO,DA
+15 SET DA(1)=IMPDA
+16 SET DIC("P")="90056.0202A"
+17 SET DIC=$$DIC^XBDIQ1(90056.0202)
+18 SET DLAYGO=90056
+19 SET DIC(0)="FZE"
+20 SET X=SEGDA
+21 SET DIC("DR")=".02///^S X=CURID"
+22 SET DIC("DR")=DIC("DR")_";.03///^S X=CURSEG"
+23 SET DIC("DR")=DIC("DR")_";.04///^S X=SEGLNK"
+24 SET DIC("DR")=DIC("DR")_";1.01///^S X=SEGX"
+25 DO FILE^DICN
+26 KILL DIC,DR,DD,DO
+27 QUIT
+28 ; ********************************************************************
+29 ;
CLEAR(IMPDA) ; kill nodes 15 & 20 for a rerun
+1 KILL ^BAREDI("I",DUZ(2),IMPDA,15)
+2 KILL ^BAREDI("I",DUZ(2),IMPDA,20)
+3 QUIT
