Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEF77

IBCEF77.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
  1. N IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
  1. S (IB1,IB2,IBZ,IBZ1,IBTRI)=""
  1. D F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
  1. S IBZ1=$$ALLPTYP^IBCEF3(IB399)
  1. 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
  1. S IBNET=$$NETID^IBCEP() ; netwrk id type
  1. I $G(IBN) D
  1. . S Z=0 F S Z=$O(IBDST(IBPRNUM,IBPRTYP,Z)) Q:'Z S IBID(+$P(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
  1. F S IB1=$O(IBSRC(IB1)) Q:IB1="" D Q:IBN=IBLIMIT
  1. . N OK,IBSTLIC
  1. . S IBSTLIC=""
  1. . F S IB2=$O(IBSRC(IB1,IB2)) Q:IB2="" D Q:IBN=IBLIMIT
  1. . . S IBSVP=$P(IBSRC(IB1,IB2),U)
  1. . . ; If ID overridden, output no others of this type
  1. . . I $G(IBEXC),$P($G(IBSRC(IB1,IB2)),U,9)=IBEXC Q
  1. . . ; Ck state of care/lic match if st lic#
  1. . . I $P($G(IBSRC(IB1,IB2)),U,3)="0B" S OK=1 D Q:'OK
  1. . . . I +$$CAREST^IBCEP2A(IB399)'=$P(IBSRC(IB1,IB2),U,7) S IBSTLIC=1 Q
  1. . . . I $G(IBSTLIC(0))'="" S OK=0 Q
  1. . . . S IBSTLIC(0)=$G(IBSRC(IB1,IB2)),OK=0
  1. . . ; Exclude SSN from sec ids unless required
  1. . . I $P($G(IBSRC(IB1,IB2)),U,3)="SY" Q
  1. . . ; Only 1 of each prov id type
  1. . . Q:$D(IBID(+$P($G(IBSRC(IB1,IB2)),U,9)))
  1. . . S IBN=IBN+1,IBID(+$P($G(IBSRC(IB1,IB2)),U,9))=""
  1. . . S IBDST(IBPRNUM,IBPRTYP,IBN)=$G(IBSRC(IB1,IB2))
  1. . I IBN'=IBLIMIT,'$G(IBSTLIC),$G(IBSTLIC(0))'="" S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
  1. ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
  1. ;I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006 ;JRA IB*2.0*592 ';'
  1. N FT S FT=$$FT^IBCEF(IB399) ;JRA IB*2.0*592
  1. I (FT=2!(FT=7)),$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ;JRA IB*2.0*592
  1. . Q:$P(IBZ,U,IBPRTYP)=""
  1. . ; here, no network id & TRICARE ins co.
  1. . N Z
  1. . S Z=+$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)),Z=$P($G(^DGCR(399,IB399,"PRV",Z,0)),U,2)
  1. . 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
  1. Q
  1. ;
  1. ; esg - 8/25/06 - IB*2*348 - CFIDS function
  1. ;
  1. CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
  1. ; Function returns a 3 piece string: [1] default secondary ID qual
  1. ; [2] default secondary ID
  1. ; [3] NPI
  1. ; Input: IBIFN - internal claim#
  1. ; PRVTYP - internal provider type ID number
  1. ; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
  1. ; - if blank, then default Att/Rend based on form type
  1. ; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
  1. ; ex "^1A^1B^1C^1H^G2^LU^N5^"
  1. ; UB-04 only wants IDs provided by the payer, not the providers own IDS
  1. ; Also, they want the qualifier to be G2 (Commercial)
  1. ; if it is a payer provided ID
  1. NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
  1. S ID=""
  1. I '$G(IBIFN) G CFIDSX
  1. S FT=$$FT^IBCEF(IBIFN)
  1. I '$G(PRVTYP) S PRVTYP=3 I FT=3 S PRVTYP=4
  1. D ALLIDS^IBCEF75(IBIFN,.IBZ,1)
  1. S OK=0 I $G(ALLOWIDS)="" S OK=1
  1. F I=1:1 D Q:OK
  1. . S IBQ=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3) ; qualifier
  1. . S IBSID=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4) ; ID#
  1. . I IBQ="",IBSID="" S OK=1 Q
  1. . Q:OK
  1. . I $G(ALLOWIDS)[(U_IBQ_U) S OK=1,IBQ="G2" Q
  1. . S (IBQ,IBSID)=""
  1. S IBNPI=""
  1. D F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
  1. S IBNPI=$P(IBNPI,U,PRVTYP) ; NPI
  1. ;
  1. ; special check for the referring doc
  1. I PRVTYP=1,$D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
  1. ;
  1. ; If UB-04 and no IDs, use VA UPIN as deafult
  1. I $D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),FT=3,IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
  1. ;
  1. ; determine if legacy ID's should be displayed
  1. I '$$PRTLID(IBIFN,IBNPI) S (IBQ,IBSID)=""
  1. ;
  1. S ID=IBQ_U_IBSID_U_IBNPI
  1. CFIDSX ;
  1. Q ID
  1. ;
  1. DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
  1. ; AMT = amount to be formatted
  1. ; LEN = length of field - right justified to this length
  1. ; DEC = flag to include the decimal point or not
  1. ; DEFAULT value is to not include the decimal point
  1. ; if DEC is not defined or 0, assume no decimal point
  1. ; so 15 will be returned as 1500, 6.77 will be returned as 677
  1. ; if DEC is 1, then the decimal point will be included
  1. ;
  1. S LEN=$G(LEN,10),DEC=$G(DEC,0) ; defaults
  1. S AMT=$FN(+$G(AMT),"",2) ; format # with 2 decimals
  1. I 'DEC S AMT=$TR(AMT,".") ; strip or leave decimal
  1. S AMT=$J(AMT,LEN) ; right justify
  1. Q AMT
  1. ;
  1. 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
  1. ; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
  1. ; "Print Legacy ID" site parameter for this particular form type.
  1. ;
  1. ; Possible site parameter values are:
  1. ; "Y" - always print Legacy ID
  1. ; "N" - never print Legacy ID
  1. ; "C" - only print Legacy ID if NPI is not available.
  1. ;
  1. ; This information is used to determine if Legacy ID should be printed
  1. ; for claim number in question.
  1. ;
  1. ; Note: Situation when "Print Legacy ID" site parameter is not set is treated
  1. ; as if this parameter was set to "Y" - always print Legacy ID.
  1. ;
  1. ; Input:
  1. ; IBIFN - internal claim number
  1. ; NPI - NPI number (or "" if no NPI is available)
  1. ;
  1. ; Returns:
  1. ; 0 - Legacy ID should not be printed
  1. ; 1 - Legacy ID should be printed
  1. ;
  1. ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
  1. ;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 ';'
  1. N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592
  1. ;JWS;IB*2.0*592 - NO legacy id's for dental
  1. I FT=7 Q 0
  1. 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
  1. ;
  1. REMARK(IBIFN,IBXDATA,OFLG) ; procedure to return array of UB-04 remark text
  1. ; for claim IBIFN. Data pulled from field# 402 of file 399 and
  1. ; formatted into an array IBXDATA(n) where each line is not greater
  1. ; than 24 characters long. This will fit into UB-04 FL-80.
  1. ;
  1. ; OFLG=1 only when called in the output formatter. In this case, only
  1. ; 4 lines in IBXDATA will be returned.
  1. ;
  1. NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX,IBCP1
  1. K IBXDATA
  1. ;
  1. ; MRD;IB*2.0*516 - Pull the Bill Remarks for the claim. If this was
  1. ; called from the Output Formatter, then look at lines of claim for
  1. ; NDC's. If any are found, they should be added to the end of TEXT.
  1. ;
  1. S TEXT=$P($G(^DGCR(399,+$G(IBIFN),"UF2")),U,3)
  1. ; VAD/ Begin of IB*2*577 changes
  1. ; NDC, Quantity, and Unit of Measure now printed in FL-43
  1. ; instead of here in FL-80
  1. ;I $G(OFLG) D
  1. ;. S J=0
  1. ;. F S J=$O(^DGCR(399,+$G(IBIFN),"CP",J)) Q:'J S IBCP1=$G(^(J,1)) I $P(IBCP1,U,7)'="" D
  1. ;. . I TEXT'="" S TEXT=TEXT_" "
  1. ;. . S TEXT=TEXT_"N4"_$TR($P(IBCP1,U,7),"-")_" UN"_$P(IBCP1,U,8)
  1. ;. . Q
  1. ;. Q
  1. ; VAD/ End of IB*2*577 changes
  1. ;
  1. ; If there's nothing in TEXT, then Quit.
  1. ;
  1. I TEXT="" Q
  1. ;
  1. ; need to break up large words for word wrapping purposes to get
  1. ; as many characters as possible in the box.
  1. S LEN=17
  1. F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
  1. . S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
  1. . S $P(TEXT," ",PCE)=NEWCHS
  1. . Q
  1. ;
  1. ; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
  1. ; array with strings of max length=1 less than what you tell it.
  1. ;
  1. S LEN=20 ; line 1 is 19 chars
  1. D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
  1. S IBK=$$TRIM^XLFSTR($G(IBZ(1))) ; save off the first line
  1. S TEXT=$P(TEXT,IBK,2,99) ; restore the rest of the text
  1. S TEXT=$$TRIM^XLFSTR(TEXT) ; trim spaces
  1. ;
  1. S LEN=25 ; the rest is 24 chars
  1. D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
  1. S IBXDATA(1)=" "_IBK ; line 1
  1. S J=0 F S J=$O(IBZ(J)) Q:'J D ; lines 2-n
  1. . I J>3,$G(OFLG) Q ; only 4 lines for output formatter
  1. . S TX=$$TRIM^XLFSTR($G(IBZ(J)))
  1. . I TX'="" S IBXDATA(J+1)=TX
  1. . Q
  1. Q
  1. ;
  1. 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.
  1. ; 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
  1. ; It returns a string with N4 - the NDC Drug qualifier
  1. ; NDC Code without the hyphens
  1. ; a space
  1. ; Units qualifier
  1. ; Units
  1. ; Ex "N412345678901 ML1.5"
  1. I NDCDATA="" Q ""
  1. S NDCDATA=$P(NDCDATA,U,21,23)
  1. Q:$P(NDCDATA,U)="" ""
  1. Q "N4"_$TR($P(NDCDATA,U),"-")_" "_$TR($P(NDCDATA,U,2,3),U)
  1. ;