BAR50P02 ; IHS/SD/LSL - PARSE SEGMENTS INTO ELEMENTS AND CONVERT ; 11 Jul 2011 2:50 PM
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,5,20,21,23**;OCT 26,2005
;
; IHS/SD/LSL - 08/19/02 - V1.7 Patch 4 - HIPAA
; Modified EN to use EDI Standard Data Types File if data types
; are not specified in A/R Transport File
;
; IHS/SD/LSL - 02/10/04 - V1.7 Patch 5 - Remark Codes
; Add HRMKCD line tag to look up Remark Codes in
; A/R REMARK CODE File
; Add LQCD line tag for NCPDP reject/payment codes and
; remark codes.
;
; IHS/SD/LSL - 2/9/04 - V1.7 Patch 5 - IM12514
; Denial codes for proprietary ERA not working correctly
;
; IHS/SD/LSL - 06/23/04 V1.8 Patch 1 - IM13518
; "+" standard code before lookup table in case leading zero sent
;
; IHS/SD/SDR - bar*1.8*20 - ERA REQ1 - Added CHKS tag to populate Check/EFT multiple
; JULY 2012: HEAT#76062 Peter Ottis Changed all hardcoded segment delimiters "*"
; to -> E
;
; *******************************************************************
;;
EN(TRDA,IMPDA) ;EP
S TABID=$$GET1^DIQ(90056.01,TRDA,.03) ; Table data type code
;
; gather data types & conversions
K DAT
D ENPM^XBDIQ1(90056.0103,"TRDA,0",".01;.02;.03","DAT(")
I '$D(DAT) D
. S BARI=0
. F S BARI=$O(^BAREDT(BARI)) Q:'+BARI D
. . F BARJ=".01",".02",".03" S DAT(BARI,BARJ)=$$GET1^DIQ(90056.05,BARI,BARJ)
K BARI,BARJ
K DAT("ID") ;node generated by XBDIQ1
; build index of types with conversion code DAT("ID")="S X=F(X)"
S DATDA=0
F S DATDA=$O(DAT(DATDA)) Q:DATDA'>0 D
. ; replace | with ^ for routine tag^rou references
. S DAT(DAT(DATDA,.01))=$TR(DAT(DATDA,.03),"|","^")
;
;pull import record list into ^TMP($J,"SE")
K ^TMP($J,"SE")
W !,"Processing Segment Elements into Values",!
D ENPM^XBDIQ1(90056.0202,"IMPDA,0",".01","^TMP($J,""SE"",")
S RECM="^TMP($J,""SE"")"
; scan import records
S COUNT=1
S RECDA=0
F S RECDA=$O(@RECM@(RECDA)) Q:RECDA'>0 D
. W:'(COUNT#10) "."
. W:'(COUNT#500) " ",COUNT,!
. S COUNT=COUNT+1
. K REC
. D ENP^XBDIQ1(90056.0202,"IMPDA,RECDA",".02;.03;.04;1.01","REC(")
. S PATHS=REC(.04)
. D LOADTR
W " ",COUNT,!
Q
; ********************************************************************
;
LOADTR ;
; load element parsing specifications
S:'$D(E) E="|"
K ^TMP($J,"ELM"),ARRAY
S SEGXDA=$P(PATHS,",",2)
; pull records id, path, and value
D ENPM^XBDIQ1(90056.0102,"TRDA,SEGXDA,0",".01","^TMP($J,""ELM"",")
S ELMDA=0
F S ELMDA=$O(^TMP($J,"ELM",ELMDA)) Q:ELMDA'>0 D
. K ELM
. D ENP^XBDIQ1(90056.0102,"TRDA,SEGXDA,ELMDA",".02;.03;.04;.07;.09","ELM(","I")
. S SEQ=ELM(.03)
. S X=$P(REC(1.01),E,SEQ+1)
. D CONVERT
. ; store converted value in array
. S ARRAY(SEQ)=X
; set array elements into WP field of record
K ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10) ;I DON'T THINK THIS IS SET/ TPF
S I=$O(ARRAY(""),-1)
S ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,0)="^^"_I_"^"_I_"^"_DT
;F ELMDA=1:1:I S ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,ELMDA,0)=ARRAY(ELMDA)
;IHS/SD/TPF 9/6/2011 BAR*18*21 5010 PAGE 2 CHANGE TO N407
;REPLACE ABOVE WITH BELOW BECAUSE WHEN POSTING ELEMENTS ARE SET UP
;FOR ELEMENTS AND YOU SKIP IT CAN'T HANDLE THE SKIPPED ELMENTS.
S ELMDA=""
F S ELMDA=$O(ARRAY(ELMDA)) Q:ELMDA="" D
.S ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,ELMDA,0)=ARRAY(ELMDA)
Q
; ********************************************************************
;
CONVERT ;
; Convert incoming data according to data type(s)
I $L(ELM(.07)) D TABLE Q
I $L(ELM(.09,"I")) D STNDTBL Q
I $D(DAT(ELM(.04))) S XX=DAT(ELM(.04)),XX=$TR(XX,"|","^") X XX Q
S X=X
Q
; ********************************************************************
;
TABLE ;
; perform lookup on table ; ELM(.07) contains path to table
;S X=X_"-TABLE-"_ELM(.07)
S MCODE=$$GET1^DIQ(90056.0105,ELM(.07),.03)
S MCODE=$TR(MCODE,"|","^")
I $L(MCODE) X MCODE Q ;table is using a routine to resolve X
S X=$$FIND(90056.0106,ELM(.07),X) ; regular table entry
Q
; *******************************************************************
;
STNDTBL ; EP - Pull value from A/R EDI TABLES File
S MCODE=$$GET1^DIQ(90056.04,ELM(.09,"I"),.03) ; Processing code
S MCODE=$TR(MCODE,"|","^")
I $L(MCODE) X MCODE Q
; Find standard tables entry
S DA(1)=ELM(.09,"I")
S DIC="^BARETBL("_DA(1)_",1,"
S DIC(0)="XZ"
D ^DIC
I +Y<0 S X=X_" | No Match" Q
S X=X_" | "_$P(Y(0),U,2)
Q
; *******************************************************************
;
DT ;
; Convert date to readable format for HIPAA 835
; ISA09 comes as YYMMDD all other elements are YYYYMMDD
S X=$S($L(X)=6:($E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2)),1:$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4))
S %DT="X"
D ^%DT,DD^%DT
S X=Y
Q
; ********************************************************************
;
CLMCODE ; EP
; .03 (processing routine) for this data type of this element
; find claim reason code
Q:X=""
K DIC,DA
S DIC=$$DIC^XBDIQ1(90056.0107)
S DA(1)=TRDA
S DIC(0)="X"
D ^DIC
I Y'>0 S X=X_" | No Match" Q
S XDA=+Y
S X=X_" | "_$$VAL^XBDIQ1(90056.0107,"TRDA,XDA",.02)
Q
; *******************************************************************
;
CLMADJCD ; EP
; .03 (processing routine) for this data type of this element
; Find standard claim level adjustment code
S X=$TR(X," ") ;BAR*1.8*5 IM26444
Q:X=""
K DIC,DA
I +X>0 S X=+X ;IM13518
S DIC="^BARADJ("
S DIC(0)="ZX"
K DD,DO
D ^DIC
I +Y<0 S X=X_" | No Match" Q
S XDA=+Y
S X=X_" | "_$$GET1^DIQ(90056.06,XDA,.02)
Q
; *******************************************************************
;
RMKCODE ;
; find remark code
Q:X=""
S X=X_" | Remark Code"
Q
; ********************************************************************
;
HRMKCD ; EP
; This line tag called by .03 field in A/R EDI TABLES File
; Processing routine for Remark Code elements to look up in RPMS File
Q:X=""
K DIC,DA
S DIC="^BARMKCD("
S DIC(0)="ZX"
K DD,DO
D ^DIC
I +Y<0 S X=X_" | No Match" Q
S XDA=+Y
S X=X_" | "_$$GET1^DIQ(90056.23,XDA,.02)
Q
; ********************************************************************
;
LQCD ; EP
; This line tag called by .03 field in A/R EDI TABLES File
; Processing routine for Remark or NCPDP Reject Payment Codes.
; Whichever is passed in on LQ02
;
; BARCTYP = HE = Remark Code
; BARCTYP = RX = NCPDP Reject/Payment Code
Q:X=""
S BARCTYP=$P(REC(1.01),E,2) ; Type of Code
I BARCTYP="HE" D HRMKCD Q
I BARCTYP'="RX" D Q
. S X=X_" | No Match"
K DIC,DA
S DIC="^ABSPF(9002313.93,"
S DIC(0)="ZX"
K DD,DO
D ^DIC
I +Y<0 S X=X_" | No Match" Q
S XDA=+Y
S X=X_" | "_$$GET1^DIQ(9002313.93,XDA,.02)
Q
; ********************************************************************
;
PLVCODE ;
; find provider level reason code
; Not called for HIPAA - regular table entry.
Q:X=""
K DIC,DA
S DIC=$$DIC^XBDIQ1(90056.0108)
S DA(1)=TRDA
S DIC(0)="X"
D ^DIC
I Y'>0 S X=X_" | No PLV match" Q
S XDA=+Y,X=X_" | "_$$VAL^XBDIQ1(90056.0108,"TRDA,XDA",.02)
Q
; ********************************************************************
;
FIND(FILE,PATH,X) ;
;find X in file and return X_VALUE
K DIC,DA
I X="" Q X
;
S DIC=$$DIC^XBDIQ1(FILE)
S DIC(0)="XZ"
F I=1:1 S DAZ(I)=$P(PATH,",",I) Q:DAZ(I)'>0
F C=1:1:I-1 S DA(C)=DAZ(I-C)
D ^DIC
I Y'>0 S X=X_" | NO MATCH" Q X
S X=X_" | "_$P(Y(0),U,2)
Q X
;start new code bar*1.8*20 REQ1
CHKS(IMPDA) ;EP - POPULATE CHECK/EFTS SUBFILE IN IMPORT FILE
N BARCTMP
S I=0,BARCCNT=1
F S I=$O(^BAREDI("I",DUZ(2),IMPDA,15,I)) Q:'I D
.S IREC=$G(^BAREDI("I",DUZ(2),IMPDA,15,I,0))
. ;;;Q:$P(IREC,"*")'="ST"
. ;;;S $P(BARCTMP(BARCCNT),U,2)=$P(IREC,"*",3) ;ST control#
. Q:$P(IREC,E)'="ST" ;P.OTT
. S $P(BARCTMP(BARCCNT),U,2)=$P(IREC,E,3) ;ST control# P.OTT
. S I=I+1
.;S $P(BARCTMP(BARCCNT),U,4)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",2) ;BPR01
.;S $P(BARCTMP(BARCCNT),U,3)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;BPR02
.;S $P(BARCTMP(BARCCNT),U,5)=($P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",17)-17000000) ;BPR16
.S $P(BARCTMP(BARCCNT),U,4)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,2) ;BPR01
.S $P(BARCTMP(BARCCNT),U,3)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3) ;BPR02
.S $P(BARCTMP(BARCCNT),U,5)=($P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,17)-17000000) ;BPR16
.S I=I+1
.;I $P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*")="NTE" S I=I+1 ;check for NTE that PNC includes here ;bar*1.8*21
.;start new code bar*1.8*21 IHS/SD/SDR
.S BARQ=0
.F D Q:BARQ=1
..;;;I $P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*")="NTE" S I=I+1
..I $P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E)="NTE" S I=I+1
..E S BARQ=1
.;end new code bar*1.8*21
. ;;;S $P(BARCTMP(BARCCNT),U)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;TRN02
. S $P(BARCTMP(BARCCNT),U)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3) ;TRN02
.S I=I+2
. ;;;S $P(BARCTMP(BARCCNT),U,6)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;N102
.S $P(BARCTMP(BARCCNT),U,6)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3) ;N102
.S $P(BARCTMP(BARCCNT),U,11)="UNF"
.S BARCCNT=+$G(BARCCNT)+1
S BARCCNT=0
D PLB
F S BARCCNT=$O(BARCTMP(BARCCNT)) Q:'BARCCNT D
.K DIC,DIE,DIR,X,Y,DA
.S DA(1)=IMPDA
.S DIC="^BAREDI(""I"","_DUZ(2)_","_DA(1)_",5,"
.S DIC("P")=$P(^DD(90056.02,5,0),U,2)
.S DIC(0)=""
.S X=$P(BARCTMP(BARCCNT),U)
.S DIC("DR")=".02////"_$P(BARCTMP(BARCCNT),U,2)
.S DIC("DR")=DIC("DR")_";.03////"_$P(BARCTMP(BARCCNT),U,3)
.S DIC("DR")=DIC("DR")_";.04////"_$P(BARCTMP(BARCCNT),U,4)
.S DIC("DR")=DIC("DR")_";.05////"_$P(BARCTMP(BARCCNT),U,5)
.S DIC("DR")=DIC("DR")_";.06////"_$P(BARCTMP(BARCCNT),U,6)
.S DIC("DR")=DIC("DR")_";.09////"_$P(BARCTMP(BARCCNT),U,9)
.S DIC("DR")=DIC("DR")_";.11////"_$P(BARCTMP(BARCCNT),U,11)
.K DD,DO
.D FILE^DICN
Q
PLB ; EP
;ADD UP ALL PLB AMOUNTS FOR DISPLAY P.OTT: ALL "*"-> E
N BARCDA,CNT,BARVCK,BARSEG,BARSCK
S BARCDA=0
S (BARVCK,BARSCK)=""
F CNT=1:1 S BARCDA=$O(^BAREDI("I",DUZ(2),IMPDA,15,BARCDA)) Q:'BARCDA D
.W:'(CNT#1000) "."
.S BAR15=^BAREDI("I",DUZ(2),IMPDA,15,BARCDA,0)
.S BARSEG=$P(BAR15,E)
.S:BARSEG="TRN" BARVCK=$P(BAR15,E,3) ;Check Number
.Q:BARSEG'="PLB" ;Only want PLB
.S BARCCNT=0
.F S BARCCNT=$O(BARCTMP(BARCCNT)) Q:'BARCCNT D
..Q:($P($G(BARCTMP(BARCCNT)),U)'=BARVCK) ;find check number in temp array
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,5) ;PLB amount PLB04
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,7) ;PLB amount PLB06
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,9) ;PLB amount PLB08
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,11) ;PLB amount PLB10
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,13) ;PLB amount PLB12
..S $P(BARCTMP(BARCCNT),U,9)=+$P(BARCTMP(BARCCNT),U,9)+$P(BAR15,E,15) ;PLB amount PLB14
Q
BAR50P02 ; IHS/SD/LSL - PARSE SEGMENTS INTO ELEMENTS AND CONVERT ; 11 Jul 2011 2:50 PM
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,5,20,21,23**;OCT 26,2005
+2 ;
+3 ; IHS/SD/LSL - 08/19/02 - V1.7 Patch 4 - HIPAA
+4 ; Modified EN to use EDI Standard Data Types File if data types
+5 ; are not specified in A/R Transport File
+6 ;
+7 ; IHS/SD/LSL - 02/10/04 - V1.7 Patch 5 - Remark Codes
+8 ; Add HRMKCD line tag to look up Remark Codes in
+9 ; A/R REMARK CODE File
+10 ; Add LQCD line tag for NCPDP reject/payment codes and
+11 ; remark codes.
+12 ;
+13 ; IHS/SD/LSL - 2/9/04 - V1.7 Patch 5 - IM12514
+14 ; Denial codes for proprietary ERA not working correctly
+15 ;
+16 ; IHS/SD/LSL - 06/23/04 V1.8 Patch 1 - IM13518
+17 ; "+" standard code before lookup table in case leading zero sent
+18 ;
+19 ; IHS/SD/SDR - bar*1.8*20 - ERA REQ1 - Added CHKS tag to populate Check/EFT multiple
+20 ; JULY 2012: HEAT#76062 Peter Ottis Changed all hardcoded segment delimiters "*"
+21 ; to -> E
+22 ;
+23 ; *******************************************************************
+24 ;;
EN(TRDA,IMPDA) ;EP
+1 ; Table data type code
SET TABID=$$GET1^DIQ(90056.01,TRDA,.03)
+2 ;
+3 ; gather data types & conversions
+4 KILL DAT
+5 DO ENPM^XBDIQ1(90056.0103,"TRDA,0",".01;.02;.03","DAT(")
+6 IF '$DATA(DAT)
Begin DoDot:1
+7 SET BARI=0
+8 FOR
SET BARI=$ORDER(^BAREDT(BARI))
IF '+BARI
QUIT
Begin DoDot:2
+9 FOR BARJ=".01",".02",".03"
SET DAT(BARI,BARJ)=$$GET1^DIQ(90056.05,BARI,BARJ)
End DoDot:2
End DoDot:1
+10 KILL BARI,BARJ
+11 ;node generated by XBDIQ1
KILL DAT("ID")
+12 ; build index of types with conversion code DAT("ID")="S X=F(X)"
+13 SET DATDA=0
+14 FOR
SET DATDA=$ORDER(DAT(DATDA))
IF DATDA'>0
QUIT
Begin DoDot:1
+15 ; replace | with ^ for routine tag^rou references
+16 SET DAT(DAT(DATDA,.01))=$TRANSLATE(DAT(DATDA,.03),"|","^")
End DoDot:1
+17 ;
+18 ;pull import record list into ^TMP($J,"SE")
+19 KILL ^TMP($JOB,"SE")
+20 WRITE !,"Processing Segment Elements into Values",!
+21 DO ENPM^XBDIQ1(90056.0202,"IMPDA,0",".01","^TMP($J,""SE"",")
+22 SET RECM="^TMP($J,""SE"")"
+23 ; scan import records
+24 SET COUNT=1
+25 SET RECDA=0
+26 FOR
SET RECDA=$ORDER(@RECM@(RECDA))
IF RECDA'>0
QUIT
Begin DoDot:1
+27 IF '(COUNT#10)
WRITE "."
+28 IF '(COUNT#500)
WRITE " ",COUNT,!
+29 SET COUNT=COUNT+1
+30 KILL REC
+31 DO ENP^XBDIQ1(90056.0202,"IMPDA,RECDA",".02;.03;.04;1.01","REC(")
+32 SET PATHS=REC(.04)
+33 DO LOADTR
End DoDot:1
+34 WRITE " ",COUNT,!
+35 QUIT
+36 ; ********************************************************************
+37 ;
LOADTR ;
+1 ; load element parsing specifications
+2 IF '$DATA(E)
SET E="|"
+3 KILL ^TMP($JOB,"ELM"),ARRAY
+4 SET SEGXDA=$PIECE(PATHS,",",2)
+5 ; pull records id, path, and value
+6 DO ENPM^XBDIQ1(90056.0102,"TRDA,SEGXDA,0",".01","^TMP($J,""ELM"",")
+7 SET ELMDA=0
+8 FOR
SET ELMDA=$ORDER(^TMP($JOB,"ELM",ELMDA))
IF ELMDA'>0
QUIT
Begin DoDot:1
+9 KILL ELM
+10 DO ENP^XBDIQ1(90056.0102,"TRDA,SEGXDA,ELMDA",".02;.03;.04;.07;.09","ELM(","I")
+11 SET SEQ=ELM(.03)
+12 SET X=$PIECE(REC(1.01),E,SEQ+1)
+13 DO CONVERT
+14 ; store converted value in array
+15 SET ARRAY(SEQ)=X
End DoDot:1
+16 ; set array elements into WP field of record
+17 ;I DON'T THINK THIS IS SET/ TPF
KILL ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10)
+18 SET I=$ORDER(ARRAY(""),-1)
+19 SET ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,0)="^^"_I_"^"_I_"^"_DT
+20 ;F ELMDA=1:1:I S ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,ELMDA,0)=ARRAY(ELMDA)
+21 ;IHS/SD/TPF 9/6/2011 BAR*18*21 5010 PAGE 2 CHANGE TO N407
+22 ;REPLACE ABOVE WITH BELOW BECAUSE WHEN POSTING ELEMENTS ARE SET UP
+23 ;FOR ELEMENTS AND YOU SKIP IT CAN'T HANDLE THE SKIPPED ELMENTS.
+24 SET ELMDA=""
+25 FOR
SET ELMDA=$ORDER(ARRAY(ELMDA))
IF ELMDA=""
QUIT
Begin DoDot:1
+26 SET ^BAREDI("I",DUZ(2),IMPDA,20,RECDA,10,ELMDA,0)=ARRAY(ELMDA)
End DoDot:1
+27 QUIT
+28 ; ********************************************************************
+29 ;
CONVERT ;
+1 ; Convert incoming data according to data type(s)
+2 IF $LENGTH(ELM(.07))
DO TABLE
QUIT
+3 IF $LENGTH(ELM(.09,"I"))
DO STNDTBL
QUIT
+4 IF $DATA(DAT(ELM(.04)))
SET XX=DAT(ELM(.04))
SET XX=$TRANSLATE(XX,"|","^")
XECUTE XX
QUIT
+5 SET X=X
+6 QUIT
+7 ; ********************************************************************
+8 ;
TABLE ;
+1 ; perform lookup on table ; ELM(.07) contains path to table
+2 ;S X=X_"-TABLE-"_ELM(.07)
+3 SET MCODE=$$GET1^DIQ(90056.0105,ELM(.07),.03)
+4 SET MCODE=$TRANSLATE(MCODE,"|","^")
+5 ;table is using a routine to resolve X
IF $LENGTH(MCODE)
XECUTE MCODE
QUIT
+6 ; regular table entry
SET X=$$FIND(90056.0106,ELM(.07),X)
+7 QUIT
+8 ; *******************************************************************
+9 ;
STNDTBL ; EP - Pull value from A/R EDI TABLES File
+1 ; Processing code
SET MCODE=$$GET1^DIQ(90056.04,ELM(.09,"I"),.03)
+2 SET MCODE=$TRANSLATE(MCODE,"|","^")
+3 IF $LENGTH(MCODE)
XECUTE MCODE
QUIT
+4 ; Find standard tables entry
+5 SET DA(1)=ELM(.09,"I")
+6 SET DIC="^BARETBL("_DA(1)_",1,"
+7 SET DIC(0)="XZ"
+8 DO ^DIC
+9 IF +Y<0
SET X=X_" | No Match"
QUIT
+10 SET X=X_" | "_$PIECE(Y(0),U,2)
+11 QUIT
+12 ; *******************************************************************
+13 ;
DT ;
+1 ; Convert date to readable format for HIPAA 835
+2 ; ISA09 comes as YYMMDD all other elements are YYYYMMDD
+3 SET X=$SELECT($LENGTH(X)=6:($EXTRACT(X,3,4)_"/"_$EXTRACT(X,5,6)_"/"_$EXTRACT(X,1,2)),1:$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4))
+4 SET %DT="X"
+5 DO ^%DT
DO DD^%DT
+6 SET X=Y
+7 QUIT
+8 ; ********************************************************************
+9 ;
CLMCODE ; EP
+1 ; .03 (processing routine) for this data type of this element
+2 ; find claim reason code
+3 IF X=""
QUIT
+4 KILL DIC,DA
+5 SET DIC=$$DIC^XBDIQ1(90056.0107)
+6 SET DA(1)=TRDA
+7 SET DIC(0)="X"
+8 DO ^DIC
+9 IF Y'>0
SET X=X_" | No Match"
QUIT
+10 SET XDA=+Y
+11 SET X=X_" | "_$$VAL^XBDIQ1(90056.0107,"TRDA,XDA",.02)
+12 QUIT
+13 ; *******************************************************************
+14 ;
CLMADJCD ; EP
+1 ; .03 (processing routine) for this data type of this element
+2 ; Find standard claim level adjustment code
+3 ;BAR*1.8*5 IM26444
SET X=$TRANSLATE(X," ")
+4 IF X=""
QUIT
+5 KILL DIC,DA
+6 ;IM13518
IF +X>0
SET X=+X
+7 SET DIC="^BARADJ("
+8 SET DIC(0)="ZX"
+9 KILL DD,DO
+10 DO ^DIC
+11 IF +Y<0
SET X=X_" | No Match"
QUIT
+12 SET XDA=+Y
+13 SET X=X_" | "_$$GET1^DIQ(90056.06,XDA,.02)
+14 QUIT
+15 ; *******************************************************************
+16 ;
RMKCODE ;
+1 ; find remark code
+2 IF X=""
QUIT
+3 SET X=X_" | Remark Code"
+4 QUIT
+5 ; ********************************************************************
+6 ;
HRMKCD ; EP
+1 ; This line tag called by .03 field in A/R EDI TABLES File
+2 ; Processing routine for Remark Code elements to look up in RPMS File
+3 IF X=""
QUIT
+4 KILL DIC,DA
+5 SET DIC="^BARMKCD("
+6 SET DIC(0)="ZX"
+7 KILL DD,DO
+8 DO ^DIC
+9 IF +Y<0
SET X=X_" | No Match"
QUIT
+10 SET XDA=+Y
+11 SET X=X_" | "_$$GET1^DIQ(90056.23,XDA,.02)
+12 QUIT
+13 ; ********************************************************************
+14 ;
LQCD ; EP
+1 ; This line tag called by .03 field in A/R EDI TABLES File
+2 ; Processing routine for Remark or NCPDP Reject Payment Codes.
+3 ; Whichever is passed in on LQ02
+4 ;
+5 ; BARCTYP = HE = Remark Code
+6 ; BARCTYP = RX = NCPDP Reject/Payment Code
+7 IF X=""
QUIT
+8 ; Type of Code
SET BARCTYP=$PIECE(REC(1.01),E,2)
+9 IF BARCTYP="HE"
DO HRMKCD
QUIT
+10 IF BARCTYP'="RX"
Begin DoDot:1
+11 SET X=X_" | No Match"
End DoDot:1
QUIT
+12 KILL DIC,DA
+13 SET DIC="^ABSPF(9002313.93,"
+14 SET DIC(0)="ZX"
+15 KILL DD,DO
+16 DO ^DIC
+17 IF +Y<0
SET X=X_" | No Match"
QUIT
+18 SET XDA=+Y
+19 SET X=X_" | "_$$GET1^DIQ(9002313.93,XDA,.02)
+20 QUIT
+21 ; ********************************************************************
+22 ;
PLVCODE ;
+1 ; find provider level reason code
+2 ; Not called for HIPAA - regular table entry.
+3 IF X=""
QUIT
+4 KILL DIC,DA
+5 SET DIC=$$DIC^XBDIQ1(90056.0108)
+6 SET DA(1)=TRDA
+7 SET DIC(0)="X"
+8 DO ^DIC
+9 IF Y'>0
SET X=X_" | No PLV match"
QUIT
+10 SET XDA=+Y
SET X=X_" | "_$$VAL^XBDIQ1(90056.0108,"TRDA,XDA",.02)
+11 QUIT
+12 ; ********************************************************************
+13 ;
FIND(FILE,PATH,X) ;
+1 ;find X in file and return X_VALUE
+2 KILL DIC,DA
+3 IF X=""
QUIT X
+4 ;
+5 SET DIC=$$DIC^XBDIQ1(FILE)
+6 SET DIC(0)="XZ"
+7 FOR I=1:1
SET DAZ(I)=$PIECE(PATH,",",I)
IF DAZ(I)'>0
QUIT
+8 FOR C=1:1:I-1
SET DA(C)=DAZ(I-C)
+9 DO ^DIC
+10 IF Y'>0
SET X=X_" | NO MATCH"
QUIT X
+11 SET X=X_" | "_$PIECE(Y(0),U,2)
+12 QUIT X
+13 ;start new code bar*1.8*20 REQ1
CHKS(IMPDA) ;EP - POPULATE CHECK/EFTS SUBFILE IN IMPORT FILE
+1 NEW BARCTMP
+2 SET I=0
SET BARCCNT=1
+3 FOR
SET I=$ORDER(^BAREDI("I",DUZ(2),IMPDA,15,I))
IF 'I
QUIT
Begin DoDot:1
+4 SET IREC=$GET(^BAREDI("I",DUZ(2),IMPDA,15,I,0))
+5 ;;;Q:$P(IREC,"*")'="ST"
+6 ;;;S $P(BARCTMP(BARCCNT),U,2)=$P(IREC,"*",3) ;ST control#
+7 ;P.OTT
IF $PIECE(IREC,E)'="ST"
QUIT
+8 ;ST control# P.OTT
SET $PIECE(BARCTMP(BARCCNT),U,2)=$PIECE(IREC,E,3)
+9 SET I=I+1
+10 ;S $P(BARCTMP(BARCCNT),U,4)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",2) ;BPR01
+11 ;S $P(BARCTMP(BARCCNT),U,3)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;BPR02
+12 ;S $P(BARCTMP(BARCCNT),U,5)=($P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",17)-17000000) ;BPR16
+13 ;BPR01
SET $PIECE(BARCTMP(BARCCNT),U,4)=$PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,2)
+14 ;BPR02
SET $PIECE(BARCTMP(BARCCNT),U,3)=$PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3)
+15 ;BPR16
SET $PIECE(BARCTMP(BARCCNT),U,5)=($PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,17)-17000000)
+16 SET I=I+1
+17 ;I $P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*")="NTE" S I=I+1 ;check for NTE that PNC includes here ;bar*1.8*21
+18 ;start new code bar*1.8*21 IHS/SD/SDR
+19 SET BARQ=0
+20 FOR
Begin DoDot:2
+21 ;;;I $P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*")="NTE" S I=I+1
+22 IF $PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E)="NTE"
SET I=I+1
+23 IF '$TEST
SET BARQ=1
End DoDot:2
IF BARQ=1
QUIT
+24 ;end new code bar*1.8*21
+25 ;;;S $P(BARCTMP(BARCCNT),U)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;TRN02
+26 ;TRN02
SET $PIECE(BARCTMP(BARCCNT),U)=$PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3)
+27 SET I=I+2
+28 ;;;S $P(BARCTMP(BARCCNT),U,6)=$P(^BAREDI("I",DUZ(2),IMPDA,15,I,0),"*",3) ;N102
+29 ;N102
SET $PIECE(BARCTMP(BARCCNT),U,6)=$PIECE(^BAREDI("I",DUZ(2),IMPDA,15,I,0),E,3)
+30 SET $PIECE(BARCTMP(BARCCNT),U,11)="UNF"
+31 SET BARCCNT=+$GET(BARCCNT)+1
End DoDot:1
+32 SET BARCCNT=0
+33 DO PLB
+34 FOR
SET BARCCNT=$ORDER(BARCTMP(BARCCNT))
IF 'BARCCNT
QUIT
Begin DoDot:1
+35 KILL DIC,DIE,DIR,X,Y,DA
+36 SET DA(1)=IMPDA
+37 SET DIC="^BAREDI(""I"","_DUZ(2)_","_DA(1)_",5,"
+38 SET DIC("P")=$PIECE(^DD(90056.02,5,0),U,2)
+39 SET DIC(0)=""
+40 SET X=$PIECE(BARCTMP(BARCCNT),U)
+41 SET DIC("DR")=".02////"_$PIECE(BARCTMP(BARCCNT),U,2)
+42 SET DIC("DR")=DIC("DR")_";.03////"_$PIECE(BARCTMP(BARCCNT),U,3)
+43 SET DIC("DR")=DIC("DR")_";.04////"_$PIECE(BARCTMP(BARCCNT),U,4)
+44 SET DIC("DR")=DIC("DR")_";.05////"_$PIECE(BARCTMP(BARCCNT),U,5)
+45 SET DIC("DR")=DIC("DR")_";.06////"_$PIECE(BARCTMP(BARCCNT),U,6)
+46 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(BARCTMP(BARCCNT),U,9)
+47 SET DIC("DR")=DIC("DR")_";.11////"_$PIECE(BARCTMP(BARCCNT),U,11)
+48 KILL DD,DO
+49 DO FILE^DICN
End DoDot:1
+50 QUIT
PLB ; EP
+1 ;ADD UP ALL PLB AMOUNTS FOR DISPLAY P.OTT: ALL "*"-> E
+2 NEW BARCDA,CNT,BARVCK,BARSEG,BARSCK
+3 SET BARCDA=0
+4 SET (BARVCK,BARSCK)=""
+5 FOR CNT=1:1
SET BARCDA=$ORDER(^BAREDI("I",DUZ(2),IMPDA,15,BARCDA))
IF 'BARCDA
QUIT
Begin DoDot:1
+6 IF '(CNT#1000)
WRITE "."
+7 SET BAR15=^BAREDI("I",DUZ(2),IMPDA,15,BARCDA,0)
+8 SET BARSEG=$PIECE(BAR15,E)
+9 ;Check Number
IF BARSEG="TRN"
SET BARVCK=$PIECE(BAR15,E,3)
+10 ;Only want PLB
IF BARSEG'="PLB"
QUIT
+11 SET BARCCNT=0
+12 FOR
SET BARCCNT=$ORDER(BARCTMP(BARCCNT))
IF 'BARCCNT
QUIT
Begin DoDot:2
+13 ;find check number in temp array
IF ($PIECE($GET(BARCTMP(BARCCNT)),U)'=BARVCK)
QUIT
+14 ;PLB amount PLB04
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,5)
+15 ;PLB amount PLB06
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,7)
+16 ;PLB amount PLB08
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,9)
+17 ;PLB amount PLB10
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,11)
+18 ;PLB amount PLB12
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,13)
+19 ;PLB amount PLB14
SET $PIECE(BARCTMP(BARCCNT),U,9)=+$PIECE(BARCTMP(BARCCNT),U,9)+$PIECE(BAR15,E,15)
End DoDot:2
End DoDot:1
+20 QUIT
