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

IBCEF31.m

Go to the documentation of this file.
  1. IBCEF31 ;ALB/ESG - FORMATTER SPECIFIC BILL FLD FUNCTIONS - CONT ;14-NOV-03
  1. ;;2.0;INTEGRATED BILLING;**155,296,349,400,432,488,516,592,608**;21-MAR-94;Build 90
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. ALLTYP(IBIFN) ; returns codes to translate to ALL ins types on a bill
  1. ; IBIFN = ien of bill
  1. N IBX,Z
  1. F Z=1:1:3 S $P(IBX,U,Z)=$$INSTYP(IBIFN,Z)
  1. ; IBX = primary code^secondary code^tertiary code
  1. Q IBX
  1. ;
  1. INSTYP(IBIFN,SEQ) ; Returns insurance type code for an ins on a bill
  1. ; IBIFN = ien of bill
  1. ; SEQ = sequence (1,2,3) of insurance wanted - prim, second, tert
  1. ; Default is current insurance co
  1. ;
  1. N IBA,Z
  1. ;
  1. I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN)
  1. S Z=+$G(^DGCR(399,IBIFN,"I"_SEQ))
  1. ;Codes 1:HMO;2:COMMERCIAL;3:MEDICARE;4:MEDICAID;5:GROUP POLICY;9:OTHER
  1. I Z D
  1. . S IBA=$P($G(^DIC(36,Z,3)),U,9)
  1. . I $$MCRWNR^IBEFUNC(Z) S IBA=3 ; force Medicare (WNR) definition to be correct
  1. . I IBA="" S IBA=5 ;Default is group policy - 5 if blank
  1. ;
  1. Q $G(IBA)
  1. ;
  1. POLTYP(IBIFN,IBSEQ) ; Returns ins electronic policy type code for one
  1. ; ins policy on a bill
  1. ; IBIFN = ien of bill
  1. ; IBSEQ = sequence (1,2,3) of ins policy wanted - prim, second, tert
  1. ; Default is current insurance co
  1. ;
  1. N IBPLAN,IBPLTYP
  1. ;
  1. I '$G(IBSEQ) S IBSEQ=+$$COBN^IBCEF(IBIFN)
  1. S IBPLAN=$G(^IBA(355.3,+$P($G(^DGCR(399,IBIFN,"I"_IBSEQ)),U,18),0))
  1. S IBPLTYP=$P(IBPLAN,U,15)
  1. ;
  1. ; esg - 06/30/05 - IB*2.0*296 - Force Medicare (WNR) to be correct
  1. ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) the same as CMS-1500
  1. ;I $$WNRBILL^IBEFUNC(IBIFN,IBSEQ),$$FT^IBCEF(IBIFN)=2 S IBPLTYP="MB" ; CMS-1500 ----> Medicare Part B ;JRA IB*2.0*592 ';'
  1. ;I $$WNRBILL^IBEFUNC(IBIFN,IBSEQ),$$FT^IBCEF(IBIFN)=3 S IBPLTYP="MA" ; UB-04 -------> Medicare Part A
  1. N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592
  1. I $$WNRBILL^IBEFUNC(IBIFN,IBSEQ),(FT=2!(FT=7)) S IBPLTYP="MB" ; CMS-1500 ----> Medicare Part B ;JRA IB*2.0*592 same for J430D
  1. I $$WNRBILL^IBEFUNC(IBIFN,IBSEQ),FT=3 S IBPLTYP="MA" ; UB-04 -------> Medicare Part A ;JRA IB*2.0*592 Use 'FT' vs function call
  1. ;
  1. I IBPLTYP="" S IBPLTYP="CI" ;Default is commercial - 'CI'
  1. I IBPLTYP="MX" D
  1. . I $P(IBPLAN,U,14)'="","AB"[$P(IBPLAN,U,14) S IBPLTYP="M"_$P(IBPLAN,U,14) Q
  1. . S IBPLTYP="CI"
  1. Q $G(IBPLTYP)
  1. ;
  1. ALLPTYP(IBIFN) ; returns insurance policy type codes for ALL ins on a bill
  1. ; IBIFN = ien of bill
  1. N IBX,Z S IBX=""
  1. F Z=1:1:3 I $D(^DGCR(399,IBIFN,"I"_Z)) S $P(IBX,U,Z)=$$POLTYP(IBIFN,Z)
  1. ; IBX = primary code^secondary code^tertiary code
  1. Q IBX
  1. ;
  1. PGDX(DXCNT,IBX0,IBXDA,IBXLN,IBXCOL,IBXSIZE,IBXSAVE) ; Subroutine - Checks for Diagnosis Codes (Dx) beyond
  1. ; the first four, that relate to the current Dx position passed in DXCNT.
  1. ; This subroutine stores the Diagnosis Codes in output global using display parameters (IBXLN,IBXCOL)
  1. ; THE PAGE IS ALWAYS 1 NOW SO WE DON'T NEED 4 LINES BELOW BAA *488*
  1. ; If DXCNT is 1, check for Dx's 5,9,...etc & display on pages 2,3,...etc
  1. ; If DXCNT is 2, check for Dx's 6,10,...etc & display on pages 2,3,...etc
  1. ; If DXCNT is 3, check for Dx's 7,11,...etc & display on pages 2,3,...etc
  1. ; If DXCNT is 4, check for Dx's 8,12,...etc & display on pages 2,3,...etc
  1. ;
  1. ; Input: DXCNT= position of current Dx (from 1 to 4)
  1. ; IBX0= zero-level of file 364.7 of current Dx
  1. ; IBXDA= ien# of file 364.6 of current Dx
  1. ; IBXLN IBXCOL= line# & Column# of current Dx
  1. ; IBXSIZE= size counter
  1. ; IBXSAVE("DX")= local array with all Dx's on current bill
  1. ;
  1. ; For patch *488*
  1. ; S DXNM = 12 This is the number of diagnosis on a 1500 form
  1. ; S IBPG=1 This is the page number. All 12 print on page 1
  1. N IBPG,VAL
  1. S IBPG=1
  1. I '$D(IBXSAVE("DX",DXCNT)) Q
  1. S VAL=$P($$ICD9^IBACSV(+IBXSAVE("DX",DXCNT)),U) ; resolve Dx pointer
  1. S VAL=$$FORMAT^IBCEF3(VAL,$G(IBX0),$G(IBXDA)) ;format Dx value
  1. D SETGBL^IBCEFG(IBPG,IBXLN,IBXCOL,VAL,.IBXSIZE) ;store in output global
  1. Q ;PGDX
  1. ;
  1. DXSV(IB,IBXSAVE) ; output formatter subroutine
  1. ; save off DX codes in IBXSAVE("DX")
  1. N Z,IBCT
  1. S (Z,IBCT)=0
  1. F S Z=$O(IB(Z)) Q:'Z I $G(IB(Z)) S IBCT=IBCT+1 M IBXSAVE("DX",IBCT)=IB(Z)
  1. Q
  1. ;
  1. AUTRF(IBXIEN,IBL,Z) ; returns auth # and referral# if room for both, separated by a space - IB*2.0*432
  1. ; IBXIEN= claim ien
  1. ; IBL = field length-1 to allow for 1 blank space between numbers (28 for CMS 1500, 30 for UB-04)
  1. ; Z = 1 for PRIMARY, 2 for SECONDARY, 3 for TERTIARY
  1. ;
  1. N IBXDATA,IBZ
  1. Q:$G(IBXIEN)="" ""
  1. ; if CMS 1500, find current codes
  1. I $G(Z)="",$G(IBL)=28 S Z=$$COBN^IBCEF(IBXIEN)
  1. Q:$G(Z)="" ""
  1. ; if length not defined, default to shortest
  1. S:IBL="" IBL=28
  1. D F^IBCEF("N-"_$P("PRIMARY^SECONDARY^TERTIARY",U,Z)_" AUTH CODE",,,IBXIEN)
  1. D F^IBCEF("N-"_$P("PRIMARY^SECONDARY^TERTIARY",U,Z)_" REFERRAL NUMBER","IBZ",,IBXIEN)
  1. ; if length of auth and referral combined is too long, only return auth code
  1. Q $S(IBZ="":IBXDATA,IBXDATA="":IBZ,$L(IBXDATA)+$L(IBZ)>IBL:IBXDATA,1:IBXDATA_" "_IBZ)
  1. ;
  1. GRPNAME(IBIEN,IBXDATA) ; Populate IBXDATA with the Group Name(s).
  1. ; MRD;IB*2.0*516 - Created this procedure as extract code for
  1. ; ^IBA(364.5,199), N-ALL INSURANCE GROUP NAME.
  1. N A,Z
  1. F Z=1:1:3 I $D(^DGCR(399,IBIEN,"I"_Z)) D
  1. . S IBXDATA(Z)=$$POLICY^IBCEF(IBIEN,15,Z) I IBXDATA(Z)'="" Q
  1. . S A=$$POLICY^IBCEF(IBIEN,1,Z) ; Pull piece 1, Ins. Type.
  1. . I A'="" S IBXDATA(Z)=$P($G(^DIC(36,+A,0)),U)
  1. . Q
  1. Q
  1. ;
  1. GRPNUM(IBXIEN,IBXDATA) ; Populate IBXDATA with the Group Number(s).
  1. ; MRD;IB*2.0*516 - Created this procedure as extract code for
  1. ; ^IBA(364.5,200), N-ALL INSURANCE GROUP NUMBER.
  1. N Z
  1. F Z=1:1:3 I $D(^DGCR(399,IBXIEN,"I"_Z)) S IBXDATA(Z)=$$POLICY^IBCEF(IBXIEN,3,Z)
  1. Q
  1. ;
  1. CMNDATA(IBXIEN,IBPROC,FLD,INT) ;JRA;IB*2.0*608 Return data for specified Certificate of Medical Necessity (CMN) field.
  1. ;Created to return data for a specific CMN field, which is a subfield of file 399, field 304 (Procedure). Returns data
  1. ; in External format by default.
  1. ;
  1. ;Input: IBXIEN = Internal bill/claim number
  1. ; IBPROC = Procedure # (subscript in ^DGCR)
  1. ; FLD = Field number of desired field
  1. ; INT = Flag set to 'I' if the subfield's Internal value is to be returned (optional)
  1. ;
  1. ;Output: VAL = External (or optionally Internal) value of the CMN subfield specified by FLD
  1. ;
  1. Q:('$G(IBXIEN)!('$G(FLD)!('$G(IBPROC)))) ""
  1. S INT=$G(INT)
  1. N ND,VAL,X
  1. S ND=IBPROC_","_IBXIEN
  1. S VAL=$$GET1^DIQ(399.0304,ND,FLD,INT)
  1. Q VAL
  1. ;
  1. CMNDEX(IBXIEN,IBXSAVE) ;JRA;IB*2.0*608 Data Extract for LQ, CMN and MEA segments
  1. Q:'$G(IBXIEN)
  1. ;
  1. N CMNREQ,ND,X,IBXDATA
  1. ;Get Procedure Links for all Procedures on the claim.
  1. D OUTPT^IBCEF11(IBXIEN,0) Q:'$D(IBXDATA)
  1. N LP,Z,CNT
  1. S LP=0 F S LP=$O(IBXDATA(LP)) Q:'+LP D
  1. . S CNT=$G(CNT)+1
  1. . Q:'$D(IBXDATA(LP,"CPLNK"))
  1. . S ND=IBXDATA(LP,"CPLNK")
  1. . S ND=ND_","_IBXIEN_","
  1. . S CMNREQ=$$GET1^DIQ(399.0304,ND,23,"I")
  1. . S:CMNREQ="" CMNREQ=0
  1. . Q:'+CMNREQ
  1. . S Z=$G(Z)+1
  1. . S IBXSAVE("CMNDEX",Z)=IBXDATA(LP,"CPLNK")_U_CNT
  1. Q
  1. ;
  1. FRM(IBXIEN,IBXSAVE) ;JRA;IB*2.0*608 Data Extract for FRM segment
  1. Q:'$G(IBXIEN)
  1. ;
  1. N CMNREQ,CNT,DEL,IBXDATA,LP,ND,PAIRQ,QUIT,RESPTYP,X,Z,Z1
  1. ;Get Procedure Data for all Procedures on the claim.
  1. D OUTPT^IBCEF11(IBXIEN,0) Q:'$D(IBXDATA)
  1. S LP=0 F S LP=$O(IBXDATA(LP)) Q:'+LP D
  1. . Q:'$D(IBXDATA(LP,"CPLNK"))
  1. . S CNT=$G(CNT)+1
  1. . S ND=IBXDATA(LP,"CPLNK")
  1. . S ND=ND_","_IBXIEN_","
  1. . S CMNREQ=$$GET1^DIQ(399.0304,ND,23,"I")
  1. . S:CMNREQ="" CMNREQ=0
  1. . Q:'+CMNREQ
  1. . S Z=$G(Z)+1
  1. . ;WHAT FORM
  1. . N DATA,FORM,FLD,FLDS,INTEXT,QUES,QUESNUM,X
  1. . S FORM=$TR($$GET1^DIQ(399.0304,ND,"24:3","I"),"-") ; get the form number to figure what fields go with it
  1. . Q:FORM="" ; quit if no form number
  1. . ;
  1. . S FLDS=$P($T(@FORM),";;",2,9999) ; get all the associated data fields from below
  1. . ;
  1. . N PAIREDQA
  1. . ;Parse FLDS to get DD field, question number, type of response (2=Y/N, 3=text/code, 4=date, 5=percent/decimal), and the response data.
  1. . F X=1:1 S QUES=$P(FLDS,"~",X) Q:QUES="" D
  1. .. S FLD=$P(QUES,U)
  1. .. S QUESNUM=$P(QUES,U,2)
  1. .. S RESPTYP=$P(QUES,U,3)
  1. .. I RESPTYP=4 S INTEXT="I"
  1. .. E S INTEXT=$P(QUES,U,4) S:INTEXT="" INTEXT="E"
  1. .. S DATA=$$GET1^DIQ(399.0304,ND,FLD,INTEXT)
  1. .. ;
  1. .. ; KLUDGE; On form CMN10126 If 4A or 3A is blank, don't send the other (which means get rid of the previous Q/A)
  1. .. ; same for 4B/3B
  1. .. I FORM="CMN10126",".3A.3B.4A.4B."[QUESNUM S PAIRQ=0 D Q:PAIRQ
  1. ... I QUESNUM="3A"!(QUESNUM="3B") S PAIREDQA(QUESNUM)=DATA Q
  1. ... I QUESNUM="4A",$G(PAIREDQA("3A"))="" S PAIRQ=1 Q
  1. ... I QUESNUM="4B",$G(PAIREDQA("3B"))="" S PAIRQ=1 Q
  1. ..;
  1. .. Q:DATA="" ;Do not include FRM rec for unanswered questions
  1. .. ;
  1. .. S:RESPTYP=2 DATA=$E(DATA) ; only want Y or N
  1. .. I QUESNUM=4,"YN"'[DATA S DATA="W"
  1. .. S:RESPTYP=4 DATA=$$DT^IBCEFG1(DATA,"","D8") ;YYYYMMDD date format
  1. .. ;Procedure# has a 1 to many ratio with Question# but can't have 2 subscripts so combine into 1, ordering IBXSAVE by Question#.
  1. .. S IBXSAVE("FRM",(Z_"_"_(X/10)))=QUESNUM_U
  1. .. S $P(IBXSAVE("FRM",(Z_"_"_(X/10))),U,RESPTYP)=DATA
  1. .. S $P(IBXSAVE("FRM",(Z_"_"_(X/10))),U,6)=CNT
  1. ;
  1. ;Re-subscript IBXSAVE with sequential integers as current subscript format will not work with Output Formatter.
  1. S (Z,Z1)=0 F S Z=$O(IBXSAVE("FRM",Z)) Q:'Z S Z1=Z1+1,IBXSAVE("FRM",Z1)=IBXSAVE("FRM",Z),DEL(Z)=""
  1. S Z=0 F S Z=$O(DEL(Z)) Q:'Z K IBXSAVE("FRM",Z)
  1. Q
  1. ;
  1. PTWT(IBXIEN) ;JRA;IB*2.0*608 Return CMN Patient Weight from 1st Service Line # that has it (or NULL if none)
  1. Q:'$G(IBXIEN)
  1. N FOUND,IBPROC,IBXSAVE,PTWT
  1. D CMNDEX(IBXIEN,.IBXSAVE)
  1. S (FOUND,Z)=0,PTWT="" F S Z=$O(IBXSAVE("CMNDEX",Z)) Q:Z="" D Q:FOUND
  1. . S IBPROC=+IBXSAVE("CMNDEX",Z) Q:'IBPROC
  1. . S PTWT=$$CMNDATA(IBXIEN,IBPROC,24.03) S:PTWT FOUND=1
  1. Q PTWT
  1. ;
  1. ;JRA;IB*2.0*608 Tags CMN484 & CMN10126 added
  1. ; FIELD#^QUESTION#^RESPONSE_TYPE^INT/EXT
  1. CMN484 ;;24.1^1A^3~24.102^1B^5~24.103^1C^4~24.107^2^3^I~24.108^3^3^I~24.109^4^2^I~24.11^5^3~24.111^6A^3~24.113^6B^5~24.114^6C^4~24.104^7^2~24.105^8^2~24.106^9^2~24.115^C^3
  1. ;
  1. CMN10126 ;;24.201^1^2~24.202^2^2~24.204^3A^3~24.219^3B^3~24.203^4A^3~24.218^4B^3~24.205^5^3^I~24.206^6^3~24.207^7^2~24.208^8A^3~24.209^8B^5~24.21^8C^3~24.211^8D^3~24.212^8E^5~24.213^8F^3~24.215^8G^3~24.216^8H^5~24.214^9^3^I
  1. ;