BPSOSCF ;BHAM ISC/FCS/DRS/DLF - Low-level format of .02 ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,15,19,23,28**;JUN 2004;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;
; 100 (Transaction Header Segment)
; 110 (Patient Segment)
; 120 (Insurance Segment)
; 130 (Claim Segment)
; 140 (Pharmacy Provider Segment)
; 150 (Prescriber Segment)
; 160 (COB/Other Payments Segment)
; 170 (Worker's Compensation Segment)
; 180 (DUR/PPS Segment)
; 190 (Pricing Segment)
; 200 (Coupon Segment)
; 210 (Compound Segment)
; 220 (Prior Authorization Segment)
; 230 (Clinical Segment)
; 240 (Additional Documentation Segment)
; 250 (Facility Segment)
; 260 (Narrative Segment)
; 270 (Purchaser Segment)
; 280 (Service Provider Segment)
; 290 (Intermediary Segment)
; 300 (Last Known 4Rx Segment)
;
; FORMAT = IEN in BPS NCPDP FORMATS (#9002313.92)
; NODE = Segment Node
; MEDN = Transaction multiple in BPS Claims
XLOOP(FORMAT,NODE,MEDN) ; format claim record
;
Q:$G(FORMAT)="" Q:$G(NODE)="" ; FORMAT, NODE required
;
N FLAG,FLDIEN,FLDINFO,IEN511,IEN59,MDATA,NCPVERS,NODEIEN,ORDER,OVERRIDE,PMODE,RECMIEN,BPSX
; quit If the payer sheet doesn't have the segment
I '$D(^BPSF(9002313.92,FORMAT,NODE,0)) Q
;
; VA doesn't do these segments
I ",300,290,280,270,260,250,240,230,220,210,200,170,140,"[(","_NODE_",") Q
;
; Per NCPDP standard, eligibility doesn't support segments listed below
I BPS("Transaction Code")="E1",",290,280,270,260,250,230,220,210,200,190,180,170,160,130,"[(","_NODE_",") Q
;
; For COB, if the payer sequence is primary, then quit and don't output the COB fields
I NODE=160,$$COB59^BPSUTIL2(+$G(BPS("RX",BPS(9002313.0201),"IEN59")))=1 Q
;
; COB processing is handled differently
I NODE=160 D COB^BPSOSHF(FORMAT,NODE,MEDN) Q
;
; DUR is handled differently since it is repeating
I NODE=180 D DURPPS^BPSOSHF(FORMAT,NODE,MEDN) Q
;
; Loop through the fields in the segment
S ORDER=0
F S ORDER=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER)) Q:'ORDER D
. ; Get the pointer to the BPS NCPDP FIELD DEFS table
. S RECMIEN=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0))
. I 'RECMIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$T(+0)) Q
. S MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0),FLDIEN=$P(MDATA,U,2)
.; Corrupt or erroneous format file
. I 'FLDIEN Q
. S FLDINFO=$G(^BPSF(9002313.91,FLDIEN,0)) ; BPS NCPDP FIELD DEFS (#9002313.91)
. I FLDINFO="" D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XLOOP",$T(+0)) Q
.; Quit for 111-AM Segment Identification
.; 478-H7 Other Amount Claimed Submitted Count
.; 479-H8 Other Amount Claimed Submitted Qualifier
.; 478 and 479 are handled by 480 and 111 is standard field for each segment
. S BPSX=$P(FLDINFO,U) I ",111,478,479,"[(","_BPSX_",") Q
.;
.; Set override value (may not be defined so override will be null)
. I $D(MEDN) S OVERRIDE=$G(BPS("OVERRIDE","RX",MEDN,FLDIEN))
. E S OVERRIDE=$G(BPS("OVERRIDE",FLDIEN))
.;
.; Get processing mode (S-Standard (default), X-Special Code)
. S PMODE=$P(MDATA,U,3)
. I PMODE="" S PMODE="S" ;default it
.;
.; Default FLAG and value being computed
. S FLAG="GFS"
. S BPS("X")=""
. ;
. ; If there is an override, set BPS("X") to it and
. ; only do Format and Set code
. I OVERRIDE]"" S FLAG="FS",BPS("X")=OVERRIDE
. ;
. ; If Special Code mode is set, execute special code instead
. ; of field's Get code and change Flag to FS so Format and
. ; Set code is still done but not GET code
. I PMODE="X",OVERRIDE="" D
.. S FLAG="FS"
.. D XSPCCODE(FORMAT,NODE,RECMIEN)
. ;
. ; Call XFLDCODE to do processing based on FLAG setting
. D XFLDCODE(NODE,FLDIEN,FLAG)
;
; If the current segment is 130/Claim, populate field 460-ET
; QUANTITY PRESCRIBED if it's not already populated.
;
I NODE=130 D
. I $$GET1^DIQ(9002313.0201,BPS(9002313.0201)_","_BPS(9002313.02),460,"I")'="" Q
. S FLDIEN=$O(^BPSF(9002313.91,"B",460,""))
. I FLDIEN="" Q
. D XFLDCODE(NODE,FLDIEN,"GFS")
. Q
;
; The user has the ability, via the action RED / Resubmit with
; Edits, to add to the claim fields not on the payer sheet.
; Any fields to be added to the claim are stored in the file
; BPS NCPDP OVERRIDE.
;
; Determine the transaction from the claim. Determine
; override, and Quit if none. Field 1.13 is NCPDP OVERRIDES,
; ptr to 9002313.511.
;
S IEN59=$$CLAIM59^BPSUTIL2(BPS(9002313.02))
S IEN511=$$GET1^DIQ(9002313.59,IEN59,1.13,"I")
I 'IEN511 Q
;
; Loop through additional fields for the current segment (NODE) and
; call XFLDCODE to add to the claim.
;
S NODEIEN=$O(^BPSF(9002313.9,"C",NODE,""))
I 'NODEIEN Q
S BPSX=""
F S BPSX=$O(^BPS(9002313.511,IEN511,2,"SEG",NODEIEN,BPSX)) Q:BPSX="" D
. S FLDIEN=$$GET1^DIQ(9002313.5112,BPSX_","_IEN511_",",.01,"I")
. S BPS("X")=""
. D XFLDCODE(NODE,FLDIEN,"GFS")
;
Q
;
;
; Execute Get, Format and/or Set MUMPS code for NCPDP Field
;
; Parameters: NODE - Segment Node
; FLDIEN - NCPDP Field Definitions IEN
; FLAG - If variable contains:
; "G" - Execute Get Code
; "F" - Execute Format Code
; "S" - Execute S Code
;
; When called by the DURPPS^BPSOSHF, DUR is also set and used
; by the SET logic for the DUR fields. This variable is newed
; by the calling routine
XFLDCODE(NODE,FLDIEN,FLAG) ;EP
; 5.1 loops through the 10, 25, 30 nodes
;
N FNODE,INDEX,MCODE,NCPVERS,X
;
; Check if record exists and FLAG variable is set correctly
; Changed from Q: to give fatal error - 10/18/2000
I 'FLDIEN D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XFLDCODE",$T(+0)) Q
I FLAG="" D IMPOSS^BPSOSUE("DB,P","TI","FLAG null",,"XFLDCODE",$T(+0)) Q
; get NCPDP version, default to vD.0
S NCPVERS=$G(BPS("NCPDP","Version")) S:NCPVERS="" NCPVERS="D0"
; Loop through GET CODE, D0 FORMAT (or FORMAT), SET CODE w-p fields and execute code
F FNODE=10,20,25,30 D
.I FNODE=25,NCPVERS="D0" Q ; node 25 is FORMAT CODE for versions before D.0
.I FNODE=20,NCPVERS'="D0" Q ; node 20 is FORMAT CODE for vD.0
.I FLAG'[$S(FNODE=10:"G",FNODE=25!(FNODE=20):"F",FNODE=30:"S",1:"") Q
.I '$D(^BPSF(9002313.91,FLDIEN,FNODE,0)) D IMPOSS^BPSOSUE("DB","TI","FLDIEN="_FLDIEN,"FNODE="_FNODE,"XFLDCODE",$T(+0))
.; Loop through the W-P field and execute each line
.S INDEX=0
.F S INDEX=$O(^BPSF(9002313.91,FLDIEN,FNODE,INDEX)) Q:'INDEX D
..; If doing SET code and if this is not the header segment, add the ID prefix
..I FNODE=30,NODE'=100 S BPS("X")=$P($G(^BPSF(9002313.91,FLDIEN,5)),U,1)_BPS("X")
..; Get the code and xecute
..S MCODE=$G(^BPSF(9002313.91,FLDIEN,FNODE,INDEX,0))
..Q:MCODE="" Q:$E(MCODE,1)=";" ; no M code or comment
..X MCODE
;
Q
;
;
; Execute Special Code (for NCPDP Field within NCPDP Record)
; FORMAT = NCPDP Record Format IEN (9002313.92)
; NODE = Global node value (100,110,120,130,140)
; RECMIEN = Field Multiple IEN
XSPCCODE(FORMAT,NODE,RECMIEN) ;EP - Above and BPSOSHR
; BPS NCPDP FORMATS (#9002313.92)
I '$D(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","no special code there to XECUTE","FORMAT="_FORMAT,"XSPCCODE",$T(+0)) Q
N INDEX,MCODE
S INDEX=0
F S INDEX=$O(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX)) Q:'INDEX D
. S MCODE=$G(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX,0))
. Q:MCODE=""
. Q:$E(MCODE,1)=";"
. X MCODE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSCF 7625 printed Oct 16, 2024@17:52:28 Page 2
BPSOSCF ;BHAM ISC/FCS/DRS/DLF - Low-level format of .02 ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,15,19,23,28**;JUN 2004;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; 100 (Transaction Header Segment)
+5 ; 110 (Patient Segment)
+6 ; 120 (Insurance Segment)
+7 ; 130 (Claim Segment)
+8 ; 140 (Pharmacy Provider Segment)
+9 ; 150 (Prescriber Segment)
+10 ; 160 (COB/Other Payments Segment)
+11 ; 170 (Worker's Compensation Segment)
+12 ; 180 (DUR/PPS Segment)
+13 ; 190 (Pricing Segment)
+14 ; 200 (Coupon Segment)
+15 ; 210 (Compound Segment)
+16 ; 220 (Prior Authorization Segment)
+17 ; 230 (Clinical Segment)
+18 ; 240 (Additional Documentation Segment)
+19 ; 250 (Facility Segment)
+20 ; 260 (Narrative Segment)
+21 ; 270 (Purchaser Segment)
+22 ; 280 (Service Provider Segment)
+23 ; 290 (Intermediary Segment)
+24 ; 300 (Last Known 4Rx Segment)
+25 ;
+26 ; FORMAT = IEN in BPS NCPDP FORMATS (#9002313.92)
+27 ; NODE = Segment Node
+28 ; MEDN = Transaction multiple in BPS Claims
XLOOP(FORMAT,NODE,MEDN) ; format claim record
+1 ;
+2 ; FORMAT, NODE required
if $GET(FORMAT)=""
QUIT
if $GET(NODE)=""
QUIT
+3 ;
+4 NEW FLAG,FLDIEN,FLDINFO,IEN511,IEN59,MDATA,NCPVERS,NODEIEN,ORDER,OVERRIDE,PMODE,RECMIEN,BPSX
+5 ; quit If the payer sheet doesn't have the segment
+6 IF '$DATA(^BPSF(9002313.92,FORMAT,NODE,0))
QUIT
+7 ;
+8 ; VA doesn't do these segments
+9 IF ",300,290,280,270,260,250,240,230,220,210,200,170,140,"[(","_NODE_",")
QUIT
+10 ;
+11 ; Per NCPDP standard, eligibility doesn't support segments listed below
+12 IF BPS("Transaction Code")="E1"
IF ",290,280,270,260,250,230,220,210,200,190,180,170,160,130,"[(","_NODE_",")
QUIT
+13 ;
+14 ; For COB, if the payer sequence is primary, then quit and don't output the COB fields
+15 IF NODE=160
IF $$COB59^BPSUTIL2(+$GET(BPS("RX",BPS(9002313.0201),"IEN59")))=1
QUIT
+16 ;
+17 ; COB processing is handled differently
+18 IF NODE=160
DO COB^BPSOSHF(FORMAT,NODE,MEDN)
QUIT
+19 ;
+20 ; DUR is handled differently since it is repeating
+21 IF NODE=180
DO DURPPS^BPSOSHF(FORMAT,NODE,MEDN)
QUIT
+22 ;
+23 ; Loop through the fields in the segment
+24 SET ORDER=0
+25 FOR
SET ORDER=$ORDER(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER))
if 'ORDER
QUIT
Begin DoDot:1
+26 ; Get the pointer to the BPS NCPDP FIELD DEFS table
+27 SET RECMIEN=$ORDER(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0))
+28 IF 'RECMIEN
DO IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$TEXT(+0))
QUIT
+29 SET MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0)
SET FLDIEN=$PIECE(MDATA,U,2)
+30 ; Corrupt or erroneous format file
+31 IF 'FLDIEN
QUIT
+32 ; BPS NCPDP FIELD DEFS (#9002313.91)
SET FLDINFO=$GET(^BPSF(9002313.91,FLDIEN,0))
+33 IF FLDINFO=""
DO IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XLOOP",$TEXT(+0))
QUIT
+34 ; Quit for 111-AM Segment Identification
+35 ; 478-H7 Other Amount Claimed Submitted Count
+36 ; 479-H8 Other Amount Claimed Submitted Qualifier
+37 ; 478 and 479 are handled by 480 and 111 is standard field for each segment
+38 SET BPSX=$PIECE(FLDINFO,U)
IF ",111,478,479,"[(","_BPSX_",")
QUIT
+39 ;
+40 ; Set override value (may not be defined so override will be null)
+41 IF $DATA(MEDN)
SET OVERRIDE=$GET(BPS("OVERRIDE","RX",MEDN,FLDIEN))
+42 IF '$TEST
SET OVERRIDE=$GET(BPS("OVERRIDE",FLDIEN))
+43 ;
+44 ; Get processing mode (S-Standard (default), X-Special Code)
+45 SET PMODE=$PIECE(MDATA,U,3)
+46 ;default it
IF PMODE=""
SET PMODE="S"
+47 ;
+48 ; Default FLAG and value being computed
+49 SET FLAG="GFS"
+50 SET BPS("X")=""
+51 ;
+52 ; If there is an override, set BPS("X") to it and
+53 ; only do Format and Set code
+54 IF OVERRIDE]""
SET FLAG="FS"
SET BPS("X")=OVERRIDE
+55 ;
+56 ; If Special Code mode is set, execute special code instead
+57 ; of field's Get code and change Flag to FS so Format and
+58 ; Set code is still done but not GET code
+59 IF PMODE="X"
IF OVERRIDE=""
Begin DoDot:2
+60 SET FLAG="FS"
+61 DO XSPCCODE(FORMAT,NODE,RECMIEN)
End DoDot:2
+62 ;
+63 ; Call XFLDCODE to do processing based on FLAG setting
+64 DO XFLDCODE(NODE,FLDIEN,FLAG)
End DoDot:1
+65 ;
+66 ; If the current segment is 130/Claim, populate field 460-ET
+67 ; QUANTITY PRESCRIBED if it's not already populated.
+68 ;
+69 IF NODE=130
Begin DoDot:1
+70 IF $$GET1^DIQ(9002313.0201,BPS(9002313.0201)_","_BPS(9002313.02),460,"I")'=""
QUIT
+71 SET FLDIEN=$ORDER(^BPSF(9002313.91,"B",460,""))
+72 IF FLDIEN=""
QUIT
+73 DO XFLDCODE(NODE,FLDIEN,"GFS")
+74 QUIT
End DoDot:1
+75 ;
+76 ; The user has the ability, via the action RED / Resubmit with
+77 ; Edits, to add to the claim fields not on the payer sheet.
+78 ; Any fields to be added to the claim are stored in the file
+79 ; BPS NCPDP OVERRIDE.
+80 ;
+81 ; Determine the transaction from the claim. Determine
+82 ; override, and Quit if none. Field 1.13 is NCPDP OVERRIDES,
+83 ; ptr to 9002313.511.
+84 ;
+85 SET IEN59=$$CLAIM59^BPSUTIL2(BPS(9002313.02))
+86 SET IEN511=$$GET1^DIQ(9002313.59,IEN59,1.13,"I")
+87 IF 'IEN511
QUIT
+88 ;
+89 ; Loop through additional fields for the current segment (NODE) and
+90 ; call XFLDCODE to add to the claim.
+91 ;
+92 SET NODEIEN=$ORDER(^BPSF(9002313.9,"C",NODE,""))
+93 IF 'NODEIEN
QUIT
+94 SET BPSX=""
+95 FOR
SET BPSX=$ORDER(^BPS(9002313.511,IEN511,2,"SEG",NODEIEN,BPSX))
if BPSX=""
QUIT
Begin DoDot:1
+96 SET FLDIEN=$$GET1^DIQ(9002313.5112,BPSX_","_IEN511_",",.01,"I")
+97 SET BPS("X")=""
+98 DO XFLDCODE(NODE,FLDIEN,"GFS")
End DoDot:1
+99 ;
+100 QUIT
+101 ;
+102 ;
+103 ; Execute Get, Format and/or Set MUMPS code for NCPDP Field
+104 ;
+105 ; Parameters: NODE - Segment Node
+106 ; FLDIEN - NCPDP Field Definitions IEN
+107 ; FLAG - If variable contains:
+108 ; "G" - Execute Get Code
+109 ; "F" - Execute Format Code
+110 ; "S" - Execute S Code
+111 ;
+112 ; When called by the DURPPS^BPSOSHF, DUR is also set and used
+113 ; by the SET logic for the DUR fields. This variable is newed
+114 ; by the calling routine
XFLDCODE(NODE,FLDIEN,FLAG) ;EP
+1 ; 5.1 loops through the 10, 25, 30 nodes
+2 ;
+3 NEW FNODE,INDEX,MCODE,NCPVERS,X
+4 ;
+5 ; Check if record exists and FLAG variable is set correctly
+6 ; Changed from Q: to give fatal error - 10/18/2000
+7 IF 'FLDIEN
DO IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XFLDCODE",$TEXT(+0))
QUIT
+8 IF FLAG=""
DO IMPOSS^BPSOSUE("DB,P","TI","FLAG null",,"XFLDCODE",$TEXT(+0))
QUIT
+9 ; get NCPDP version, default to vD.0
+10 SET NCPVERS=$GET(BPS("NCPDP","Version"))
if NCPVERS=""
SET NCPVERS="D0"
+11 ; Loop through GET CODE, D0 FORMAT (or FORMAT), SET CODE w-p fields and execute code
+12 FOR FNODE=10,20,25,30
Begin DoDot:1
+13 ; node 25 is FORMAT CODE for versions before D.0
IF FNODE=25
IF NCPVERS="D0"
QUIT
+14 ; node 20 is FORMAT CODE for vD.0
IF FNODE=20
IF NCPVERS'="D0"
QUIT
+15 IF FLAG'[$SELECT(FNODE=10:"G",FNODE=25!(FNODE=20):"F",FNODE=30:"S",1:"")
QUIT
+16 IF '$DATA(^BPSF(9002313.91,FLDIEN,FNODE,0))
DO IMPOSS^BPSOSUE("DB","TI","FLDIEN="_FLDIEN,"FNODE="_FNODE,"XFLDCODE",$TEXT(+0))
+17 ; Loop through the W-P field and execute each line
+18 SET INDEX=0
+19 FOR
SET INDEX=$ORDER(^BPSF(9002313.91,FLDIEN,FNODE,INDEX))
if 'INDEX
QUIT
Begin DoDot:2
+20 ; If doing SET code and if this is not the header segment, add the ID prefix
+21 IF FNODE=30
IF NODE'=100
SET BPS("X")=$PIECE($GET(^BPSF(9002313.91,FLDIEN,5)),U,1)_BPS("X")
+22 ; Get the code and xecute
+23 SET MCODE=$GET(^BPSF(9002313.91,FLDIEN,FNODE,INDEX,0))
+24 ; no M code or comment
if MCODE=""
QUIT
if $EXTRACT(MCODE,1)=";"
QUIT
+25 XECUTE MCODE
End DoDot:2
End DoDot:1
+26 ;
+27 QUIT
+28 ;
+29 ;
+30 ; Execute Special Code (for NCPDP Field within NCPDP Record)
+31 ; FORMAT = NCPDP Record Format IEN (9002313.92)
+32 ; NODE = Global node value (100,110,120,130,140)
+33 ; RECMIEN = Field Multiple IEN
XSPCCODE(FORMAT,NODE,RECMIEN) ;EP - Above and BPSOSHR
+1 ; BPS NCPDP FORMATS (#9002313.92)
+2 IF '$DATA(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0))
DO IMPOSS^BPSOSUE("DB,P","TI","no special code there to XECUTE","FORMAT="_FORMAT,"XSPCCODE",$TEXT(+0))
QUIT
+3 NEW INDEX,MCODE
+4 SET INDEX=0
+5 FOR
SET INDEX=$ORDER(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+6 SET MCODE=$GET(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX,0))
+7 if MCODE=""
QUIT
+8 if $EXTRACT(MCODE,1)=";"
QUIT
+9 XECUTE MCODE
End DoDot:1
+10 QUIT
+11 ;
