IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371,447,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
;IBIFN = bill ien throughout this routine
COB(IBIFN) ; Bill seq
N A
S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P"
Q A
;
COBN(IBIFN,A) ; Return seq # of selected payer
; A = 'PST' or null to get current bill payer seq #
I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P"
I 'A S A=$F("PST",A)-1 S:A<1 A=1
Q A
;
POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill
; IBPC = pc # of data element in policy (optional)
; if null, 0-node is returned
; IBCOBN = bill designation 1-3 or 'PST' (optional)
; if null, default to current
N IBI,IBY
I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN))
S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN))
;IB*516/TAZ -
; The I1,I2,I3 nodes of the claim are copies of the zero node insurance
; information from the patient file. Four fields on that node are now
; marked for deletion because their lengths are not HIPAA-compliant.
; The correct values for Name of Insured and Subscriber ID should now
; be pulled from the I17,I27,I37 nodes of the claim. The Group Name
; and Number should come from file 355.3 based on the Plan.
S IBY=$G(^DGCR(399,IBIFN,"I"_IBCOBN_"7")) ; new I7 node - 516 - baa
I $P(IBY,U,1)'="" S $P(IBI,U,17)=$P(IBY,U,1) ; Name of insured long - 516 - baa
I $P(IBY,U,2)'="" S $P(IBI,U,2)=$P(IBY,U,2) ; Subscriber ID long -516 - baa
S IBY=$P(IBI,U,18)
S $P(IBI,U,3)=$$GET1^DIQ(355.3,+IBY_",",2.02) ; Group Number - 516 -taz
S $P(IBI,U,15)=$$GET1^DIQ(355.3,+IBY_",",2.01) ; Group Name - 516 - taz
I $G(IBPC) S IBI=$P(IBI,U,IBPC)
POLICYQ Q IBI
;
INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces:
; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
; STREET ADDRESS 2^STREET ADDRESS 3
; IBIFN = bill ien
; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
; or 1-2-3. If not defined or null, return current
; If insured is patient or spouse, take from patient file top level
; fields, then if top-level street addresses are blank and policy
; level fields are not, use policy level
; If insured is other than patient/spouse, use policy level fields only
N A,B,IBADDR,IBI,DFN,VAPA,VATEST
S:$G(IBCOB)="" IBCOB=""
I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
S IBI=+$$POLICY(IBIFN,16,IBCOB) ; pt relationship to insured
S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
; insured's address (patient/spouse) same as patient's
S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2)
D ADD^VADPT
S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
S A=$G(^DPT(DFN,.312,+A,3))
I $TR($P(IBADDR,U)," ")="" D PI3
I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
Q IBADDR
;
PI3 ; build IBADDR string from patient insurance 3 node data
S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
S $P(IBADDR,U,5,6)=$P(A,U,6,7)
F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
S $P(IBADDR,U,7)="" ; no street address 3 in file 2.312
Q
;
PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
;IBIFN = bill ien
;ELE = subscript in ^UTILITY("VAPA", array for element needed
;
I '$D(^UTILITY("VAPA",$J)) D ; once per pt
.N VAHOW,DFN,VAPA
.S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")=""
.D ADD^VADPT
Q $P($G(^UTILITY("VAPA",$J,ELE)),U)
;
PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics
;IBIFN = bill ien
;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
;PC = pc of string at subscript ELE to be returned
;
I '$G(PC) S PC=1
I '$D(^UTILITY("VADM",$J)) D ; once per pt
.N VAHOW,DFN,VADM
.S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
.D DEM^VADPT
Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC)
;
PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info
;ELE = subscript in VAOA array for employer element needed
;WHOSE = 6 if spouse's info needed 5 if pt info needed (DEFAULT)
;
N DFN
S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5)
D OAD^VADPT
Q $P($G(VAOA(ELE)),U)
;
INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces:
; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
; IBIFN = bill ien
; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
; or 1,2,3 ... if not defined or null, return current
; If insured is patient/spouse, take from patient file top level
; fields, then if top-level are blank and policy level aren't,
; use policy level
; If insured other than patient/spouse, use policy level fields only
N A,B,IBDEM,IBI,DFN,VADM
S:$G(IBCOB)="" IBCOB=""
S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB)
S IBI=$$WHOSINS(IBIFN,IBCOB)
S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1
; If it gets here, assume insured is patient/spouse
S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0)
F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U)
S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U)
I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1
S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2)
I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only
INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
S A=$G(^DPT(DFN,.312,+A,3))
S:"MF"'[$G(VADM(5)) VADM(5)=""
S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12))
S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3)
S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U)
S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11)
S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5)
Q IBDEM
;
INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces:
; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
; or 123 - if not defined or null, return current
N A,IBEMPL,IBI,DFN,VAOA
S IBI=$$WHOSINS(IBIFN,$G(IBCOB))
I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ
; insured = pt/spouse
S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
INSEMPQ Q IBEMPL
;
WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and
; seq of coverage COB (123 or PST) or if not defined or null, current
N Z,Z0,VAEL,DFN
S Z=+$$POLICY(IBIFN,16,$G(IBCOB))
I 'Z D
.S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
.I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q ;vet is pt
.I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q ;vet is pt, so vets spouse is pt's spouse
.S Z=9 ; relationship of insured to pt unknown
Q Z
;
EMPSTAT(IBIFN,WHOSE) ;Return employment status
; IBIFN = bill ien
; WHOSE = v for vet, s for spouse status
N STAT,DFN,VAPD
S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U)
I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15)
I STAT="" S STAT=9
Q STAT
;
INPAT(IBIFN,OUT) ; Determine if bill is inpatient
; OUT = optional - if 1, return output value based on
; inpatient/outpatient from UB-04 type of bill field
; Return 1 if inpatient, 0 if not inpatient or can't be determined
N INPT,CODE,CODE0,IB0
S IB0=$G(^DGCR(399,IBIFN,0))
S OUT=+$G(OUT),CODE=+$P(IB0,U,5)
I 'OUT S INPT=CODE
I OUT D
. S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
. I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q ; 18X
. I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q ; 89X
. I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q ; 81X
. I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q ; 71X
. I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q ; 72X
. S INPT=CODE0
Q $S(INPT:INPT'>2,1:0)
;
INSPRF(IBIFN) ; Function to determine if bill is prof or inst
; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
N A
S A=$G(^DGCR(399,IBIFN,0))
I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0)
Q $S($P(A,U,27)=1:1,1:0)
;
F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN
; If IBXDATA array to be returned as data value(s) of fld
; D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME")
; Variable ref-ed by IBXERR1 will contain error message if an error
; @IBXRET always defined on return. It will be null if error
I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN
I $G(IBXERR1)="" S IBXERR1="IBXERR"
N IBXHOLD
S IBXHOLD=""
I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET"
S @IBXERR1=""
;
N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
;
I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ
I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ
.F S FLD=$O(^IBA(364.5,"B",FLD)) D Q:STOP
..I $E(FLD,1,$L(OFLD))'=OFLD S FLD=""
..S STOP=1
;
S Z=0
F S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q
I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ
;
S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
;
I $G(IBXERR2)'="" S @IBXERR1=IBXERR2
FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q
;
I IBXHOLD="IBXDATA" S IBXRET="IBXRET"
M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1)
S:'($D(@IBXARRY)#2) @IBXARRY=""
Q
;
SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for
; outpatient/UB-04 lines or X12-837 institutional lines
; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
; 0 = external (MMDDYY or MMDDYYYY)
N IBZ
G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500
S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT)
D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
I '$G(IBZ)!(FORMAT=2) G SERVDTQ
;
I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ
S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1)
;
SERVDTQ Q $G(IBZ)
;
NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
; SPACE = flag if 1 strip SPACES
; EXC = list of punctuation not to strip
;
N PUNCT,Z
S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
I $G(SPACE) S PUNCT=PUNCT_" "
I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z))
S X=$TR(X,PUNCT)
Q X
;
FT(IBIFN) ; Internal code for bill form type
Q +$P($G(^DGCR(399,IBIFN,0)),U,19)
;
COBCT(IBIFN) ; # of payers on claim
N CT,Z
S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z)) S CT=CT+1
Q CT
;
INSTOUT(IBIFN) ; Identify a Outpatient Institutional Claim. IB*2.0*447 BI
; Return a 1 if claim/bill is Institutional and Outpatient, otherwise return 0.
Q (($$INPAT^IBCEF(IBIFN)=0)&($$INSPRF^IBCEF(IBIFN)=1))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF 11039 printed Dec 13, 2024@02:09:56 Page 2
IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371,447,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;IBIFN = bill ien throughout this routine
COB(IBIFN) ; Bill seq
+1 NEW A
+2 SET A=$PIECE($GET(^DGCR(399,IBIFN,0)),U,21)
if A=""
SET A="P"
+3 QUIT A
+4 ;
COBN(IBIFN,A) ; Return seq # of selected payer
+1 ; A = 'PST' or null to get current bill payer seq #
+2 IF $GET(A)=""
SET A=$$COB(IBIFN)
if "PST"'[A
SET A="P"
+3 IF 'A
SET A=$FIND("PST",A)-1
if A<1
SET A=1
+4 QUIT A
+5 ;
POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill
+1 ; IBPC = pc # of data element in policy (optional)
+2 ; if null, 0-node is returned
+3 ; IBCOBN = bill designation 1-3 or 'PST' (optional)
+4 ; if null, default to current
+5 NEW IBI,IBY
+6 IF "PST"[$GET(IBCOBN)
SET IBCOBN=$$COBN(IBIFN,$GET(IBCOBN))
+7 SET IBI=$GET(^DGCR(399,IBIFN,"I"_IBCOBN))
+8 ;IB*516/TAZ -
+9 ; The I1,I2,I3 nodes of the claim are copies of the zero node insurance
+10 ; information from the patient file. Four fields on that node are now
+11 ; marked for deletion because their lengths are not HIPAA-compliant.
+12 ; The correct values for Name of Insured and Subscriber ID should now
+13 ; be pulled from the I17,I27,I37 nodes of the claim. The Group Name
+14 ; and Number should come from file 355.3 based on the Plan.
+15 ; new I7 node - 516 - baa
SET IBY=$GET(^DGCR(399,IBIFN,"I"_IBCOBN_"7"))
+16 ; Name of insured long - 516 - baa
IF $PIECE(IBY,U,1)'=""
SET $PIECE(IBI,U,17)=$PIECE(IBY,U,1)
+17 ; Subscriber ID long -516 - baa
IF $PIECE(IBY,U,2)'=""
SET $PIECE(IBI,U,2)=$PIECE(IBY,U,2)
+18 SET IBY=$PIECE(IBI,U,18)
+19 ; Group Number - 516 -taz
SET $PIECE(IBI,U,3)=$$GET1^DIQ(355.3,+IBY_",",2.02)
+20 ; Group Name - 516 - taz
SET $PIECE(IBI,U,15)=$$GET1^DIQ(355.3,+IBY_",",2.01)
+21 IF $GET(IBPC)
SET IBI=$PIECE(IBI,U,IBPC)
POLICYQ QUIT IBI
+1 ;
INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces:
+1 ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
+2 ; STREET ADDRESS 2^STREET ADDRESS 3
+3 ; IBIFN = bill ien
+4 ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
+5 ; or 1-2-3. If not defined or null, return current
+6 ; If insured is patient or spouse, take from patient file top level
+7 ; fields, then if top-level street addresses are blank and policy
+8 ; level fields are not, use policy level
+9 ; If insured is other than patient/spouse, use policy level fields only
+10 NEW A,B,IBADDR,IBI,DFN,VAPA,VATEST
+11 if $GET(IBCOB)=""
SET IBCOB=""
+12 IF 'IBCOB
SET IBCOB=$$COBN(IBIFN,$GET(IBCOB))
+13 ; pt relationship to insured
SET IBI=+$$POLICY(IBIFN,16,IBCOB)
+14 SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+15 IF $SELECT('IBI:1,1:"12"'[IBI)
SET IBADDR=""
GOTO INSADDQ
+16 ; insured's address (patient/spouse) same as patient's
+17 SET VATEST("ADD",9)=+$GET(^DGCR(399,IBIFN,"U"))
SET VATEST("ADD",10)=+$PIECE($GET(^("U")),U,2)
+18 DO ADD^VADPT
+19 SET IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$PIECE($GET(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
INSADDQ SET A=$PIECE($GET(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
+1 SET A=$GET(^DPT(DFN,.312,+A,3))
+2 IF $TRANSLATE($PIECE(IBADDR,U)," ")=""
DO PI3
+3 IF IBI=2
IF $$NOPUNCT($PIECE(A,U,6,10),1)'=""
DO PI3
+4 QUIT IBADDR
+5 ;
PI3 ; build IBADDR string from patient insurance 3 node data
+1 SET $PIECE(IBADDR,U,1)=$PIECE(A,U,6)_" "_$PIECE(A,U,7)
+2 SET $PIECE(IBADDR,U,5,6)=$PIECE(A,U,6,7)
+3 FOR B=2,4
SET $PIECE(IBADDR,U,B)=$PIECE(A,U,B+6)
+4 SET $PIECE(IBADDR,U,3)=$PIECE($GET(^DIC(5,+$PIECE(A,U,9),0)),U,2)
+5 ; no street address 3 in file 2.312
SET $PIECE(IBADDR,U,7)=""
+6 QUIT
+7 ;
PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
+1 ;IBIFN = bill ien
+2 ;ELE = subscript in ^UTILITY("VAPA", array for element needed
+3 ;
+4 ; once per pt
IF '$DATA(^UTILITY("VAPA",$JOB))
Begin DoDot:1
+5 NEW VAHOW,DFN,VAPA
+6 SET VAHOW=2
SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
SET VAPA("P")=""
+7 DO ADD^VADPT
End DoDot:1
+8 QUIT $PIECE($GET(^UTILITY("VAPA",$JOB,ELE)),U)
+9 ;
PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics
+1 ;IBIFN = bill ien
+2 ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
+3 ;PC = pc of string at subscript ELE to be returned
+4 ;
+5 IF '$GET(PC)
SET PC=1
+6 ; once per pt
IF '$DATA(^UTILITY("VADM",$JOB))
Begin DoDot:1
+7 NEW VAHOW,DFN,VADM
+8 SET VAHOW=2
SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+9 DO DEM^VADPT
End DoDot:1
+10 QUIT $PIECE($GET(^UTILITY("VADM",$JOB,ELE)),U,PC)
+11 ;
PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info
+1 ;ELE = subscript in VAOA array for employer element needed
+2 ;WHOSE = 6 if spouse's info needed 5 if pt info needed (DEFAULT)
+3 ;
+4 NEW DFN
+5 SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
SET VAOA("A")=$SELECT($GET(WHOSE):WHOSE,1:5)
+6 DO OAD^VADPT
+7 QUIT $PIECE($GET(VAOA(ELE)),U)
+8 ;
INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces:
+1 ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
+2 ; IBIFN = bill ien
+3 ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
+4 ; or 1,2,3 ... if not defined or null, return current
+5 ; If insured is patient/spouse, take from patient file top level
+6 ; fields, then if top-level are blank and policy level aren't,
+7 ; use policy level
+8 ; If insured other than patient/spouse, use policy level fields only
+9 NEW A,B,IBDEM,IBI,DFN,VADM
+10 if $GET(IBCOB)=""
SET IBCOB=""
+11 if 'IBCOB
SET IBCOB=$$COBN(IBIFN,IBCOB)
+12 SET IBI=$$WHOSINS(IBIFN,IBCOB)
+13 SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+14 IF $SELECT('IBI:1,1:"12"'[IBI)
SET IBDEM=""
GOTO INSDEM1
+15 ; If it gets here, assume insured is patient/spouse
+16 SET A=$$PTDEM(IBIFN,0)
SET A=$$PTADDR(IBIFN,0)
+17 FOR A=2,3,5
SET VADM(A)=$PIECE($GET(^UTILITY("VADM",$JOB,A)),U)
+18 SET VAPA(8)=$PIECE($GET(^UTILITY("VAPA",$JOB,8)),U)
+19 IF VADM(5)=""
IF 'VADM(3)
IF VAPA(8)=""
SET IBDEM=""
GOTO INSDEM1
+20 SET $PIECE(IBDEM,U,3)=VAPA(8)
SET $PIECE(IBDEM,U,6)=VADM(2)
+21 ;Patient's own policy only
IF IBI=1
IF VADM(3)
SET $PIECE(IBDEM,U)=VADM(3)
INSDEM1 SET A=$PIECE($GET(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
+1 SET A=$GET(^DPT(DFN,.312,+A,3))
+2 if "MF"'[$GET(VADM(5))
SET VADM(5)=""
+3 SET $PIECE(IBDEM,U,2)=$SELECT(IBI=1:VADM(5),1:$PIECE(A,U,12))
+4 SET $PIECE(IBDEM,U,4,5)=$PIECE(A,U,2)_U_$PIECE(A,U,3)
+5 if '$PIECE(IBDEM,U)
SET $PIECE(IBDEM,U)=$PIECE(A,U)
+6 if $PIECE(IBDEM,U,3)=""
SET $PIECE(IBDEM,U,3)=$PIECE(A,U,11)
+7 if $PIECE(IBDEM,U,6)=""
SET $PIECE(IBDEM,U,6)=$PIECE(A,U,5)
+8 QUIT IBDEM
+9 ;
INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces:
+1 ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
+2 ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
+3 ; or 123 - if not defined or null, return current
+4 NEW A,IBEMPL,IBI,DFN,VAOA
+5 SET IBI=$$WHOSINS(IBIFN,$GET(IBCOB))
+6 IF $SELECT('IBI:1,1:"12"'[IBI)
SET IBEMPL="^^"
GOTO INSEMPQ
+7 ; insured = pt/spouse
+8 SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+9 SET A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
+10 SET IBEMPL=VAOA(9)_U_VAOA(4)_U_$PIECE($GET(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
INSEMPQ QUIT IBEMPL
+1 ;
WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and
+1 ; seq of coverage COB (123 or PST) or if not defined or null, current
+2 NEW Z,Z0,VAEL,DFN
+3 SET Z=+$$POLICY(IBIFN,16,$GET(IBCOB))
+4 IF 'Z
Begin DoDot:1
+5 SET Z0=$$POLICY(IBIFN,6,$GET(IBCOB))
SET DFN=$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+6 ;vet is pt
IF Z0="v"
DO ELIG^VADPT
IF VAEL(4)
SET Z=1
QUIT
+7 ;vet is pt, so vets spouse is pt's spouse
IF Z0="s"
DO ELIG^VADPT
IF VAEL(4)
SET Z=2
QUIT
+8 ; relationship of insured to pt unknown
SET Z=9
End DoDot:1
+9 QUIT Z
+10 ;
EMPSTAT(IBIFN,WHOSE) ;Return employment status
+1 ; IBIFN = bill ien
+2 ; WHOSE = v for vet, s for spouse status
+3 NEW STAT,DFN,VAPD
+4 SET STAT=""
SET DFN=+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2)
+5 IF WHOSE="v"
DO OPD^VADPT
SET STAT=$PIECE(VAPD(7),U)
+6 IF WHOSE="s"
SET STAT=$PIECE($GET(^DPT(DFN,.25)),U,15)
+7 IF STAT=""
SET STAT=9
+8 QUIT STAT
+9 ;
INPAT(IBIFN,OUT) ; Determine if bill is inpatient
+1 ; OUT = optional - if 1, return output value based on
+2 ; inpatient/outpatient from UB-04 type of bill field
+3 ; Return 1 if inpatient, 0 if not inpatient or can't be determined
+4 NEW INPT,CODE,CODE0,IB0
+5 SET IB0=$GET(^DGCR(399,IBIFN,0))
+6 SET OUT=+$GET(OUT)
SET CODE=+$PIECE(IB0,U,5)
+7 IF 'OUT
SET INPT=CODE
+8 IF OUT
Begin DoDot:1
+9 SET CODE0=$PIECE($GET(^DGCR(399.1,+$PIECE(IB0,U,25),0)),U,2)
+10 ; 18X
IF CODE0=8
IF $PIECE(IB0,U,24)=1
SET INPT=$PIECE(IB0,U,5)
QUIT
+11 ; 89X
IF CODE0=9
IF $PIECE(IB0,U,24)=8
SET INPT=$PIECE(IB0,U,5)
QUIT
+12 ; 81X
IF CODE0=1
IF $PIECE(IB0,U,24)=8
SET INPT=0
QUIT
+13 ; 71X
IF CODE0=1
IF $PIECE(IB0,U,24)=7
SET INPT=0
QUIT
+14 ; 72X
IF CODE0=2
IF $PIECE(IB0,U,24)=7
SET INPT=0
QUIT
+15 SET INPT=CODE0
End DoDot:1
+16 QUIT $SELECT(INPT:INPT'>2,1:0)
+17 ;
INSPRF(IBIFN) ; Function to determine if bill is prof or inst
+1 ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
+2 NEW A
+3 SET A=$GET(^DGCR(399,IBIFN,0))
+4 IF $PIECE(A,U,27)=""
SET $PIECE(A,U,27)=$SELECT($PIECE(A,U,19)=3:1,1:0)
+5 QUIT $SELECT($PIECE(A,U,27)=1:1,1:0)
+6 ;
F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN
+1 ; If IBXDATA array to be returned as data value(s) of fld
+2 ; D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME")
+3 ; Variable ref-ed by IBXERR1 will contain error message if an error
+4 ; @IBXRET always defined on return. It will be null if error
+5 IF $GET(IBIEN)
NEW IBXIEN
SET IBXIEN=IBIEN
+6 IF $GET(IBXERR1)=""
SET IBXERR1="IBXERR"
+7 NEW IBXHOLD
+8 SET IBXHOLD=""
+9 IF $GET(IBXRET)=""!($GET(IBXRET)="IBXDATA")
SET IBXHOLD="IBXDATA"
SET IBXRET="IBXRET"
+10 SET @IBXERR1=""
+11 ;
+12 NEW FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
+13 ;
+14 IF '$GET(IBXIEN)
SET @IBXERR1="Invalid entry #"
GOTO FQ
+15 IF '$DATA(^IBA(364.5,"B",FLD))
SET OFLD=FLD
SET STOP=0
Begin DoDot:1
+16 FOR
SET FLD=$ORDER(^IBA(364.5,"B",FLD))
Begin DoDot:2
+17 IF $EXTRACT(FLD,1,$LENGTH(OFLD))'=OFLD
SET FLD=""
+18 SET STOP=1
End DoDot:2
if STOP
QUIT
End DoDot:1
IF FLD=""
SET @IBXERR1=OFLD_" Field not found!!"
GOTO FQ
+19 ;
+20 SET Z=0
+21 FOR
SET Z=$ORDER(^IBA(364.5,"B",FLD,Z))
if 'Z
QUIT
IF $PIECE($GET(^IBA(364.5,Z,0)),U,5)=399
QUIT
+22 IF 'Z
SET @IBXERR1=FLD_" Field not found!!"
GOTO FQ
+23 ;
+24 SET FLDN(1)=Z
DO EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
+25 ;
+26 IF $GET(IBXERR2)'=""
SET @IBXERR1=IBXERR2
FQ SET IBXARRY=$SELECT(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
+1 IF @IBXERR1'=""
KILL @IBXARRY
SET @IBXARRY=""
QUIT
+2 ;
+3 IF IBXHOLD="IBXDATA"
SET IBXRET="IBXRET"
+4 MERGE IBXRETX=@IBXRET
KILL @IBXARRY
MERGE @IBXARRY=IBXRETX(1)
+5 if '($DATA(@IBXARRY)#2)
SET @IBXARRY=""
+6 QUIT
+7 ;
SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for
+1 ; outpatient/UB-04 lines or X12-837 institutional lines
+2 ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
+3 ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
+4 ; 0 = external (MMDDYY or MMDDYYYY)
+5 NEW IBZ
+6 ;Inpatient claim or billed on a CMS-1500
if $$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3)
GOTO SERVDTQ
+7 SET LENGTH=$GET(LENGTH)
SET FORMAT=$GET(FORMAT)
+8 DO F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
+9 IF '$GET(IBZ)!(FORMAT=2)
GOTO SERVDTQ
+10 ;
+11 IF FORMAT=1
SET IBZ=$$DT^IBCEFG1(IBZ,"",$SELECT(LENGTH'=6:"D8",1:"D6"))
GOTO SERVDTQ
+12 SET IBZ=$$DATE^IBCF2(IBZ,$SELECT(LENGTH=6:0,1:1),1)
+13 ;
SERVDTQ QUIT $GET(IBZ)
+1 ;
NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
+1 ; SPACE = flag if 1 strip SPACES
+2 ; EXC = list of punctuation not to strip
+3 ;
+4 NEW PUNCT,Z
+5 SET PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
+6 IF $GET(SPACE)
SET PUNCT=PUNCT_" "
+7 IF $GET(EXC)'=""
FOR Z=1:1:$LENGTH(EXC)
SET PUNCT=$TRANSLATE(PUNCT,$EXTRACT(EXC,Z))
+8 SET X=$TRANSLATE(X,PUNCT)
+9 QUIT X
+10 ;
FT(IBIFN) ; Internal code for bill form type
+1 QUIT +$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
+2 ;
COBCT(IBIFN) ; # of payers on claim
+1 NEW CT,Z
+2 SET CT=0
FOR Z="I1","I2","I3"
if '$DATA(^DGCR(399,IBIFN,Z))
QUIT
SET CT=CT+1
+3 QUIT CT
+4 ;
INSTOUT(IBIFN) ; Identify a Outpatient Institutional Claim. IB*2.0*447 BI
+1 ; Return a 1 if claim/bill is Institutional and Outpatient, otherwise return 0.
+2 QUIT (($$INPAT^IBCEF(IBIFN)=0)&($$INSPRF^IBCEF(IBIFN)=1))
+3 ;
