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