- 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 Feb 18, 2025@23:18:04 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