- IBCEF77 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
- ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,348,349,516,577,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
- N IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
- S (IB1,IB2,IBZ,IBZ1,IBTRI)=""
- D F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
- S IBZ1=$$ALLPTYP^IBCEF3(IB399)
- F Z=1:1:3 S $P(IBZ1,U,Z)=$S($P(IBZ1,U,Z)="CH":1,1:"") S:$P(IBZ1,U,Z) IBTRI=1
- S IBNET=$$NETID^IBCEP() ; netwrk id type
- I $G(IBN) D
- . S Z=0 F S Z=$O(IBDST(IBPRNUM,IBPRTYP,Z)) Q:'Z S IBID(+$P(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
- F S IB1=$O(IBSRC(IB1)) Q:IB1="" D Q:IBN=IBLIMIT
- . N OK,IBSTLIC
- . S IBSTLIC=""
- . F S IB2=$O(IBSRC(IB1,IB2)) Q:IB2="" D Q:IBN=IBLIMIT
- . . S IBSVP=$P(IBSRC(IB1,IB2),U)
- . . ; If ID overridden, output no others of this type
- . . I $G(IBEXC),$P($G(IBSRC(IB1,IB2)),U,9)=IBEXC Q
- . . ; Ck state of care/lic match if st lic#
- . . I $P($G(IBSRC(IB1,IB2)),U,3)="0B" S OK=1 D Q:'OK
- . . . I +$$CAREST^IBCEP2A(IB399)'=$P(IBSRC(IB1,IB2),U,7) S IBSTLIC=1 Q
- . . . I $G(IBSTLIC(0))'="" S OK=0 Q
- . . . S IBSTLIC(0)=$G(IBSRC(IB1,IB2)),OK=0
- . . ; Exclude SSN from sec ids unless required
- . . I $P($G(IBSRC(IB1,IB2)),U,3)="SY" Q
- . . ; Only 1 of each prov id type
- . . Q:$D(IBID(+$P($G(IBSRC(IB1,IB2)),U,9)))
- . . S IBN=IBN+1,IBID(+$P($G(IBSRC(IB1,IB2)),U,9))=""
- . . S IBDST(IBPRNUM,IBPRTYP,IBN)=$G(IBSRC(IB1,IB2))
- . I IBN'=IBLIMIT,'$G(IBSTLIC),$G(IBSTLIC(0))'="" S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
- ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
- ;I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006 ;JRA IB*2.0*592 ';'
- N FT S FT=$$FT^IBCEF(IB399) ;JRA IB*2.0*592
- I (FT=2!(FT=7)),$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ;JRA IB*2.0*592
- . Q:$P(IBZ,U,IBPRTYP)=""
- . ; here, no network id & TRICARE ins co.
- . N Z
- . S Z=+$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)),Z=$P($G(^DGCR(399,IB399,"PRV",Z,0)),U,2)
- . S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$P($G(^IBE(355.97,IBNET,0)),U,3)_U_$P(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
- Q
- ;
- ; esg - 8/25/06 - IB*2*348 - CFIDS function
- ;
- CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
- ; Function returns a 3 piece string: [1] default secondary ID qual
- ; [2] default secondary ID
- ; [3] NPI
- ; Input: IBIFN - internal claim#
- ; PRVTYP - internal provider type ID number
- ; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
- ; - if blank, then default Att/Rend based on form type
- ; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
- ; ex "^1A^1B^1C^1H^G2^LU^N5^"
- ; UB-04 only wants IDs provided by the payer, not the providers own IDS
- ; Also, they want the qualifier to be G2 (Commercial)
- ; if it is a payer provided ID
- NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
- S ID=""
- I '$G(IBIFN) G CFIDSX
- S FT=$$FT^IBCEF(IBIFN)
- I '$G(PRVTYP) S PRVTYP=3 I FT=3 S PRVTYP=4
- D ALLIDS^IBCEF75(IBIFN,.IBZ,1)
- S OK=0 I $G(ALLOWIDS)="" S OK=1
- F I=1:1 D Q:OK
- . S IBQ=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3) ; qualifier
- . S IBSID=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4) ; ID#
- . I IBQ="",IBSID="" S OK=1 Q
- . Q:OK
- . I $G(ALLOWIDS)[(U_IBQ_U) S OK=1,IBQ="G2" Q
- . S (IBQ,IBSID)=""
- S IBNPI=""
- D F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
- S IBNPI=$P(IBNPI,U,PRVTYP) ; NPI
- ;
- ; special check for the referring doc
- I PRVTYP=1,$D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
- ;
- ; If UB-04 and no IDs, use VA UPIN as deafult
- I $D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),FT=3,IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
- ;
- ; determine if legacy ID's should be displayed
- I '$$PRTLID(IBIFN,IBNPI) S (IBQ,IBSID)=""
- ;
- S ID=IBQ_U_IBSID_U_IBNPI
- CFIDSX ;
- Q ID
- ;
- DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
- ; AMT = amount to be formatted
- ; LEN = length of field - right justified to this length
- ; DEC = flag to include the decimal point or not
- ; DEFAULT value is to not include the decimal point
- ; if DEC is not defined or 0, assume no decimal point
- ; so 15 will be returned as 1500, 6.77 will be returned as 677
- ; if DEC is 1, then the decimal point will be included
- ;
- S LEN=$G(LEN,10),DEC=$G(DEC,0) ; defaults
- S AMT=$FN(+$G(AMT),"",2) ; format # with 2 decimals
- I 'DEC S AMT=$TR(AMT,".") ; strip or leave decimal
- S AMT=$J(AMT,LEN) ; right justify
- Q AMT
- ;
- PRTLID(IBIFN,NPI) ; YMG; Print Legacy IDs on the CMS-1500 or UB-04 form
- ; Function fetches form type associated with given claim number
- ; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
- ; "Print Legacy ID" site parameter for this particular form type.
- ;
- ; Possible site parameter values are:
- ; "Y" - always print Legacy ID
- ; "N" - never print Legacy ID
- ; "C" - only print Legacy ID if NPI is not available.
- ;
- ; This information is used to determine if Legacy ID should be printed
- ; for claim number in question.
- ;
- ; Note: Situation when "Print Legacy ID" site parameter is not set is treated
- ; as if this parameter was set to "Y" - always print Legacy ID.
- ;
- ; Input:
- ; IBIFN - internal claim number
- ; NPI - NPI number (or "" if no NPI is available)
- ;
- ; Returns:
- ; 0 - Legacy ID should not be printed
- ; 1 - Legacy ID should be printed
- ;
- ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
- ;Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S($$FT^IBCEF(IBIFN)=2:32,1:33)) ;JRA IB*2.0*592 ';'
- N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592
- ;JWS;IB*2.0*592 - NO legacy id's for dental
- I FT=7 Q 0
- Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S(FT=2:32,1:33)) ;JRA IB*2.0*592
- ;
- ; for claim IBIFN. Data pulled from field# 402 of file 399 and
- ; formatted into an array IBXDATA(n) where each line is not greater
- ; than 24 characters long. This will fit into UB-04 FL-80.
- ;
- ; OFLG=1 only when called in the output formatter. In this case, only
- ; 4 lines in IBXDATA will be returned.
- ;
- NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX,IBCP1
- K IBXDATA
- ;
- ; MRD;IB*2.0*516 - Pull the Bill Remarks for the claim. If this was
- ; called from the Output Formatter, then look at lines of claim for
- ; NDC's. If any are found, they should be added to the end of TEXT.
- ;
- S TEXT=$P($G(^DGCR(399,+$G(IBIFN),"UF2")),U,3)
- ; VAD/ Begin of IB*2*577 changes
- ; NDC, Quantity, and Unit of Measure now printed in FL-43
- ; instead of here in FL-80
- ;I $G(OFLG) D
- ;. S J=0
- ;. F S J=$O(^DGCR(399,+$G(IBIFN),"CP",J)) Q:'J S IBCP1=$G(^(J,1)) I $P(IBCP1,U,7)'="" D
- ;. . I TEXT'="" S TEXT=TEXT_" "
- ;. . S TEXT=TEXT_"N4"_$TR($P(IBCP1,U,7),"-")_" UN"_$P(IBCP1,U,8)
- ;. . Q
- ;. Q
- ; VAD/ End of IB*2*577 changes
- ;
- ; If there's nothing in TEXT, then Quit.
- ;
- I TEXT="" Q
- ;
- ; need to break up large words for word wrapping purposes to get
- ; as many characters as possible in the box.
- S LEN=17
- F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
- . S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
- . S $P(TEXT," ",PCE)=NEWCHS
- . Q
- ;
- ; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
- ; array with strings of max length=1 less than what you tell it.
- ;
- S LEN=20 ; line 1 is 19 chars
- D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
- S IBK=$$TRIM^XLFSTR($G(IBZ(1))) ; save off the first line
- S TEXT=$P(TEXT,IBK,2,99) ; restore the rest of the text
- S TEXT=$$TRIM^XLFSTR(TEXT) ; trim spaces
- ;
- S LEN=25 ; the rest is 24 chars
- D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
- S IBXDATA(1)=" "_IBK ; line 1
- S J=0 F S J=$O(IBZ(J)) Q:'J D ; lines 2-n
- . I J>3,$G(OFLG) Q ; only 4 lines for output formatter
- . S TX=$$TRIM^XLFSTR($G(IBZ(J)))
- . I TX'="" S IBXDATA(J+1)=TX
- . Q
- Q
- ;
- B43(NDCDATA) ; This is passed a string and properly formats if there is NDC drug information.
- ; The drug information is in pieces 21-23 of that string.
- ; It was part of the output formatter entry 364.7[1406] used for FL43 but that got too big for a FileMan Mumps data element
- ; It returns a string with N4 - the NDC Drug qualifier
- ; NDC Code without the hyphens
- ; a space
- ; Units qualifier
- ; Units
- ; Ex "N412345678901 ML1.5"
- I NDCDATA="" Q ""
- S NDCDATA=$P(NDCDATA,U,21,23)
- Q:$P(NDCDATA,U)="" ""
- Q "N4"_$TR($P(NDCDATA,U),"-")_" "_$TR($P(NDCDATA,U,2,3),U)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF77 9176 printed Jan 18, 2025@03:11:32 Page 2
- IBCEF77 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
- +1 ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,348,349,516,577,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
- +1 NEW IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
- +2 SET (IB1,IB2,IBZ,IBZ1,IBTRI)=""
- +3 DO F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
- +4 SET IBZ1=$$ALLPTYP^IBCEF3(IB399)
- +5 FOR Z=1:1:3
- SET $PIECE(IBZ1,U,Z)=$SELECT($PIECE(IBZ1,U,Z)="CH":1,1:"")
- if $PIECE(IBZ1,U,Z)
- SET IBTRI=1
- +6 ; netwrk id type
- SET IBNET=$$NETID^IBCEP()
- +7 IF $GET(IBN)
- Begin DoDot:1
- +8 SET Z=0
- FOR
- SET Z=$ORDER(IBDST(IBPRNUM,IBPRTYP,Z))
- if 'Z
- QUIT
- SET IBID(+$PIECE(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
- End DoDot:1
- +9 FOR
- SET IB1=$ORDER(IBSRC(IB1))
- if IB1=""
- QUIT
- Begin DoDot:1
- +10 NEW OK,IBSTLIC
- +11 SET IBSTLIC=""
- +12 FOR
- SET IB2=$ORDER(IBSRC(IB1,IB2))
- if IB2=""
- QUIT
- Begin DoDot:2
- +13 SET IBSVP=$PIECE(IBSRC(IB1,IB2),U)
- +14 ; If ID overridden, output no others of this type
- +15 IF $GET(IBEXC)
- IF $PIECE($GET(IBSRC(IB1,IB2)),U,9)=IBEXC
- QUIT
- +16 ; Ck state of care/lic match if st lic#
- +17 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="0B"
- SET OK=1
- Begin DoDot:3
- +18 IF +$$CAREST^IBCEP2A(IB399)'=$PIECE(IBSRC(IB1,IB2),U,7)
- SET IBSTLIC=1
- QUIT
- +19 IF $GET(IBSTLIC(0))'=""
- SET OK=0
- QUIT
- +20 SET IBSTLIC(0)=$GET(IBSRC(IB1,IB2))
- SET OK=0
- End DoDot:3
- if 'OK
- QUIT
- +21 ; Exclude SSN from sec ids unless required
- +22 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="SY"
- QUIT
- +23 ; Only 1 of each prov id type
- +24 if $DATA(IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9)))
- QUIT
- +25 SET IBN=IBN+1
- SET IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9))=""
- +26 SET IBDST(IBPRNUM,IBPRTYP,IBN)=$GET(IBSRC(IB1,IB2))
- End DoDot:2
- if IBN=IBLIMIT
- QUIT
- +27 IF IBN'=IBLIMIT
- IF '$GET(IBSTLIC)
- IF $GET(IBSTLIC(0))'=""
- SET IBN=IBN+1
- SET IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
- End DoDot:1
- if IBN=IBLIMIT
- QUIT
- +28 ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
- +29 ;I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006 ;JRA IB*2.0*592 ';'
- +30 ;JRA IB*2.0*592
- NEW FT
- SET FT=$$FT^IBCEF(IB399)
- +31 ;JRA IB*2.0*592
- IF (FT=2!(FT=7))
- IF $GET(IBID(IBNET))=""
- IF IBTRI
- IF $PIECE(IBZ1,U,IBSEQ)
- Begin DoDot:1
- +32 if $PIECE(IBZ,U,IBPRTYP)=""
- QUIT
- +33 ; here, no network id & TRICARE ins co.
- +34 NEW Z
- +35 SET Z=+$ORDER(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
- SET Z=$PIECE($GET(^DGCR(399,IB399,"PRV",Z,0)),U,2)
- +36 SET IBN=IBN+1
- SET IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$PIECE($GET(^IBE(355.97,IBNET,0)),U,3)_U_$PIECE(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
- End DoDot:1
- +37 QUIT
- +38 ;
- +39 ; esg - 8/25/06 - IB*2*348 - CFIDS function
- +40 ;
- CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
- +1 ; Function returns a 3 piece string: [1] default secondary ID qual
- +2 ; [2] default secondary ID
- +3 ; [3] NPI
- +4 ; Input: IBIFN - internal claim#
- +5 ; PRVTYP - internal provider type ID number
- +6 ; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
- +7 ; - if blank, then default Att/Rend based on form type
- +8 ; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
- +9 ; ex "^1A^1B^1C^1H^G2^LU^N5^"
- +10 ; UB-04 only wants IDs provided by the payer, not the providers own IDS
- +11 ; Also, they want the qualifier to be G2 (Commercial)
- +12 ; if it is a payer provided ID
- +13 NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
- +14 SET ID=""
- +15 IF '$GET(IBIFN)
- GOTO CFIDSX
- +16 SET FT=$$FT^IBCEF(IBIFN)
- +17 IF '$GET(PRVTYP)
- SET PRVTYP=3
- IF FT=3
- SET PRVTYP=4
- +18 DO ALLIDS^IBCEF75(IBIFN,.IBZ,1)
- +19 SET OK=0
- IF $GET(ALLOWIDS)=""
- SET OK=1
- +20 FOR I=1:1
- Begin DoDot:1
- +21 ; qualifier
- SET IBQ=$PIECE($GET(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3)
- +22 ; ID#
- SET IBSID=$PIECE($GET(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4)
- +23 IF IBQ=""
- IF IBSID=""
- SET OK=1
- QUIT
- +24 if OK
- QUIT
- +25 IF $GET(ALLOWIDS)[(U_IBQ_U)
- SET OK=1
- SET IBQ="G2"
- QUIT
- +26 SET (IBQ,IBSID)=""
- End DoDot:1
- if OK
- QUIT
- +27 SET IBNPI=""
- +28 DO F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
- +29 ; NPI
- SET IBNPI=$PIECE(IBNPI,U,PRVTYP)
- +30 ;
- +31 ; special check for the referring doc
- +32 IF PRVTYP=1
- IF $DATA(IBZ("PROVINF",IBIFN,"C",1,PRVTYP))
- IF IBQ=""
- IF IBSID=""
- SET IBQ="1G"
- SET IBSID="VAD000"
- +33 ;
- +34 ; If UB-04 and no IDs, use VA UPIN as deafult
- +35 IF $DATA(IBZ("PROVINF",IBIFN,"C",1,PRVTYP))
- IF FT=3
- IF IBQ=""
- IF IBSID=""
- SET IBQ="1G"
- SET IBSID="VAD000"
- +36 ;
- +37 ; determine if legacy ID's should be displayed
- +38 IF '$$PRTLID(IBIFN,IBNPI)
- SET (IBQ,IBSID)=""
- +39 ;
- +40 SET ID=IBQ_U_IBSID_U_IBNPI
- CFIDSX ;
- +1 QUIT ID
- +2 ;
- DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
- +1 ; AMT = amount to be formatted
- +2 ; LEN = length of field - right justified to this length
- +3 ; DEC = flag to include the decimal point or not
- +4 ; DEFAULT value is to not include the decimal point
- +5 ; if DEC is not defined or 0, assume no decimal point
- +6 ; so 15 will be returned as 1500, 6.77 will be returned as 677
- +7 ; if DEC is 1, then the decimal point will be included
- +8 ;
- +9 ; defaults
- SET LEN=$GET(LEN,10)
- SET DEC=$GET(DEC,0)
- +10 ; format # with 2 decimals
- SET AMT=$FNUMBER(+$GET(AMT),"",2)
- +11 ; strip or leave decimal
- IF 'DEC
- SET AMT=$TRANSLATE(AMT,".")
- +12 ; right justify
- SET AMT=$JUSTIFY(AMT,LEN)
- +13 QUIT AMT
- +14 ;
- PRTLID(IBIFN,NPI) ; YMG; Print Legacy IDs on the CMS-1500 or UB-04 form
- +1 ; Function fetches form type associated with given claim number
- +2 ; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
- +3 ; "Print Legacy ID" site parameter for this particular form type.
- +4 ;
- +5 ; Possible site parameter values are:
- +6 ; "Y" - always print Legacy ID
- +7 ; "N" - never print Legacy ID
- +8 ; "C" - only print Legacy ID if NPI is not available.
- +9 ;
- +10 ; This information is used to determine if Legacy ID should be printed
- +11 ; for claim number in question.
- +12 ;
- +13 ; Note: Situation when "Print Legacy ID" site parameter is not set is treated
- +14 ; as if this parameter was set to "Y" - always print Legacy ID.
- +15 ;
- +16 ; Input:
- +17 ; IBIFN - internal claim number
- +18 ; NPI - NPI number (or "" if no NPI is available)
- +19 ;
- +20 ; Returns:
- +21 ; 0 - Legacy ID should not be printed
- +22 ; 1 - Legacy ID should be printed
- +23 ;
- +24 ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
- +25 ;Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S($$FT^IBCEF(IBIFN)=2:32,1:33)) ;JRA IB*2.0*592 ';'
- +26 ;JRA IB*2.0*592
- NEW FT
- SET FT=$$FT^IBCEF(IBIFN)
- +27 ;JWS;IB*2.0*592 - NO legacy id's for dental
- +28 IF FT=7
- QUIT 0
- +29 ;JRA IB*2.0*592
- QUIT $SELECT(NPI="":"YC",1:"Y")[$PIECE($GET(^IBE(350.9,1,1)),U,$SELECT(FT=2:32,1:33))
- +30 ;
- +1 ; for claim IBIFN. Data pulled from field# 402 of file 399 and
- +2 ; formatted into an array IBXDATA(n) where each line is not greater
- +3 ; than 24 characters long. This will fit into UB-04 FL-80.
- +4 ;
- +5 ; OFLG=1 only when called in the output formatter. In this case, only
- +6 ; 4 lines in IBXDATA will be returned.
- +7 ;
- +8 NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX,IBCP1
- +9 KILL IBXDATA
- +10 ;
- +11 ; MRD;IB*2.0*516 - Pull the Bill Remarks for the claim. If this was
- +12 ; called from the Output Formatter, then look at lines of claim for
- +13 ; NDC's. If any are found, they should be added to the end of TEXT.
- +14 ;
- +15 SET TEXT=$PIECE($GET(^DGCR(399,+$GET(IBIFN),"UF2")),U,3)
- +16 ; VAD/ Begin of IB*2*577 changes
- +17 ; NDC, Quantity, and Unit of Measure now printed in FL-43
- +18 ; instead of here in FL-80
- +19 ;I $G(OFLG) D
- +20 ;. S J=0
- +21 ;. F S J=$O(^DGCR(399,+$G(IBIFN),"CP",J)) Q:'J S IBCP1=$G(^(J,1)) I $P(IBCP1,U,7)'="" D
- +22 ;. . I TEXT'="" S TEXT=TEXT_" "
- +23 ;. . S TEXT=TEXT_"N4"_$TR($P(IBCP1,U,7),"-")_" UN"_$P(IBCP1,U,8)
- +24 ;. . Q
- +25 ;. Q
- +26 ; VAD/ End of IB*2*577 changes
- +27 ;
- +28 ; If there's nothing in TEXT, then Quit.
- +29 ;
- +30 IF TEXT=""
- QUIT
- +31 ;
- +32 ; need to break up large words for word wrapping purposes to get
- +33 ; as many characters as possible in the box.
- +34 SET LEN=17
- +35 FOR PCE=1:1
- if PCE>$LENGTH(TEXT," ")
- QUIT
- SET CHS=$PIECE(TEXT," ",PCE)
- IF $LENGTH(CHS)>LEN
- Begin DoDot:1
- +36 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
- +37 SET $PIECE(TEXT," ",PCE)=NEWCHS
- +38 QUIT
- End DoDot:1
- +39 ;
- +40 ; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
- +41 ; array with strings of max length=1 less than what you tell it.
- +42 ;
- +43 ; line 1 is 19 chars
- SET LEN=20
- +44 ; build IBZ array
- DO FSTRNG^IBJU1(TEXT,LEN,.IBZ)
- +45 ; save off the first line
- SET IBK=$$TRIM^XLFSTR($GET(IBZ(1)))
- +46 ; restore the rest of the text
- SET TEXT=$PIECE(TEXT,IBK,2,99)
- +47 ; trim spaces
- SET TEXT=$$TRIM^XLFSTR(TEXT)
- +48 ;
- +49 ; the rest is 24 chars
- SET LEN=25
- +50 ; build IBZ array
- DO FSTRNG^IBJU1(TEXT,LEN,.IBZ)
- +51 ; line 1
- SET IBXDATA(1)=" "_IBK
- +52 ; lines 2-n
- SET J=0
- FOR
- SET J=$ORDER(IBZ(J))
- if 'J
- QUIT
- Begin DoDot:1
- +53 ; only 4 lines for output formatter
- IF J>3
- IF $GET(OFLG)
- QUIT
- +54 SET TX=$$TRIM^XLFSTR($GET(IBZ(J)))
- +55 IF TX'=""
- SET IBXDATA(J+1)=TX
- +56 QUIT
- End DoDot:1
- +57 QUIT
- +58 ;
- B43(NDCDATA) ; This is passed a string and properly formats if there is NDC drug information.
- +1 ; The drug information is in pieces 21-23 of that string.
- +2 ; It was part of the output formatter entry 364.7[1406] used for FL43 but that got too big for a FileMan Mumps data element
- +3 ; It returns a string with N4 - the NDC Drug qualifier
- +4 ; NDC Code without the hyphens
- +5 ; a space
- +6 ; Units qualifier
- +7 ; Units
- +8 ; Ex "N412345678901 ML1.5"
- +9 IF NDCDATA=""
- QUIT ""
- +10 SET NDCDATA=$PIECE(NDCDATA,U,21,23)
- +11 if $PIECE(NDCDATA,U)=""
- QUIT ""
- +12 QUIT "N4"_$TRANSLATE($PIECE(NDCDATA,U),"-")_" "_$TRANSLATE($PIECE(NDCDATA,U,2,3),U)
- +13 ;