BPSOSHF ;BHAM ISC/SD/lwj/DLF - Get/Format/Set value for repeating segments ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,11,23,24**;JUN 2004;Build 43
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine is an addendum to BPSOSCF. Its purpose is to handle
; some of the repeating fields that now exist in NCPDP 5.1.
; The logic was put in here rather than BPSOSCF to keep the original
; routine (BPSOSCF) from growing too large and too cumbersome to
; maintain.
;
DURPPS(FORMAT,NODE,MEDN) ;EP called from BPSOSCF
;
; First order of business - check the BPS("RX",MEDN,"DUR") array
; for values - if there aren't any, we don't need to write this
; segment
;
N FIELD,DUR,FLD,OVERRIDE,FLAG,ORD,FLDIEN,FLDNUM,FLDNUMB,FOUND
S FLAG="FS"
;
Q:'$D(BPS("RX",MEDN,"DUR"))
;
; Next we need to figure out which fields on this format are really
; needed, then we will loop through and populate them
;
D GETFLDS(FORMAT,NODE,.FIELD)
;
; Now lets get, format and set the field
S (ORD,DUR)=0
F S DUR=$O(BPS("RX",MEDN,"DUR",DUR)) Q:DUR="" D
. S FLDNUM="" F S FLDNUM=$O(BPS("RX",MEDN,"DUR",DUR,FLDNUM)) Q:FLDNUM="" D
.. S ORD="",FOUND=0
.. F S ORD=$O(FIELD(ORD)) Q:ORD="" D Q:FOUND
... S FLDNUMB="",FLDNUMB=$P(FIELD(ORD),U,2) Q:FLDNUMB'=FLDNUM
... S FLDIEN="",FLDIEN=$P(FIELD(ORD),U)
... S BPS("X")=BPS("RX",MEDN,"DUR",DUR,FLDNUM)
... S FOUND=1
... D XFLDCODE^BPSOSCF(NODE,FLDIEN,FLAG) ;format/set
Q
;
COB(FORMAT,NODE,MEDN) ; COB fields processing, NODE=160
;---------------------------------------------------------------
; The COB data is stored in the following local array:
;
; BPS("RX",MEDN,"OTHER PAYER",.....
;
; Array built in routine BPSOSCD.
; Special note - Overrides are not allowed on this multiple.
; "Special" code is not accounted for either.
;---------------------------------------------------------------
;
N FIELD,FLD,OVERRIDE,FLAG,ORD,NCPFLD,BPD,BPD1,BPD2,PCE,BPSOPIEN,BPSOAIEN,BPSORIEN,BPSCOUNT
S FLAG="FS"
;
; Quit if there is no data in the array
Q:'$D(BPS("RX",MEDN,"OTHER PAYER"))
;
; next we need to figure out which fields on this format are really
; needed, then we will loop through and populate them
;
D GETFLDS(FORMAT,NODE,.FIELD)
;
; re-sort this list by the NCPDP field#
; NCPFLD(NCPDP FIELD#) = internal field#
K NCPFLD S ORD=0 F S ORD=$O(FIELD(ORD)) Q:'ORD S FLD=$P(FIELD(ORD),U,2) I FLD'="" S NCPFLD(FLD)=+FIELD(ORD)
;
; see if 337-4C is needed
S FLD=337
I $D(NCPFLD(FLD)) D
. S BPS("X")=$P($G(BPS("RX",MEDN,"OTHER PAYER",0)),U,1) ; get
. I BPS("X")="" Q
. D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set
. Q
;
; now lets get, format and set the rest of the COB fields
S BPSOPIEN=0 F S BPSOPIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN)) Q:'BPSOPIEN D
. S BPD=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,0))
. ; Note that piece 9 (Benefit Stage Count) is only set by Certification Code
. F PCE=1:1:7,9,11 D
.. S FLD=$S(PCE=1:337,PCE=2:338,PCE=3:339,PCE=4:340,PCE=5:443,PCE=6:341,PCE=7:471,PCE=9:392,PCE=11:2149,1:0) Q:'FLD
.. I '$D(NCPFLD(FLD)) Q ; field not needed
.. I $P(BPD,U,PCE)="" Q ; data is nil
.. S BPS("X")=$P(BPD,U,PCE) ; get
.. D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set
.. Q
. ;
. ; Now look at the other payer amount paid fields
. S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN)) Q:'BPSOAIEN D
.. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN,0))
.. F PCE=1,2 D
... S FLD=$S(PCE=1:431,PCE=2:342,1:0) Q:'FLD
... I '$D(NCPFLD(FLD)) Q ; field not needed
... I $P(BPD1,U,PCE)="" Q ; data is nil
... S BPS("X")=$P(BPD1,U,PCE) ; get
... D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set
.. Q
. ;
. ; Now look at the other payer reject code fields
. S BPSORIEN=0 F S BPSORIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN)) Q:'BPSORIEN D
.. S BPD2=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN,0))
.. S FLD=472
.. I '$D(NCPFLD(FLD)) Q ; field not needed
.. I BPD2="" Q ; data is nil
.. S BPS("X")=BPD2 ; get
.. D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set
.. Q
. ;
. ; Now look at the other payer-patient amount paid fields
. S BPSCOUNT=0 ; initialize counter
. S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN)) Q:'BPSOAIEN D
.. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN,0))
.. ;
.. ; Field 352-NQ = OTHER PAYER-PAT RESP AMOUNT
.. I '$D(NCPFLD(352)) Q ; fields not needed
.. I '+$P(BPD1,U,1) Q ; data is nil or zero
.. S BPSCOUNT=BPSCOUNT+1 ; increment counter
.. S BPS("X")=$P(BPD1,U,1) ; get
.. D XFLDCODE^BPSOSCF(NODE,NCPFLD(352),FLAG) ; format/set
.. ;
.. ; If Field 352 is populated, then populate 351 and 353.
.. ;
.. ; Field 351-NP = OTHER PAYER-PAT RESP AMT QLFR
.. S BPS("X")=$P(BPD1,U,2) ; get
.. D XFLDCODE^BPSOSCF(NODE,NCPFLD(351),FLAG) ; format/set
.. ;
.. ; Field 353-NR = OTHER PAYER-PAT RESP AMT CNT
.. S BPS("X")=BPSCOUNT ; get
.. D XFLDCODE^BPSOSCF(NODE,NCPFLD(353),FLAG) ; format/set
.. Q
. ;
. ; Now look at the Benefit Stages fields
. ; Currently, this multiple is only set by certification code
. S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN)) Q:'BPSOAIEN D
.. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN,0))
.. F PCE=1,2 D
... S FLD=$S(PCE=1:394,PCE=2:393,1:0) Q:'FLD
... I '$D(NCPFLD(FLD)) Q ; field not needed
... I $P(BPD1,U,PCE)="" Q ; data is nil
... S BPS("X")=$P(BPD1,U,PCE) ; get
... D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set
.. Q
. Q
;
COBX ;
Q
;
GETFLDS(FORMAT,NODE,FIELD) ;EP NCPDP 5.1
;---------------------------------------------------------------
;This routine will get the list of repeating fields that must be
; be worked with separately
; (This was originally coded for the DUR/PPS segment - I'm not
; 100% sure how and if it will work for the other repeating
; fields that exist within a segment.)
;---------------------------------------------------------------
; Coming in:
; FORMAT = BPSF(9002313.92 's format IEN
; NODE = which segment we are processing (i.e. 180 - DUR/PPS)
; .FIELD = array to store the values in
;
; Exitting:
; .FIELD array will look like:
; FIELD(ord)=int^ext
; Where: ext = external field number from BPSF(9002313.91
; int = internal field number from BPSF(9002313.91
; ord = the order of the field - used in creating clm
;---------------------------------------------------------------
;
N ORDER,RECMIEN,MDATA,FLDIEN,FLDNUM,DUR
;
S ORDER=0
;
F D Q:'ORDER
. ;
. ; let's order through the format file for this node
. S ORDER=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER)) Q:'ORDER
. 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))
. S MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0)
. S FLDIEN=$P(MDATA,U,2)
. I 'FLDIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"RECMIEN="_RECMIEN,3,$T(+0)) ; corrupt or erroneous format file
. I '$D(^BPSF(9002313.91,FLDIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"DURPPS",$T(+0)) ;incomplete field definition
. ;
. ;lets create a list of fields we need
. S FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U)
. S:FLDNUM'=111 FIELD(ORDER)=FLDIEN_"^"_FLDNUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSHF 8059 printed Apr 09, 2024@20:58:45 Page 2
BPSOSHF ;BHAM ISC/SD/lwj/DLF - Get/Format/Set value for repeating segments ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,11,23,24**;JUN 2004;Build 43
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine is an addendum to BPSOSCF. Its purpose is to handle
+5 ; some of the repeating fields that now exist in NCPDP 5.1.
+6 ; The logic was put in here rather than BPSOSCF to keep the original
+7 ; routine (BPSOSCF) from growing too large and too cumbersome to
+8 ; maintain.
+9 ;
DURPPS(FORMAT,NODE,MEDN) ;EP called from BPSOSCF
+1 ;
+2 ; First order of business - check the BPS("RX",MEDN,"DUR") array
+3 ; for values - if there aren't any, we don't need to write this
+4 ; segment
+5 ;
+6 NEW FIELD,DUR,FLD,OVERRIDE,FLAG,ORD,FLDIEN,FLDNUM,FLDNUMB,FOUND
+7 SET FLAG="FS"
+8 ;
+9 if '$DATA(BPS("RX",MEDN,"DUR"))
QUIT
+10 ;
+11 ; Next we need to figure out which fields on this format are really
+12 ; needed, then we will loop through and populate them
+13 ;
+14 DO GETFLDS(FORMAT,NODE,.FIELD)
+15 ;
+16 ; Now lets get, format and set the field
+17 SET (ORD,DUR)=0
+18 FOR
SET DUR=$ORDER(BPS("RX",MEDN,"DUR",DUR))
if DUR=""
QUIT
Begin DoDot:1
+19 SET FLDNUM=""
FOR
SET FLDNUM=$ORDER(BPS("RX",MEDN,"DUR",DUR,FLDNUM))
if FLDNUM=""
QUIT
Begin DoDot:2
+20 SET ORD=""
SET FOUND=0
+21 FOR
SET ORD=$ORDER(FIELD(ORD))
if ORD=""
QUIT
Begin DoDot:3
+22 SET FLDNUMB=""
SET FLDNUMB=$PIECE(FIELD(ORD),U,2)
if FLDNUMB'=FLDNUM
QUIT
+23 SET FLDIEN=""
SET FLDIEN=$PIECE(FIELD(ORD),U)
+24 SET BPS("X")=BPS("RX",MEDN,"DUR",DUR,FLDNUM)
+25 SET FOUND=1
+26 ;format/set
DO XFLDCODE^BPSOSCF(NODE,FLDIEN,FLAG)
End DoDot:3
if FOUND
QUIT
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
COB(FORMAT,NODE,MEDN) ; COB fields processing, NODE=160
+1 ;---------------------------------------------------------------
+2 ; The COB data is stored in the following local array:
+3 ;
+4 ; BPS("RX",MEDN,"OTHER PAYER",.....
+5 ;
+6 ; Array built in routine BPSOSCD.
+7 ; Special note - Overrides are not allowed on this multiple.
+8 ; "Special" code is not accounted for either.
+9 ;---------------------------------------------------------------
+10 ;
+11 NEW FIELD,FLD,OVERRIDE,FLAG,ORD,NCPFLD,BPD,BPD1,BPD2,PCE,BPSOPIEN,BPSOAIEN,BPSORIEN,BPSCOUNT
+12 SET FLAG="FS"
+13 ;
+14 ; Quit if there is no data in the array
+15 if '$DATA(BPS("RX",MEDN,"OTHER PAYER"))
QUIT
+16 ;
+17 ; next we need to figure out which fields on this format are really
+18 ; needed, then we will loop through and populate them
+19 ;
+20 DO GETFLDS(FORMAT,NODE,.FIELD)
+21 ;
+22 ; re-sort this list by the NCPDP field#
+23 ; NCPFLD(NCPDP FIELD#) = internal field#
+24 KILL NCPFLD
SET ORD=0
FOR
SET ORD=$ORDER(FIELD(ORD))
if 'ORD
QUIT
SET FLD=$PIECE(FIELD(ORD),U,2)
IF FLD'=""
SET NCPFLD(FLD)=+FIELD(ORD)
+25 ;
+26 ; see if 337-4C is needed
+27 SET FLD=337
+28 IF $DATA(NCPFLD(FLD))
Begin DoDot:1
+29 ; get
SET BPS("X")=$PIECE($GET(BPS("RX",MEDN,"OTHER PAYER",0)),U,1)
+30 IF BPS("X")=""
QUIT
+31 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG)
+32 QUIT
End DoDot:1
+33 ;
+34 ; now lets get, format and set the rest of the COB fields
+35 SET BPSOPIEN=0
FOR
SET BPSOPIEN=$ORDER(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN))
if 'BPSOPIEN
QUIT
Begin DoDot:1
+36 SET BPD=$GET(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,0))
+37 ; Note that piece 9 (Benefit Stage Count) is only set by Certification Code
+38 FOR PCE=1:1:7,9,11
Begin DoDot:2
+39 SET FLD=$SELECT(PCE=1:337,PCE=2:338,PCE=3:339,PCE=4:340,PCE=5:443,PCE=6:341,PCE=7:471,PCE=9:392,PCE=11:2149,1:0)
if 'FLD
QUIT
+40 ; field not needed
IF '$DATA(NCPFLD(FLD))
QUIT
+41 ; data is nil
IF $PIECE(BPD,U,PCE)=""
QUIT
+42 ; get
SET BPS("X")=$PIECE(BPD,U,PCE)
+43 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG)
+44 QUIT
End DoDot:2
+45 ;
+46 ; Now look at the other payer amount paid fields
+47 SET BPSOAIEN=0
FOR
SET BPSOAIEN=$ORDER(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN))
if 'BPSOAIEN
QUIT
Begin DoDot:2
+48 SET BPD1=$GET(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN,0))
+49 FOR PCE=1,2
Begin DoDot:3
+50 SET FLD=$SELECT(PCE=1:431,PCE=2:342,1:0)
if 'FLD
QUIT
+51 ; field not needed
IF '$DATA(NCPFLD(FLD))
QUIT
+52 ; data is nil
IF $PIECE(BPD1,U,PCE)=""
QUIT
+53 ; get
SET BPS("X")=$PIECE(BPD1,U,PCE)
+54 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG)
End DoDot:3
+55 QUIT
End DoDot:2
+56 ;
+57 ; Now look at the other payer reject code fields
+58 SET BPSORIEN=0
FOR
SET BPSORIEN=$ORDER(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN))
if 'BPSORIEN
QUIT
Begin DoDot:2
+59 SET BPD2=$GET(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN,0))
+60 SET FLD=472
+61 ; field not needed
IF '$DATA(NCPFLD(FLD))
QUIT
+62 ; data is nil
IF BPD2=""
QUIT
+63 ; get
SET BPS("X")=BPD2
+64 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG)
+65 QUIT
End DoDot:2
+66 ;
+67 ; Now look at the other payer-patient amount paid fields
+68 ; initialize counter
SET BPSCOUNT=0
+69 SET BPSOAIEN=0
FOR
SET BPSOAIEN=$ORDER(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN))
if 'BPSOAIEN
QUIT
Begin DoDot:2
+70 SET BPD1=$GET(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN,0))
+71 ;
+72 ; Field 352-NQ = OTHER PAYER-PAT RESP AMOUNT
+73 ; fields not needed
IF '$DATA(NCPFLD(352))
QUIT
+74 ; data is nil or zero
IF '+$PIECE(BPD1,U,1)
QUIT
+75 ; increment counter
SET BPSCOUNT=BPSCOUNT+1
+76 ; get
SET BPS("X")=$PIECE(BPD1,U,1)
+77 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(352),FLAG)
+78 ;
+79 ; If Field 352 is populated, then populate 351 and 353.
+80 ;
+81 ; Field 351-NP = OTHER PAYER-PAT RESP AMT QLFR
+82 ; get
SET BPS("X")=$PIECE(BPD1,U,2)
+83 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(351),FLAG)
+84 ;
+85 ; Field 353-NR = OTHER PAYER-PAT RESP AMT CNT
+86 ; get
SET BPS("X")=BPSCOUNT
+87 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(353),FLAG)
+88 QUIT
End DoDot:2
+89 ;
+90 ; Now look at the Benefit Stages fields
+91 ; Currently, this multiple is only set by certification code
+92 SET BPSOAIEN=0
FOR
SET BPSOAIEN=$ORDER(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN))
if 'BPSOAIEN
QUIT
Begin DoDot:2
+93 SET BPD1=$GET(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN,0))
+94 FOR PCE=1,2
Begin DoDot:3
+95 SET FLD=$SELECT(PCE=1:394,PCE=2:393,1:0)
if 'FLD
QUIT
+96 ; field not needed
IF '$DATA(NCPFLD(FLD))
QUIT
+97 ; data is nil
IF $PIECE(BPD1,U,PCE)=""
QUIT
+98 ; get
SET BPS("X")=$PIECE(BPD1,U,PCE)
+99 ; format/set
DO XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG)
End DoDot:3
+100 QUIT
End DoDot:2
+101 QUIT
End DoDot:1
+102 ;
COBX ;
+1 QUIT
+2 ;
GETFLDS(FORMAT,NODE,FIELD) ;EP NCPDP 5.1
+1 ;---------------------------------------------------------------
+2 ;This routine will get the list of repeating fields that must be
+3 ; be worked with separately
+4 ; (This was originally coded for the DUR/PPS segment - I'm not
+5 ; 100% sure how and if it will work for the other repeating
+6 ; fields that exist within a segment.)
+7 ;---------------------------------------------------------------
+8 ; Coming in:
+9 ; FORMAT = BPSF(9002313.92 's format IEN
+10 ; NODE = which segment we are processing (i.e. 180 - DUR/PPS)
+11 ; .FIELD = array to store the values in
+12 ;
+13 ; Exitting:
+14 ; .FIELD array will look like:
+15 ; FIELD(ord)=int^ext
+16 ; Where: ext = external field number from BPSF(9002313.91
+17 ; int = internal field number from BPSF(9002313.91
+18 ; ord = the order of the field - used in creating clm
+19 ;---------------------------------------------------------------
+20 ;
+21 NEW ORDER,RECMIEN,MDATA,FLDIEN,FLDNUM,DUR
+22 ;
+23 SET ORDER=0
+24 ;
+25 FOR
Begin DoDot:1
+26 ;
+27 ; let's order through the format file for this node
+28 SET ORDER=$ORDER(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER))
if 'ORDER
QUIT
+29 SET RECMIEN=$ORDER(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0))
+30 IF 'RECMIEN
DO IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$TEXT(+0))
+31 SET MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0)
+32 SET FLDIEN=$PIECE(MDATA,U,2)
+33 ; corrupt or erroneous format file
IF 'FLDIEN
DO IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"RECMIEN="_RECMIEN,3,$TEXT(+0))
+34 ;incomplete field definition
IF '$DATA(^BPSF(9002313.91,FLDIEN,0))
DO IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"DURPPS",$TEXT(+0))
+35 ;
+36 ;lets create a list of fields we need
+37 SET FLDNUM=$PIECE($GET(^BPSF(9002313.91,FLDIEN,0)),U)
+38 if FLDNUM'=111
SET FIELD(ORDER)=FLDIEN_"^"_FLDNUM
End DoDot:1
if 'ORDER
QUIT
+39 QUIT
