Routine: BAR50P01

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

 ; ********************************************************************

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

 ; ********************************************************************

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

 ; ********************************************************************

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

 ; ********************************************************************

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)

 ; ********************************************************************

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

 ; ********************************************************************

CLEAR(IMPDA) ; kill nodes 15 & 20 for a rerun

 K ^BAREDI("I",DUZ(2),IMPDA,15)

 K ^BAREDI("I",DUZ(2),IMPDA,20)

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

BAR50P01.m