BPSECMPS ;BHAM ISC/FCS/DRS - Parse Claim Response ;3/10/08 12:31
;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,6,7,10,11,15,19,20**;JUN 2004;Build 27
;;Per VA Directive 6402, this routine should not be modified.
;
; References to UPDATE^DIE and WP^DIE supported by DBIA 2053
; Reference to FDA^DILF supported by DBIA 2054
;
PARSE(RREC,CLAIMIEN,IEN59,TRANTYPE) ;
; Parse the response from the payer and file it in the BPS Response record
; Incoming Parameters:
; RREC - HL7 message
; CLAIMIEN - IEN of the BPS Claim file
; IEN59 - IEN of the BPS Transaction file
; TRANTYPE - Transaction Type (B1-Billing Request, B2-Reversal, E1-Eligibility)
; Return value:
; RESPIEN - IEN of the BPS Response file
;
N FDAIEN,FDAIEN03,FDATA,FILE,FS,GS,ROOT,SS,TRANSACT,TRANSCNT
;
; RREC and CLAIMIEN are required
Q:$G(RREC)="" 0
Q:$G(CLAIMIEN)="" 0
;
;group and field separator characters
S GS="\X1D\",FS="\X1C\",SS="\X1E\"
S FILE="9002313.03",ROOT="FDATA(9002313.03)"
D TRANSMSN ; process transmission level data, transaction count in TRANSCNT (from PARSEH)
D TRANSACT ; process transaction level data
;
; If test system and test active, call the override routine
; IEN59 and TRANTYPE are set in BPSECMC2
I $$CHECK^BPSTEST D SETOVER^BPSTEST(+$G(IEN59),$G(TRANTYPE),.FDATA)
;
D UPDATE^DIE("S","FDATA(9002313.03)","FDAIEN")
F TRANSACT=1:1:TRANSCNT D
.D PROCRESP
.D PROCREJ
.D PROCAPP
.D PROCPPR
.D PROCCOB
.D PROCOTH^BPSECMP2
.D PROCBEN^BPSECMP2
.D PROCADM^BPSECMP2
.D PROCDUR^BPSECMP2
.D PROCINT
.D PROCQLIM ; process Quantity limit time period multiple
.D PROCDSLM ; process Days Supply limit time period multiple
.Q
;
S RESPIEN=FDAIEN(1)
; This should be called for each transaction but the IBSEND is not
; setup correctly so currently it is only called for each claim/response
; If we ever bundle claims, we will need to fix IBSEND and move this code
; to the FOR loop above.
D IBSEND^BPSECMP2(CLAIMIEN,RESPIEN,"","")
D RAW(RESPIEN,RREC)
;
Q RESPIEN
;
TRANSMSN ;This subroutine will work through the transmission level information
;
N RHEADER,RTRANM,SEG,SEGID,SEGMENT
;
;Parse response transmission level from ascii record
S RTRANM=$P(RREC,GS,1)
;
; get just the header segment
S RHEADER=$P(RTRANM,SS,1) ;header- required/fixed length
D PARSEH
;
; There are 2 optional segments on the transmission level - message
; and insurance. We'll check for both and parse what we find.
F SEG=2:1:3 D
. S SEGMENT=$P(RTRANM,SS,SEG)
. Q:SEGMENT=""
. S SEGID=$P(SEGMENT,FS,2)
. I $E(SEGID,1,2)="AM" D ; segment identification
.. S SEGFID=$E(SEGID,3,4)
.. D:(SEGFID=20)!(SEGFID=25) PARSETM
;
Q
;
TRANSACT ;This subroutine will work through the transaction level information
;
N GRP,MEDN,RTRAN,SEG,SEGMENT
S MEDN=0
;
F GRP=2:1 D Q:RTRAN=""
. S RTRAN=$P(RREC,GS,GRP) ;get the next transaction (could be 4)
. Q:RTRAN="" ;we're done if it's empty
. S MEDN=MEDN+1 ;transaction counter
. ;
. F SEG=2:1 D Q:SEGMENT="" ;break the record down by segments
.. S SEGMENT=$P(RTRAN,SS,SEG) ;get the segment
.. Q:SEGMENT=""
.. D PARSETN ;get the fields
Q
;
PARSEH ; parse the header record, required on all responses, and is fixed length
; It's the only record that is fixed length.
;
D FDA^DILF(FILE,"+1",.01,"",CLAIMIEN,ROOT) ; CLAIM ID
D FDA^DILF(FILE,"+1",.02,"",$$NOWFM^BPSOSU1,ROOT) ; DATE RESPONSE RECEIVED
D FDA^DILF(FILE,"+1",102,"",$E(RHEADER,33,34),ROOT) ; VERSION RELEASE NUMBER
D FDA^DILF(FILE,"+1",103,"",$E(RHEADER,35,36),ROOT) ; TRANSACTION CODE
D FDA^DILF(FILE,"+1",109,"",$E(RHEADER,37,37),ROOT) ; TRANSACTION COUNT
S TRANSCNT=$E(RHEADER,37,37)
D FDA^DILF(FILE,"+1",501,"",$E(RHEADER,38,38),ROOT) ; response status header
D FDA^DILF(FILE,"+1",202,"",$E(RHEADER,39,40),ROOT) ; SERVICE PROVIDER ID Qualifier
D FDA^DILF(FILE,"+1",201,"",$E(RHEADER,41,55),ROOT) ; SERVICE PROVIDER ID
D FDA^DILF(FILE,"+1",401,"",$E(RHEADER,56,63),ROOT) ; DATE OF SERVICE
;
Q
;
PARSETM ; parse the variable portions of the transmission
;
N FIELD,FLDNUM,PC
;
F PC=3:1 D Q:FIELD="" ;skip the seg id -already know its value
. S FIELD=$P(SEGMENT,FS,PC) ;piece through the record
. Q:FIELD="" ;stop - we hit the end
. S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage
. Q:FLDNUM="" ;shouldn't happen - but let's skip
. S FIELD=$E(FIELD,3,999)
. D FDA^DILF(FILE,"+1",FLDNUM,"",FIELD,ROOT)
Q
;
PARSETN ; parse the transaction level segments
;
; Possible values of the SEGFID field:
; 21 = Response Status Segment
; 22 = Response Claim Segment
; 23 = Response Pricing Segment
; 24 = Response DUR/PPS Segment
; 26 = Response Prior Authorization Segment
; 28 = Response Coordination of Benefits/Other Payers Segment
; 36 = Response Intermediary Segment
;
N CKRPT,FIELD,FLDNUM,PC,REPEAT,RPTFLD,SEGFID,SEGID,GRPCNT,GRPFLDS,VNUM
;
S RPTFLD=""
S SEGID=$P(SEGMENT,FS,2) ; this should be the segment id
Q:SEGID="" ; don't process without a Seg id
Q:$E(SEGID,1,2)'="AM" ; don't know what we have - skip
;
S SEGFID=$E(SEGID,3,4) ; this should be the field ID
S GRPCNT=0,GRPFLDS=""
;
; setup the repeating flds based on the segment
I SEGFID=21 D ;status segment
. S RPTFLD=",548,511,546,132,526,131,"
. S GRPCNT=0
. S GRPFLDS=",511,548,132,"
;
I SEGFID=22 D ;claim segment
. S RPTFLD=",552,553,554,555,556,B88,B89,B91,B92,"
. S GRPCNT=0
. S GRPFLDS=",552,B88,B91,"
;
I SEGFID=23 D ;pricing segment
. S RPTFLD=",564,565,393,394,"
. S GRPCNT=0
. S GRPFLDS=",564,393,"
;
I SEGFID=24 D ;DUR/PPS segment
. S RPTFLD=",439,528,529,530,531,532,533,544,567,570,"
. S GRPCNT=0
. S GRPFLDS=",567,"
;
I SEGFID=28 D ;COB/Other Payers segment
. S RPTFLD=",127,142,143,144,145,338,339,340,356,991,992,B23,"
. S GRPCNT=0
. S GRPFLDS=",338,"
;
I SEGFID=36 D ;Intermediary segment
. S RPTFLD=",B53,B54,B51,"
. S GRPCNT=0
. S GRPFLDS=",B53,"
;
; now let's parse out the fields
;
F PC=3:1 D Q:FIELD="" ;skip the seg id -jump to the other flds
. S FIELD=$P(SEGMENT,FS,PC) ;piece through the record
. Q:FIELD="" ;stop - we hit the end
. S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage
. Q:FLDNUM="" ;shouldn't happen - but let's skip
. S VNUM=FLDNUM
. ;Convert to VistA field number for non-numeric NCPDP numbers - BPS*1*15
. I $P(FLDNUM,".")'?3N S VNUM=$$VNUM(FLDNUM) Q:'VNUM
. S REPEAT=0 ;for this segment, let's figure
. S CKRPT=","_FLDNUM_"," ;out if the field is a repeating
. S:RPTFLD[CKRPT REPEAT=1 ;field
. ; Increment the group counter if first field of group.
. S:GRPFLDS[CKRPT GRPCNT=GRPCNT+1
. ; if rptg, store with a group counter
. S:REPEAT FDATA(MEDN,VNUM,GRPCNT)=$E(FIELD,3,$L(FIELD))
. ; not rptg, store without counter
. S:'REPEAT FDATA(MEDN,VNUM)=$E(FIELD,3,$L(FIELD))
;
Q
;
GETNUM(FIELD) ; function, return field number for a field I
; use BPS NCPDP FIELD DEFS (#9002313.91) "D" cross ref for lookup
; field number is used to store the data in the correct field in BPS RESPONSES (#9002313.03)
;
N FLDID,FLDIEN,FLDNUM
S FLDID=$E(FIELD,1,2),FLDNUM=""
Q:FLDID="" FLDNUM ; FLDID = field identifier
;
S FLDIEN=$O(^BPSF(9002313.91,"D",FLDID,0)) ; ien for fld #
S:FLDIEN FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) ;fld number
Q FLDNUM
;
VNUM(FLDNUM) ;function, returns VistA FileMan field number
N FLDIEN
S FLDIEN=$O(^BPSF(9002313.91,"B",FLDNUM,0)) Q:'FLDIEN ""
S FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,5)),U,3) ;fld number
Q FLDNUM
;
PROCRESP ; add data to RESPONSES SUB-FIELD (#9002313.0301)
;
N FDATA03,FIELD,FILE,FLDNUM,ROOT
;
S FILE=9002313.0301,ROOT="FDATA03(9002313.0301)"
; field 501 is HEADER RESPONSE STATUS, 112 is TRANSACTION RESPONSE STATUS
I '$D(FDATA(TRANSACT,501)) S FDATA(TRANSACT,501)=FDATA(TRANSACT,112)
I '$D(FDATA(TRANSACT,112)) S FDATA(TRANSACT,112)=FDATA(TRANSACT,501)
;
S FLDNUM=".01" D FDA^DILF(FILE,"+1,"_FDAIEN(TRANSACT),FLDNUM,"",TRANSACT,ROOT)
S FIELD=""
F S FIELD=$O(FDATA(TRANSACT,FIELD)) Q:FIELD="" D ;set all the non-repeating fields for 9002313.0301
.Q:$G(FDATA(TRANSACT,FIELD))="" ; no data to process
.; field 402 is PRESCRIPTION/SERVICE REF. NO.
.I FIELD=402 S FDATA(TRANSACT,FIELD)=$TR(FDATA(TRANSACT,FIELD),"\","") ;REMOVE EXTRANEOUS "\"
.D FDA^DILF(FILE,"+"_TRANSACT_","_FDAIEN(TRANSACT),FIELD,"",FDATA(TRANSACT,FIELD),ROOT)
;
D UPDATE^DIE("S","FDATA03(9002313.0301)","FDAIEN03")
;
Q
;
PROCREJ ; add data to REJECT CODE SUB-FIELD (#9002313.03511)
Q:$G(FDATA(TRANSACT,510))=""
;
N FDAT3511,FILE,FLDNUM,NNDX,NUMREJS,ROOT,REJCODE
;
S FILE="9002313.03511",ROOT="FDAT3511(9002313.03511)",NUMREJS=FDATA(TRANSACT,510),NNDX=""
F S NNDX=$O(FDATA(TRANSACT,511,NNDX)) Q:NNDX="" D ;set all the non-repeating fields for 9002313.03511 rejections
.S REJCODE=$$TRIM^XLFSTR(FDATA(TRANSACT,511,NNDX),"R")
.S REJCODE=$TR(REJCODE,"\","") Q:REJCODE']""
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",REJCODE,ROOT)
D UPDATE^DIE("S","FDAT3511(9002313.03511)")
;
Q
;
PROCAPP ; APPROVED MESSAGE CODE SUB-FIELD (#9002313.301548)
Q:$O(FDATA(TRANSACT,548,0))=""
;
N FDAT1548,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.301548",ROOT="FDAT1548(9002313.301548)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,548,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",FDATA(TRANSACT,548,NNDX),ROOT)
D UPDATE^DIE("S","FDAT1548(9002313.301548)")
;
Q
;
PROCPPR ; PREFERRED PRODUCT REPEATING SUB-FIELD (#9002313.1301)
;
Q:$O(FDATA(TRANSACT,552,0))=""
;
N FDAT1301,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.1301",ROOT="FDAT1301(9002313.1301)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,552,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
.F FLDNUM=552,553,554,555,556 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
D UPDATE^DIE("S","FDAT1301(9002313.1301)")
;
Q
PROCCOB ; OTHER PAYER ID MLTPL SUB-FIELD (#9002313.035501)
;
Q:$O(FDATA(TRANSACT,338,0))=""
;
N FDAT35501,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.035501",ROOT="FDAT35501(9002313.035501)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,338,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
.F FLDNUM=127,142,143,144,145,338,339,340,356,991,992,2023 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
D UPDATE^DIE("S","FDAT35501(9002313.035501)")
;
Q
;
PROCINT ; INTERMEDIARY REPEATING SUB-FIELD (#9002313.032052)
;
Q:$O(FDATA(TRANSACT,2053,0))=""
;
N FDAT032052,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.032052",ROOT="FDAT032052(9002313.032052)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,2053,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
.F FLDNUM=2053,2054,2051 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
D UPDATE^DIE("S","FDAT032052(9002313.032052)")
Q
;
PROCQLIM ; QUANTITY LIMIT PER SPECIFIC TIME PERIOD REPEATING SUB-FIELD (# 9002313.032087)
;
I '$G(FDATA(TRANSACT,2087)) Q ; if the counter field isn't there, then get out
;
N FDAT032087,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.032087",ROOT="FDAT032087(9002313.032087)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,2088,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
.F FLDNUM=2088,2089 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
D UPDATE^DIE("S","FDAT032087(9002313.032087)")
Q
;
PROCDSLM ; DAYS SUPPLY LIMIT PER SPECIFIC TIME PERIOD REPEATING SUB-FIELD (# 9002313.032091)
;
I '$G(FDATA(TRANSACT,2090)) Q ; if the counter field isn't there, then get out
;
N FDAT032091,FILE,FLDNUM,NNDX,ROOT
;
S FILE="9002313.032091",ROOT="FDAT032091(9002313.032091)",NNDX=""
F S NNDX=$O(FDATA(TRANSACT,2091,NNDX)) Q:NNDX="" D
.S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
.F FLDNUM=2091,2092 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
D UPDATE^DIE("S","FDAT032091(9002313.032091)")
Q
;
RAW(RESPIEN,RREC) ; store raw data received from the payer
; pass in the response IEN (9002313.03) and the raw data to be stored.
N X,CNT
K ^TMP($J,"WP")
S CNT=0 F X=1:79:$L(RREC) S CNT=CNT+1 S ^TMP($J,"WP",CNT,0)=$E(RREC,X,X+78)
D WP^DIE(9002313.03,RESPIEN_",",9999,"K","^TMP($J,""WP"")")
K ^TMP($J,"WP")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSECMPS 13524 printed Dec 13, 2024@01:50:52 Page 2
BPSECMPS ;BHAM ISC/FCS/DRS - Parse Claim Response ;3/10/08 12:31
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,6,7,10,11,15,19,20**;JUN 2004;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; References to UPDATE^DIE and WP^DIE supported by DBIA 2053
+5 ; Reference to FDA^DILF supported by DBIA 2054
+6 ;
PARSE(RREC,CLAIMIEN,IEN59,TRANTYPE) ;
+1 ; Parse the response from the payer and file it in the BPS Response record
+2 ; Incoming Parameters:
+3 ; RREC - HL7 message
+4 ; CLAIMIEN - IEN of the BPS Claim file
+5 ; IEN59 - IEN of the BPS Transaction file
+6 ; TRANTYPE - Transaction Type (B1-Billing Request, B2-Reversal, E1-Eligibility)
+7 ; Return value:
+8 ; RESPIEN - IEN of the BPS Response file
+9 ;
+10 NEW FDAIEN,FDAIEN03,FDATA,FILE,FS,GS,ROOT,SS,TRANSACT,TRANSCNT
+11 ;
+12 ; RREC and CLAIMIEN are required
+13 if $GET(RREC)=""
QUIT 0
+14 if $GET(CLAIMIEN)=""
QUIT 0
+15 ;
+16 ;group and field separator characters
+17 SET GS="\X1D\"
SET FS="\X1C\"
SET SS="\X1E\"
+18 SET FILE="9002313.03"
SET ROOT="FDATA(9002313.03)"
+19 ; process transmission level data, transaction count in TRANSCNT (from PARSEH)
DO TRANSMSN
+20 ; process transaction level data
DO TRANSACT
+21 ;
+22 ; If test system and test active, call the override routine
+23 ; IEN59 and TRANTYPE are set in BPSECMC2
+24 IF $$CHECK^BPSTEST
DO SETOVER^BPSTEST(+$GET(IEN59),$GET(TRANTYPE),.FDATA)
+25 ;
+26 DO UPDATE^DIE("S","FDATA(9002313.03)","FDAIEN")
+27 FOR TRANSACT=1:1:TRANSCNT
Begin DoDot:1
+28 DO PROCRESP
+29 DO PROCREJ
+30 DO PROCAPP
+31 DO PROCPPR
+32 DO PROCCOB
+33 DO PROCOTH^BPSECMP2
+34 DO PROCBEN^BPSECMP2
+35 DO PROCADM^BPSECMP2
+36 DO PROCDUR^BPSECMP2
+37 DO PROCINT
+38 ; process Quantity limit time period multiple
DO PROCQLIM
+39 ; process Days Supply limit time period multiple
DO PROCDSLM
+40 QUIT
End DoDot:1
+41 ;
+42 SET RESPIEN=FDAIEN(1)
+43 ; This should be called for each transaction but the IBSEND is not
+44 ; setup correctly so currently it is only called for each claim/response
+45 ; If we ever bundle claims, we will need to fix IBSEND and move this code
+46 ; to the FOR loop above.
+47 DO IBSEND^BPSECMP2(CLAIMIEN,RESPIEN,"","")
+48 DO RAW(RESPIEN,RREC)
+49 ;
+50 QUIT RESPIEN
+51 ;
TRANSMSN ;This subroutine will work through the transmission level information
+1 ;
+2 NEW RHEADER,RTRANM,SEG,SEGID,SEGMENT
+3 ;
+4 ;Parse response transmission level from ascii record
+5 SET RTRANM=$PIECE(RREC,GS,1)
+6 ;
+7 ; get just the header segment
+8 ;header- required/fixed length
SET RHEADER=$PIECE(RTRANM,SS,1)
+9 DO PARSEH
+10 ;
+11 ; There are 2 optional segments on the transmission level - message
+12 ; and insurance. We'll check for both and parse what we find.
+13 FOR SEG=2:1:3
Begin DoDot:1
+14 SET SEGMENT=$PIECE(RTRANM,SS,SEG)
+15 if SEGMENT=""
QUIT
+16 SET SEGID=$PIECE(SEGMENT,FS,2)
+17 ; segment identification
IF $EXTRACT(SEGID,1,2)="AM"
Begin DoDot:2
+18 SET SEGFID=$EXTRACT(SEGID,3,4)
+19 if (SEGFID=20)!(SEGFID=25)
DO PARSETM
End DoDot:2
End DoDot:1
+20 ;
+21 QUIT
+22 ;
TRANSACT ;This subroutine will work through the transaction level information
+1 ;
+2 NEW GRP,MEDN,RTRAN,SEG,SEGMENT
+3 SET MEDN=0
+4 ;
+5 FOR GRP=2:1
Begin DoDot:1
+6 ;get the next transaction (could be 4)
SET RTRAN=$PIECE(RREC,GS,GRP)
+7 ;we're done if it's empty
if RTRAN=""
QUIT
+8 ;transaction counter
SET MEDN=MEDN+1
+9 ;
+10 ;break the record down by segments
FOR SEG=2:1
Begin DoDot:2
+11 ;get the segment
SET SEGMENT=$PIECE(RTRAN,SS,SEG)
+12 if SEGMENT=""
QUIT
+13 ;get the fields
DO PARSETN
End DoDot:2
if SEGMENT=""
QUIT
End DoDot:1
if RTRAN=""
QUIT
+14 QUIT
+15 ;
PARSEH ; parse the header record, required on all responses, and is fixed length
+1 ; It's the only record that is fixed length.
+2 ;
+3 ; CLAIM ID
DO FDA^DILF(FILE,"+1",.01,"",CLAIMIEN,ROOT)
+4 ; DATE RESPONSE RECEIVED
DO FDA^DILF(FILE,"+1",.02,"",$$NOWFM^BPSOSU1,ROOT)
+5 ; VERSION RELEASE NUMBER
DO FDA^DILF(FILE,"+1",102,"",$EXTRACT(RHEADER,33,34),ROOT)
+6 ; TRANSACTION CODE
DO FDA^DILF(FILE,"+1",103,"",$EXTRACT(RHEADER,35,36),ROOT)
+7 ; TRANSACTION COUNT
DO FDA^DILF(FILE,"+1",109,"",$EXTRACT(RHEADER,37,37),ROOT)
+8 SET TRANSCNT=$EXTRACT(RHEADER,37,37)
+9 ; response status header
DO FDA^DILF(FILE,"+1",501,"",$EXTRACT(RHEADER,38,38),ROOT)
+10 ; SERVICE PROVIDER ID Qualifier
DO FDA^DILF(FILE,"+1",202,"",$EXTRACT(RHEADER,39,40),ROOT)
+11 ; SERVICE PROVIDER ID
DO FDA^DILF(FILE,"+1",201,"",$EXTRACT(RHEADER,41,55),ROOT)
+12 ; DATE OF SERVICE
DO FDA^DILF(FILE,"+1",401,"",$EXTRACT(RHEADER,56,63),ROOT)
+13 ;
+14 QUIT
+15 ;
PARSETM ; parse the variable portions of the transmission
+1 ;
+2 NEW FIELD,FLDNUM,PC
+3 ;
+4 ;skip the seg id -already know its value
FOR PC=3:1
Begin DoDot:1
+5 ;piece through the record
SET FIELD=$PIECE(SEGMENT,FS,PC)
+6 ;stop - we hit the end
if FIELD=""
QUIT
+7 ;get the field number used for storage
SET FLDNUM=$$GETNUM(FIELD)
+8 ;shouldn't happen - but let's skip
if FLDNUM=""
QUIT
+9 SET FIELD=$EXTRACT(FIELD,3,999)
+10 DO FDA^DILF(FILE,"+1",FLDNUM,"",FIELD,ROOT)
End DoDot:1
if FIELD=""
QUIT
+11 QUIT
+12 ;
PARSETN ; parse the transaction level segments
+1 ;
+2 ; Possible values of the SEGFID field:
+3 ; 21 = Response Status Segment
+4 ; 22 = Response Claim Segment
+5 ; 23 = Response Pricing Segment
+6 ; 24 = Response DUR/PPS Segment
+7 ; 26 = Response Prior Authorization Segment
+8 ; 28 = Response Coordination of Benefits/Other Payers Segment
+9 ; 36 = Response Intermediary Segment
+10 ;
+11 NEW CKRPT,FIELD,FLDNUM,PC,REPEAT,RPTFLD,SEGFID,SEGID,GRPCNT,GRPFLDS,VNUM
+12 ;
+13 SET RPTFLD=""
+14 ; this should be the segment id
SET SEGID=$PIECE(SEGMENT,FS,2)
+15 ; don't process without a Seg id
if SEGID=""
QUIT
+16 ; don't know what we have - skip
if $EXTRACT(SEGID,1,2)'="AM"
QUIT
+17 ;
+18 ; this should be the field ID
SET SEGFID=$EXTRACT(SEGID,3,4)
+19 SET GRPCNT=0
SET GRPFLDS=""
+20 ;
+21 ; setup the repeating flds based on the segment
+22 ;status segment
IF SEGFID=21
Begin DoDot:1
+23 SET RPTFLD=",548,511,546,132,526,131,"
+24 SET GRPCNT=0
+25 SET GRPFLDS=",511,548,132,"
End DoDot:1
+26 ;
+27 ;claim segment
IF SEGFID=22
Begin DoDot:1
+28 SET RPTFLD=",552,553,554,555,556,B88,B89,B91,B92,"
+29 SET GRPCNT=0
+30 SET GRPFLDS=",552,B88,B91,"
End DoDot:1
+31 ;
+32 ;pricing segment
IF SEGFID=23
Begin DoDot:1
+33 SET RPTFLD=",564,565,393,394,"
+34 SET GRPCNT=0
+35 SET GRPFLDS=",564,393,"
End DoDot:1
+36 ;
+37 ;DUR/PPS segment
IF SEGFID=24
Begin DoDot:1
+38 SET RPTFLD=",439,528,529,530,531,532,533,544,567,570,"
+39 SET GRPCNT=0
+40 SET GRPFLDS=",567,"
End DoDot:1
+41 ;
+42 ;COB/Other Payers segment
IF SEGFID=28
Begin DoDot:1
+43 SET RPTFLD=",127,142,143,144,145,338,339,340,356,991,992,B23,"
+44 SET GRPCNT=0
+45 SET GRPFLDS=",338,"
End DoDot:1
+46 ;
+47 ;Intermediary segment
IF SEGFID=36
Begin DoDot:1
+48 SET RPTFLD=",B53,B54,B51,"
+49 SET GRPCNT=0
+50 SET GRPFLDS=",B53,"
End DoDot:1
+51 ;
+52 ; now let's parse out the fields
+53 ;
+54 ;skip the seg id -jump to the other flds
FOR PC=3:1
Begin DoDot:1
+55 ;piece through the record
SET FIELD=$PIECE(SEGMENT,FS,PC)
+56 ;stop - we hit the end
if FIELD=""
QUIT
+57 ;get the field number used for storage
SET FLDNUM=$$GETNUM(FIELD)
+58 ;shouldn't happen - but let's skip
if FLDNUM=""
QUIT
+59 SET VNUM=FLDNUM
+60 ;Convert to VistA field number for non-numeric NCPDP numbers - BPS*1*15
+61 IF $PIECE(FLDNUM,".")'?3N
SET VNUM=$$VNUM(FLDNUM)
if 'VNUM
QUIT
+62 ;for this segment, let's figure
SET REPEAT=0
+63 ;out if the field is a repeating
SET CKRPT=","_FLDNUM_","
+64 ;field
if RPTFLD[CKRPT
SET REPEAT=1
+65 ; Increment the group counter if first field of group.
+66 if GRPFLDS[CKRPT
SET GRPCNT=GRPCNT+1
+67 ; if rptg, store with a group counter
+68 if REPEAT
SET FDATA(MEDN,VNUM,GRPCNT)=$EXTRACT(FIELD,3,$LENGTH(FIELD))
+69 ; not rptg, store without counter
+70 if 'REPEAT
SET FDATA(MEDN,VNUM)=$EXTRACT(FIELD,3,$LENGTH(FIELD))
End DoDot:1
if FIELD=""
QUIT
+71 ;
+72 QUIT
+73 ;
GETNUM(FIELD) ; function, return field number for a field I
+1 ; use BPS NCPDP FIELD DEFS (#9002313.91) "D" cross ref for lookup
+2 ; field number is used to store the data in the correct field in BPS RESPONSES (#9002313.03)
+3 ;
+4 NEW FLDID,FLDIEN,FLDNUM
+5 SET FLDID=$EXTRACT(FIELD,1,2)
SET FLDNUM=""
+6 ; FLDID = field identifier
if FLDID=""
QUIT FLDNUM
+7 ;
+8 ; ien for fld #
SET FLDIEN=$ORDER(^BPSF(9002313.91,"D",FLDID,0))
+9 ;fld number
if FLDIEN
SET FLDNUM=$PIECE($GET(^BPSF(9002313.91,FLDIEN,0)),U)
+10 QUIT FLDNUM
+11 ;
VNUM(FLDNUM) ;function, returns VistA FileMan field number
+1 NEW FLDIEN
+2 SET FLDIEN=$ORDER(^BPSF(9002313.91,"B",FLDNUM,0))
if 'FLDIEN
QUIT ""
+3 ;fld number
SET FLDNUM=$PIECE($GET(^BPSF(9002313.91,FLDIEN,5)),U,3)
+4 QUIT FLDNUM
+5 ;
PROCRESP ; add data to RESPONSES SUB-FIELD (#9002313.0301)
+1 ;
+2 NEW FDATA03,FIELD,FILE,FLDNUM,ROOT
+3 ;
+4 SET FILE=9002313.0301
SET ROOT="FDATA03(9002313.0301)"
+5 ; field 501 is HEADER RESPONSE STATUS, 112 is TRANSACTION RESPONSE STATUS
+6 IF '$DATA(FDATA(TRANSACT,501))
SET FDATA(TRANSACT,501)=FDATA(TRANSACT,112)
+7 IF '$DATA(FDATA(TRANSACT,112))
SET FDATA(TRANSACT,112)=FDATA(TRANSACT,501)
+8 ;
+9 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+1,"_FDAIEN(TRANSACT),FLDNUM,"",TRANSACT,ROOT)
+10 SET FIELD=""
+11 ;set all the non-repeating fields for 9002313.0301
FOR
SET FIELD=$ORDER(FDATA(TRANSACT,FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+12 ; no data to process
if $GET(FDATA(TRANSACT,FIELD))=""
QUIT
+13 ; field 402 is PRESCRIPTION/SERVICE REF. NO.
+14 ;REMOVE EXTRANEOUS "\"
IF FIELD=402
SET FDATA(TRANSACT,FIELD)=$TRANSLATE(FDATA(TRANSACT,FIELD),"\","")
+15 DO FDA^DILF(FILE,"+"_TRANSACT_","_FDAIEN(TRANSACT),FIELD,"",FDATA(TRANSACT,FIELD),ROOT)
End DoDot:1
+16 ;
+17 DO UPDATE^DIE("S","FDATA03(9002313.0301)","FDAIEN03")
+18 ;
+19 QUIT
+20 ;
PROCREJ ; add data to REJECT CODE SUB-FIELD (#9002313.03511)
+1 if $GET(FDATA(TRANSACT,510))=""
QUIT
+2 ;
+3 NEW FDAT3511,FILE,FLDNUM,NNDX,NUMREJS,ROOT,REJCODE
+4 ;
+5 SET FILE="9002313.03511"
SET ROOT="FDAT3511(9002313.03511)"
SET NUMREJS=FDATA(TRANSACT,510)
SET NNDX=""
+6 ;set all the non-repeating fields for 9002313.03511 rejections
FOR
SET NNDX=$ORDER(FDATA(TRANSACT,511,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+7 SET REJCODE=$$TRIM^XLFSTR(FDATA(TRANSACT,511,NNDX),"R")
+8 SET REJCODE=$TRANSLATE(REJCODE,"\","")
if REJCODE']""
QUIT
+9 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",REJCODE,ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT3511(9002313.03511)")
+11 ;
+12 QUIT
+13 ;
PROCAPP ; APPROVED MESSAGE CODE SUB-FIELD (#9002313.301548)
+1 if $ORDER(FDATA(TRANSACT,548,0))=""
QUIT
+2 ;
+3 NEW FDAT1548,FILE,FLDNUM,NNDX,ROOT
+4 ;
+5 SET FILE="9002313.301548"
SET ROOT="FDAT1548(9002313.301548)"
SET NNDX=""
+6 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,548,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+7 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",FDATA(TRANSACT,548,NNDX),ROOT)
End DoDot:1
+8 DO UPDATE^DIE("S","FDAT1548(9002313.301548)")
+9 ;
+10 QUIT
+11 ;
PROCPPR ; PREFERRED PRODUCT REPEATING SUB-FIELD (#9002313.1301)
+1 ;
+2 if $ORDER(FDATA(TRANSACT,552,0))=""
QUIT
+3 ;
+4 NEW FDAT1301,FILE,FLDNUM,NNDX,ROOT
+5 ;
+6 SET FILE="9002313.1301"
SET ROOT="FDAT1301(9002313.1301)"
SET NNDX=""
+7 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,552,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+8 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
+9 FOR FLDNUM=552,553,554,555,556
IF $DATA(FDATA(TRANSACT,FLDNUM,NNDX))
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$GET(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT1301(9002313.1301)")
+11 ;
+12 QUIT
PROCCOB ; OTHER PAYER ID MLTPL SUB-FIELD (#9002313.035501)
+1 ;
+2 if $ORDER(FDATA(TRANSACT,338,0))=""
QUIT
+3 ;
+4 NEW FDAT35501,FILE,FLDNUM,NNDX,ROOT
+5 ;
+6 SET FILE="9002313.035501"
SET ROOT="FDAT35501(9002313.035501)"
SET NNDX=""
+7 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,338,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+8 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
+9 FOR FLDNUM=127,142,143,144,145,338,339,340,356,991,992,2023
IF $DATA(FDATA(TRANSACT,FLDNUM,NNDX))
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$GET(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT35501(9002313.035501)")
+11 ;
+12 QUIT
+13 ;
PROCINT ; INTERMEDIARY REPEATING SUB-FIELD (#9002313.032052)
+1 ;
+2 if $ORDER(FDATA(TRANSACT,2053,0))=""
QUIT
+3 ;
+4 NEW FDAT032052,FILE,FLDNUM,NNDX,ROOT
+5 ;
+6 SET FILE="9002313.032052"
SET ROOT="FDAT032052(9002313.032052)"
SET NNDX=""
+7 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,2053,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+8 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
+9 FOR FLDNUM=2053,2054,2051
IF $DATA(FDATA(TRANSACT,FLDNUM,NNDX))
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$GET(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT032052(9002313.032052)")
+11 QUIT
+12 ;
PROCQLIM ; QUANTITY LIMIT PER SPECIFIC TIME PERIOD REPEATING SUB-FIELD (# 9002313.032087)
+1 ;
+2 ; if the counter field isn't there, then get out
IF '$GET(FDATA(TRANSACT,2087))
QUIT
+3 ;
+4 NEW FDAT032087,FILE,FLDNUM,NNDX,ROOT
+5 ;
+6 SET FILE="9002313.032087"
SET ROOT="FDAT032087(9002313.032087)"
SET NNDX=""
+7 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,2088,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+8 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
+9 FOR FLDNUM=2088,2089
IF $DATA(FDATA(TRANSACT,FLDNUM,NNDX))
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$GET(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT032087(9002313.032087)")
+11 QUIT
+12 ;
PROCDSLM ; DAYS SUPPLY LIMIT PER SPECIFIC TIME PERIOD REPEATING SUB-FIELD (# 9002313.032091)
+1 ;
+2 ; if the counter field isn't there, then get out
IF '$GET(FDATA(TRANSACT,2090))
QUIT
+3 ;
+4 NEW FDAT032091,FILE,FLDNUM,NNDX,ROOT
+5 ;
+6 SET FILE="9002313.032091"
SET ROOT="FDAT032091(9002313.032091)"
SET NNDX=""
+7 FOR
SET NNDX=$ORDER(FDATA(TRANSACT,2091,NNDX))
if NNDX=""
QUIT
Begin DoDot:1
+8 SET FLDNUM=".01"
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT)
+9 FOR FLDNUM=2091,2092
IF $DATA(FDATA(TRANSACT,FLDNUM,NNDX))
DO FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$GET(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT)
End DoDot:1
+10 DO UPDATE^DIE("S","FDAT032091(9002313.032091)")
+11 QUIT
+12 ;
RAW(RESPIEN,RREC) ; store raw data received from the payer
+1 ; pass in the response IEN (9002313.03) and the raw data to be stored.
+2 NEW X,CNT
+3 KILL ^TMP($JOB,"WP")
+4 SET CNT=0
FOR X=1:79:$LENGTH(RREC)
SET CNT=CNT+1
SET ^TMP($JOB,"WP",CNT,0)=$EXTRACT(RREC,X,X+78)
+5 DO WP^DIE(9002313.03,RESPIEN_",",9999,"K","^TMP($J,""WP"")")
+6 KILL ^TMP($JOB,"WP")
+7 QUIT
+8 ;
