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 Dec 13, 2024@02:10:03 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 ;
