IBCEF7 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
;;2.0;INTEGRATED BILLING;**232,349,432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
ALLPROV ;called from #364.5 entry "N-ALL CUR/OTH PROVIDER INFO"
;*342/TAZ - Added call to LPRV^IBCEF80 for line level providers; restructured due to line length
I +$G(IBXSAVE("PROVINF",IBXIEN))=0 D
. N IBZ
. D PROVIDER(IBXIEN,"C",.IBZ),PROVIDER(IBXIEN,"O",.IBZ) S IBXSAVE("PROVINF",IBXIEN)=IBXIEN M IBXSAVE("PROVINF",IBXIEN)=IBZ
Q
;for PRV1
;Input:
; IB399 ien of #399
PRV1(IB399) ;
N IBN,IBZ,IBZ1,IBZN,IBZD,IBRES,IBIND,IBDEF,IBDEFTYP,IBQ,IBFRMTYP,IBZNAME
S IBFRMTYP=+$$FT^IBCEF(IB399)
S IBN=0,IBIND=0,IBRES="",IBQ=0
S IBDEF=$P($G(^DGCR(399,IB399,"M1")),U,$$COBN^IBCEF(IB399)+1),IBDEFTYP=""
I IBDEF'="" S IBDEFTYP=$$SOP^IBCEP2B(IB399,"")
;JRA IB*2.0*592 Treat new Dental form 7 (J430D)
;I IBDEFTYP'="",$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0 S (IBDEF,IBDEFTYP)="" ;JRA IB*2.0*592 ';'
I IBDEFTYP'="",$$CHCKPRV1^IBCEF73($S(IBFRMTYP=7:7,IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0 S (IBDEF,IBDEFTYP)="" ;JRA IB*2.0*592
I IBDEF'="",IBDEFTYP'="" S IBIND=IBIND+2,$P(IBRES,U,IBIND)=(IBDEFTYP_U_IBDEF)
F S IBN=$O(^IBE(355.97,IBN)) Q:+IBN=0!(IBQ=1) D
. S IBZ=$G(^IBE(355.97,IBN,0)),IBZ1=$G(^(1))
. Q:$P(IBZ,"^",4)=""!$P(IBZ1,U,9) ;if no FACILITY'S DEFAULT ID #
. Q:$P(IBZ1,"^",4)!(IBDEFTYP=$P(IBZ,U,3))
. S IBZN=$P(IBZ,"^",3),IBZNAME=$P(IBZ,"^",1)
. ;I IBFRMTYP=2 Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500 ;JRA IB*2.0*592 ';'
. I IBFRMTYP=2!(IBFRMTYP=7) Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500 or J430D ;JRA IB*2.0*592
. I IBFRMTYP=3 Q:IBZN="1B"!(IBZNAME="MEDICARE PART B") ;UB
. ;Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0 ;JRA IB*2.0*592 ';'
. Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=7:7,IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0 ;JRA IB*2.0*592
. I $P(IBZ,"^",2)=0!($P(IBZ,"^",2)=2) D
. . S IBIND=IBIND+2
. . I IBIND>14 S IBQ=1 Q
. . S $P(IBRES,"^",IBIND)=IBZN_"^"_$P(IBZ,"^",4)
;Remove any duplicate entries
N I,Q,QUAL,QUALC,IBRESTMP,SEQ
F I=2:2:($L(IBRES,"^")-1) D
. S QUAL=$P(IBRES,"^",I)
. I $G(IBRESTMP(QUAL))="" S IBRESTMP(QUAL)=$P(IBRES,"^",(I+1))
S Q=2
S I="",QUAL=""
K IBRES
S IBRES=""
S SEQ=0
F S QUAL=$O(IBRESTMP(QUAL)) Q:QUAL="" D
. S SEQ=SEQ+2
. S $P(IBRES,"^",SEQ)=QUAL,$P(IBRES,"^",(SEQ+1))=IBRESTMP(QUAL)
Q IBRES
;
; creates array of SUBSCR IDs for all "other insurances"
;Input :
; IBXIEN - ien in #399
;Output:
; IBZOUT(Z) - array with ien of #36
OTHSBID(IBXIEN,IBZOUT) ;
N Z,Z0,Z1,IBZ,C
D F^IBCEF("N-ALL INSURANCE CO 837 ID","IBZ")
F Z=1,2,3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,2,$E("PST",Z))
K IBXDATA
S C=$$OTHINS1^IBCEF2(IBXIEN)
F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
. S IBZOUT(Z)=IBZ(+$E(C,Z))
Q
;Input :
; IBXIEN - ien in #399
; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
;Output:
; IBARR - output array m by reference
ELMADD2(IBXIEN,IBP,IBARR) ;
N IBZZZ,A,CHECK,IB1
I '$D(IBXSAVE("OTH_INSURED_ADDR")) D OTHADD2(IBXIEN,.IBZZZ) M IBXSAVE("OTH_INSURED_ADDR")=IBZZZ
S IB1=0
F S IB1=$O(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q:'IB1 D
. ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
. S CHECK=0
. F A=1,3,4,5 I $P(IBXSAVE("OTH_INSURED_ADDR",IB1),"|",A)="" S CHECK=1 K IBXSAVE("OTH_INSURED_ADDR",IB1) Q
. I 'CHECK D
. . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q
. . S IBARR(IB1)=$P($G(IBXSAVE("OTH_INSURED_ADDR",IB1)),"|",IBP)
Q
;creates an array with address info for all other insured persons
;Input :
; IBXIEN - ien in #399
;Output:
; IBZOUT(Z) - array with STR LINE1|STR LINE2|CITY|STATE|ZIP
OTHADD2(IBXIEN,IBZOUT) ;
N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBDFN1
S IBZOUT=""
D OTHP36^IBCEF72(IBXIEN,.IBZ) ;array with iens of file #36
K IBXDATA
S C=$$OTHINS1^IBCEF2(IBXIEN)
F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
. S IBINS=+IBZ(+$E(C,Z))
. S IBDFN1=$P($G(^DGCR(399,IBXIEN,0)),"^",2)
. S IBZOUT(Z)=$$FR2PAT(IBDFN1,IBINS)
Q
;Input:
; IBDFN-patient ien
; IBINS - input array with insurance pointers to 36
;Output
; STR LINE1|STR LINE2|CITY|STATE|ZIP
FR2PAT(IBDFN,IBINS) ;information about "other insured" address
N Z3,Z4,Z5,IBZIP
S Z3=$O(^DPT(IBDFN,.312,"B",$G(IBINS),0))
Q:+Z3=0 "||||"
S Z4=$G(^DPT(IBDFN,.312,Z3,3))
S IBZIP=$P($G(^DIC(5,+$P(Z4,"^",9),0)),"^",2)
S Z5=$P(Z4,"^",6,8)_"^"_IBZIP_"^"_$P(Z4,"^",10)
Q $TR(Z5,"^","|")
;
;Input :
; IBXIEN - ien in #399
; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
; if IBP=0 then returns whole string
;Output:
; IBARR - output array m by reference
ELMADDR(IBXIEN,IBP,IBARR) ;
N IB1,A,CHECK
D:'$D(IBXSAVE("OTH_PROV_ADDR")) OTHADDR(IBXIEN)
S IB1=0
F S IB1=$O(IBXSAVE("OTH_PROV_ADDR",IB1)) Q:'IB1 D
. S CHECK=0
. ;EXCLUDE ADD LINE 2 SECOND PC SINCE IT'S OK FOR THAT TO BE EMPTY
. F A=1,3,4,5 I $P(IBXSAVE("OTH_PROV_ADDR",IB1),"|",A)="" D Q
. . ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
. . S CHECK=1 K IBXSAVE("OTH_PROV_ADDR",IB1)
. I 'CHECK D
. . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_PROV_ADDR",IB1)) Q
. . S IBARR(IB1)=$P($G(IBXSAVE("OTH_PROV_ADDR",IB1)),"|",IBP)
Q
;
;creates an array with address info for all insurances
;Input :
; IBXIEN - ien in #399
;Output:
; IBXSAVE("OTH_PROV_ADDR",Z)
OTHADDR(IBXIEN) ;
N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBINS
D F^IBCEF("N-OTH INSURANCE CO IEN 36") ;array with iens of file #36
M IBZ=IBXDATA
K IBXDATA
S C=$$OTHINS1^IBCEF2(IBXIEN)
F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
. S IBINS=+IBZ(+$E(C,Z))
. S IBZIP=$P($G(^DIC(5,+$P($G(^DIC(36,IBINS,.11)),"^",5),0)),"^",2)
. S IB1=$P($G(^DIC(36,IBINS,.11)),"^",1,2)_"^"_$P($G(^DIC(36,IBINS,.11)),"^",4)_"^"_IBZIP_"^"_$P($G(^DIC(36,IBINS,.11)),"^",6)
. S IBXSAVE("OTH_PROV_ADDR",Z)=$TR(IB1,"^","|")
Q
;
;Retrieves pointer to get info about the service provider
;IBIEN399 - ien in #399
;IBFUNC -function (3-RENDERING,etc)
;Output: VARIABLE POINTER (PTR;file_root)
PROVPTR(IBIEN399,IBFUNC) ;
;*432/TAZ - No longer used for IBXSAVE array setup
N IBN
S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
I +IBN=0 Q 0
Q $P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",2)
;
;Retrieves SSN from #200
;IBPTR- VARIABLE POINTER to #200
PROVSSN(IBIEN399) ;
N IBRETVAL S IBRETVAL=""
N IBPTR,IBFT
F IBFT=1:1:9 D
. S IBPTR=$$PROVPTR(IBIEN399,IBFT)
. S $P(IBRETVAL,"^",IBFT)=$$GETSSN^IBCEF72(IBPTR)
Q IBRETVAL
;
;Input:
; IBPTR- ptr to ^VA(200 or ^IBA(355.93
;Output:
; SSN or null
GETNMEL(IBFULL,IBEL) ;Get name element
D NAMECOMP^XLFNAME(.IBFULL)
Q $G(IBFULL(IBEL))
;-
;PROVIDER
;Input:
; IB399 - ien of #399
; IBPROV:
; "C"- to get info for CURRENT provider
; "O"- to get info for all others (in this case the array will contain info fot two providers
; IBRES - array for results (by reference)
;
;Output:
; IBRES - array to get back info (by reference)
; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
; where:
; IBPROV - see input parameter
; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
; PRTYPE: Provider type(FUNCTION)
; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
; PROV : provider/VARIABLEPTR
; INSUR: Insurance PTR #36 or NONE
; IDTYPE: ID type
; ID: ID
; FORMTYP: Form type 1=UB,2=1500
; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
PROVIDER(IB399,IBPROV,IBRES) ;
N IBCURR,IBZ,IBRESARR
S IBRESARR=""
S IBCURR=$$COB^IBCEF(IB399) ;current bill payer sequence
Q:IBPROV="A" ;PATIENT's bill
I IBPROV="C" D
. D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV)
I IBPROV="O" D
. I IBCURR="P" D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV)
. I IBCURR="S" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV)
. I IBCURR="T" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV)
M IBRES(IBPROV)=IBRESARR
Q
;
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
D PROVINF^IBCEF74(IB399,IBPRNUM,.IBRES,IBSORT,IBINSTP)
Q
;
PSPRV(IBIFN) ; Returns information for bill ien IBIFN for purchased svc
; Returns 4 digit data in following format:
; 1st digit: 0 if not outside facility
; 1 if outside facility
; 2nd digit: 0 if not non-VA provider for rendering/attending
; 1 if non-VA provider for rendering/attending
; 3rd digit: 0 if not purchased svc
; 1 if purchased svc
; 4th digit: 0 if 1500 bill
; 1 if UB bill
N IBSVC,Z,Z0,IBU2
S IBSVC="000"_+$$INSFT^IBCEU5(IBIFN),IBU2=$G(^DGCR(399,IBIFN,"U2"))
I $P(IBU2,U,10) S $E(IBSVC,1)=1 ; NON-VA FACILITY
S Z=($$FT^IBCEF(IBIFN)=3)+3,Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
I $P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,2)["IBA(355.93" S $E(IBSVC,2)=1
I $P(IBU2,U,11)>0,$P(IBU2,U,11)'>2 S $E(IBSVC,3)=1
PSPRVQ Q IBSVC
;
CHKADD ;CHECK ALL ADDRESS ELEMENTS PRESENT IF NOT KILL ALL ADDRESS ELEMENTS
;EXPECT IBXSAVE("CADR") AS SOURCE ARRAY
N Z,CHECK
S Z="",CHECK=0
F Z=1,4,5,6 D
. I $P($G(IBXSAVE("CADR")),"^",Z)="" S CHECK=1
I CHECK=1 S IBXSAVE("CADR")=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF7 9566 printed Oct 16, 2024@18:10:51 Page 2
IBCEF7 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
+1 ;;2.0;INTEGRATED BILLING;**232,349,432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ALLPROV ;called from #364.5 entry "N-ALL CUR/OTH PROVIDER INFO"
+1 ;*342/TAZ - Added call to LPRV^IBCEF80 for line level providers; restructured due to line length
+2 IF +$GET(IBXSAVE("PROVINF",IBXIEN))=0
Begin DoDot:1
+3 NEW IBZ
+4 DO PROVIDER(IBXIEN,"C",.IBZ)
DO PROVIDER(IBXIEN,"O",.IBZ)
SET IBXSAVE("PROVINF",IBXIEN)=IBXIEN
MERGE IBXSAVE("PROVINF",IBXIEN)=IBZ
End DoDot:1
+5 QUIT
+6 ;for PRV1
+7 ;Input:
+8 ; IB399 ien of #399
PRV1(IB399) ;
+1 NEW IBN,IBZ,IBZ1,IBZN,IBZD,IBRES,IBIND,IBDEF,IBDEFTYP,IBQ,IBFRMTYP,IBZNAME
+2 SET IBFRMTYP=+$$FT^IBCEF(IB399)
+3 SET IBN=0
SET IBIND=0
SET IBRES=""
SET IBQ=0
+4 SET IBDEF=$PIECE($GET(^DGCR(399,IB399,"M1")),U,$$COBN^IBCEF(IB399)+1)
SET IBDEFTYP=""
+5 IF IBDEF'=""
SET IBDEFTYP=$$SOP^IBCEP2B(IB399,"")
+6 ;JRA IB*2.0*592 Treat new Dental form 7 (J430D)
+7 ;I IBDEFTYP'="",$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0 S (IBDEF,IBDEFTYP)="" ;JRA IB*2.0*592 ';'
+8 ;JRA IB*2.0*592
IF IBDEFTYP'=""
IF $$CHCKPRV1^IBCEF73($SELECT(IBFRMTYP=7:7,IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0
SET (IBDEF,IBDEFTYP)=""
+9 IF IBDEF'=""
IF IBDEFTYP'=""
SET IBIND=IBIND+2
SET $PIECE(IBRES,U,IBIND)=(IBDEFTYP_U_IBDEF)
+10 FOR
SET IBN=$ORDER(^IBE(355.97,IBN))
if +IBN=0!(IBQ=1)
QUIT
Begin DoDot:1
+11 SET IBZ=$GET(^IBE(355.97,IBN,0))
SET IBZ1=$GET(^(1))
+12 ;if no FACILITY'S DEFAULT ID #
if $PIECE(IBZ,"^",4)=""!$PIECE(IBZ1,U,9)
QUIT
+13 if $PIECE(IBZ1,"^",4)!(IBDEFTYP=$PIECE(IBZ,U,3))
QUIT
+14 SET IBZN=$PIECE(IBZ,"^",3)
SET IBZNAME=$PIECE(IBZ,"^",1)
+15 ;I IBFRMTYP=2 Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500 ;JRA IB*2.0*592 ';'
+16 ;1500 or J430D ;JRA IB*2.0*592
IF IBFRMTYP=2!(IBFRMTYP=7)
if IBZN="1A"!(IBZNAME="MEDICARE PART A")
QUIT
+17 ;UB
IF IBFRMTYP=3
if IBZN="1B"!(IBZNAME="MEDICARE PART B")
QUIT
+18 ;Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0 ;JRA IB*2.0*592 ';'
+19 ;JRA IB*2.0*592
if $$CHCKPRV1^IBCEF73($SELECT(IBFRMTYP=7
QUIT
+20 IF $PIECE(IBZ,"^",2)=0!($PIECE(IBZ,"^",2)=2)
Begin DoDot:2
+21 SET IBIND=IBIND+2
+22 IF IBIND>14
SET IBQ=1
QUIT
+23 SET $PIECE(IBRES,"^",IBIND)=IBZN_"^"_$PIECE(IBZ,"^",4)
End DoDot:2
End DoDot:1
+24 ;Remove any duplicate entries
+25 NEW I,Q,QUAL,QUALC,IBRESTMP,SEQ
+26 FOR I=2:2:($LENGTH(IBRES,"^")-1)
Begin DoDot:1
+27 SET QUAL=$PIECE(IBRES,"^",I)
+28 IF $GET(IBRESTMP(QUAL))=""
SET IBRESTMP(QUAL)=$PIECE(IBRES,"^",(I+1))
End DoDot:1
+29 SET Q=2
+30 SET I=""
SET QUAL=""
+31 KILL IBRES
+32 SET IBRES=""
+33 SET SEQ=0
+34 FOR
SET QUAL=$ORDER(IBRESTMP(QUAL))
if QUAL=""
QUIT
Begin DoDot:1
+35 SET SEQ=SEQ+2
+36 SET $PIECE(IBRES,"^",SEQ)=QUAL
SET $PIECE(IBRES,"^",(SEQ+1))=IBRESTMP(QUAL)
End DoDot:1
+37 QUIT IBRES
+38 ;
+39 ; creates array of SUBSCR IDs for all "other insurances"
+40 ;Input :
+41 ; IBXIEN - ien in #399
+42 ;Output:
+43 ; IBZOUT(Z) - array with ien of #36
OTHSBID(IBXIEN,IBZOUT) ;
+1 NEW Z,Z0,Z1,IBZ,C
+2 DO F^IBCEF("N-ALL INSURANCE CO 837 ID","IBZ")
+3 FOR Z=1,2,3
SET IBZ(Z)=$$POLICY^IBCEF(IBXIEN,2,$EXTRACT("PST",Z))
+4 KILL IBXDATA
+5 SET C=$$OTHINS1^IBCEF2(IBXIEN)
+6 FOR Z=1,2
IF $GET(IBZ(Z))'=""
IF $EXTRACT(C,Z)
Begin DoDot:1
+7 SET IBZOUT(Z)=IBZ(+$EXTRACT(C,Z))
End DoDot:1
+8 QUIT
+9 ;Input :
+10 ; IBXIEN - ien in #399
+11 ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
+12 ;Output:
+13 ; IBARR - output array m by reference
ELMADD2(IBXIEN,IBP,IBARR) ;
+1 NEW IBZZZ,A,CHECK,IB1
+2 IF '$DATA(IBXSAVE("OTH_INSURED_ADDR"))
DO OTHADD2(IBXIEN,.IBZZZ)
MERGE IBXSAVE("OTH_INSURED_ADDR")=IBZZZ
+3 SET IB1=0
+4 FOR
SET IB1=$ORDER(IBXSAVE("OTH_INSURED_ADDR",IB1))
if 'IB1
QUIT
Begin DoDot:1
+5 ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
+6 SET CHECK=0
+7 FOR A=1,3,4,5
IF $PIECE(IBXSAVE("OTH_INSURED_ADDR",IB1),"|",A)=""
SET CHECK=1
KILL IBXSAVE("OTH_INSURED_ADDR",IB1)
QUIT
+8 IF 'CHECK
Begin DoDot:2
+9 IF IBP=0
SET IBARR(IB1)=$GET(IBXSAVE("OTH_INSURED_ADDR",IB1))
QUIT
+10 SET IBARR(IB1)=$PIECE($GET(IBXSAVE("OTH_INSURED_ADDR",IB1)),"|",IBP)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;creates an array with address info for all other insured persons
+13 ;Input :
+14 ; IBXIEN - ien in #399
+15 ;Output:
+16 ; IBZOUT(Z) - array with STR LINE1|STR LINE2|CITY|STATE|ZIP
OTHADD2(IBXIEN,IBZOUT) ;
+1 NEW C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBDFN1
+2 SET IBZOUT=""
+3 ;array with iens of file #36
DO OTHP36^IBCEF72(IBXIEN,.IBZ)
+4 KILL IBXDATA
+5 SET C=$$OTHINS1^IBCEF2(IBXIEN)
+6 FOR Z=1,2
IF $GET(IBZ(Z))'=""
IF $EXTRACT(C,Z)
Begin DoDot:1
+7 SET IBINS=+IBZ(+$EXTRACT(C,Z))
+8 SET IBDFN1=$PIECE($GET(^DGCR(399,IBXIEN,0)),"^",2)
+9 SET IBZOUT(Z)=$$FR2PAT(IBDFN1,IBINS)
End DoDot:1
+10 QUIT
+11 ;Input:
+12 ; IBDFN-patient ien
+13 ; IBINS - input array with insurance pointers to 36
+14 ;Output
+15 ; STR LINE1|STR LINE2|CITY|STATE|ZIP
FR2PAT(IBDFN,IBINS) ;information about "other insured" address
+1 NEW Z3,Z4,Z5,IBZIP
+2 SET Z3=$ORDER(^DPT(IBDFN,.312,"B",$GET(IBINS),0))
+3 if +Z3=0
QUIT "||||"
+4 SET Z4=$GET(^DPT(IBDFN,.312,Z3,3))
+5 SET IBZIP=$PIECE($GET(^DIC(5,+$PIECE(Z4,"^",9),0)),"^",2)
+6 SET Z5=$PIECE(Z4,"^",6,8)_"^"_IBZIP_"^"_$PIECE(Z4,"^",10)
+7 QUIT $TRANSLATE(Z5,"^","|")
+8 ;
+9 ;Input :
+10 ; IBXIEN - ien in #399
+11 ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
+12 ; if IBP=0 then returns whole string
+13 ;Output:
+14 ; IBARR - output array m by reference
ELMADDR(IBXIEN,IBP,IBARR) ;
+1 NEW IB1,A,CHECK
+2 if '$DATA(IBXSAVE("OTH_PROV_ADDR"))
DO OTHADDR(IBXIEN)
+3 SET IB1=0
+4 FOR
SET IB1=$ORDER(IBXSAVE("OTH_PROV_ADDR",IB1))
if 'IB1
QUIT
Begin DoDot:1
+5 SET CHECK=0
+6 ;EXCLUDE ADD LINE 2 SECOND PC SINCE IT'S OK FOR THAT TO BE EMPTY
+7 FOR A=1,3,4,5
IF $PIECE(IBXSAVE("OTH_PROV_ADDR",IB1),"|",A)=""
Begin DoDot:2
+8 ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
+9 SET CHECK=1
KILL IBXSAVE("OTH_PROV_ADDR",IB1)
End DoDot:2
QUIT
+10 IF 'CHECK
Begin DoDot:2
+11 IF IBP=0
SET IBARR(IB1)=$GET(IBXSAVE("OTH_PROV_ADDR",IB1))
QUIT
+12 SET IBARR(IB1)=$PIECE($GET(IBXSAVE("OTH_PROV_ADDR",IB1)),"|",IBP)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;creates an array with address info for all insurances
+16 ;Input :
+17 ; IBXIEN - ien in #399
+18 ;Output:
+19 ; IBXSAVE("OTH_PROV_ADDR",Z)
OTHADDR(IBXIEN) ;
+1 NEW C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBINS
+2 ;array with iens of file #36
DO F^IBCEF("N-OTH INSURANCE CO IEN 36")
+3 MERGE IBZ=IBXDATA
+4 KILL IBXDATA
+5 SET C=$$OTHINS1^IBCEF2(IBXIEN)
+6 FOR Z=1,2
IF $GET(IBZ(Z))'=""
IF $EXTRACT(C,Z)
Begin DoDot:1
+7 SET IBINS=+IBZ(+$EXTRACT(C,Z))
+8 SET IBZIP=$PIECE($GET(^DIC(5,+$PIECE($GET(^DIC(36,IBINS,.11)),"^",5),0)),"^",2)
+9 SET IB1=$PIECE($GET(^DIC(36,IBINS,.11)),"^",1,2)_"^"_$PIECE($GET(^DIC(36,IBINS,.11)),"^",4)_"^"_IBZIP_"^"_$PIECE($GET(^DIC(36,IBINS,.11)),"^",6)
+10 SET IBXSAVE("OTH_PROV_ADDR",Z)=$TRANSLATE(IB1,"^","|")
End DoDot:1
+11 QUIT
+12 ;
+13 ;Retrieves pointer to get info about the service provider
+14 ;IBIEN399 - ien in #399
+15 ;IBFUNC -function (3-RENDERING,etc)
+16 ;Output: VARIABLE POINTER (PTR;file_root)
PROVPTR(IBIEN399,IBFUNC) ;
+1 ;*432/TAZ - No longer used for IBXSAVE array setup
+2 NEW IBN
+3 SET IBN=$ORDER(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
+4 IF +IBN=0
QUIT 0
+5 QUIT $PIECE($GET(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",2)
+6 ;
+7 ;Retrieves SSN from #200
+8 ;IBPTR- VARIABLE POINTER to #200
PROVSSN(IBIEN399) ;
+1 NEW IBRETVAL
SET IBRETVAL=""
+2 NEW IBPTR,IBFT
+3 FOR IBFT=1:1:9
Begin DoDot:1
+4 SET IBPTR=$$PROVPTR(IBIEN399,IBFT)
+5 SET $PIECE(IBRETVAL,"^",IBFT)=$$GETSSN^IBCEF72(IBPTR)
End DoDot:1
+6 QUIT IBRETVAL
+7 ;
+8 ;Input:
+9 ; IBPTR- ptr to ^VA(200 or ^IBA(355.93
+10 ;Output:
+11 ; SSN or null
GETNMEL(IBFULL,IBEL) ;Get name element
+1 DO NAMECOMP^XLFNAME(.IBFULL)
+2 QUIT $GET(IBFULL(IBEL))
+3 ;-
+4 ;PROVIDER
+5 ;Input:
+6 ; IB399 - ien of #399
+7 ; IBPROV:
+8 ; "C"- to get info for CURRENT provider
+9 ; "O"- to get info for all others (in this case the array will contain info fot two providers
+10 ; IBRES - array for results (by reference)
+11 ;
+12 ;Output:
+13 ; IBRES - array to get back info (by reference)
+14 ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
+15 ; where:
+16 ; IBPROV - see input parameter
+17 ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
+18 ; PRTYPE: Provider type(FUNCTION)
+19 ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
+20 ; PROV : provider/VARIABLEPTR
+21 ; INSUR: Insurance PTR #36 or NONE
+22 ; IDTYPE: ID type
+23 ; ID: ID
+24 ; FORMTYP: Form type 1=UB,2=1500
+25 ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
PROVIDER(IB399,IBPROV,IBRES) ;
+1 NEW IBCURR,IBZ,IBRESARR
+2 SET IBRESARR=""
+3 ;current bill payer sequence
SET IBCURR=$$COB^IBCEF(IB399)
+4 ;PATIENT's bill
if IBPROV="A"
QUIT
+5 IF IBPROV="C"
Begin DoDot:1
+6 if $$ISINSUR^IBCEF71(IBCURR,IB399)
DO PROVINF(IB399,$SELECT(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV)
End DoDot:1
+7 IF IBPROV="O"
Begin DoDot:1
+8 IF IBCURR="P"
if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,1,IBPROV)
if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV)
+9 IF IBCURR="S"
if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV)
if $$ISINSUR^IBCEF71("T",IB399)
DO PROVINF(IB399,3,.IBRESARR,2,IBPROV)
+10 IF IBCURR="T"
if $$ISINSUR^IBCEF71("P",IB399)
DO PROVINF(IB399,1,.IBRESARR,1,IBPROV)
if $$ISINSUR^IBCEF71("S",IB399)
DO PROVINF(IB399,2,.IBRESARR,2,IBPROV)
End DoDot:1
+11 MERGE IBRES(IBPROV)=IBRESARR
+12 QUIT
+13 ;
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
+1 DO PROVINF^IBCEF74(IB399,IBPRNUM,.IBRES,IBSORT,IBINSTP)
+2 QUIT
+3 ;
PSPRV(IBIFN) ; Returns information for bill ien IBIFN for purchased svc
+1 ; Returns 4 digit data in following format:
+2 ; 1st digit: 0 if not outside facility
+3 ; 1 if outside facility
+4 ; 2nd digit: 0 if not non-VA provider for rendering/attending
+5 ; 1 if non-VA provider for rendering/attending
+6 ; 3rd digit: 0 if not purchased svc
+7 ; 1 if purchased svc
+8 ; 4th digit: 0 if 1500 bill
+9 ; 1 if UB bill
+10 NEW IBSVC,Z,Z0,IBU2
+11 SET IBSVC="000"_+$$INSFT^IBCEU5(IBIFN)
SET IBU2=$GET(^DGCR(399,IBIFN,"U2"))
+12 ; NON-VA FACILITY
IF $PIECE(IBU2,U,10)
SET $EXTRACT(IBSVC,1)=1
+13 SET Z=($$FT^IBCEF(IBIFN)=3)+3
SET Z0=+$ORDER(^DGCR(399,IBIFN,"PRV","B",Z,0))
+14 IF $PIECE($GET(^DGCR(399,IBIFN,"PRV",Z0,0)),U,2)["IBA(355.93"
SET $EXTRACT(IBSVC,2)=1
+15 IF $PIECE(IBU2,U,11)>0
IF $PIECE(IBU2,U,11)'>2
SET $EXTRACT(IBSVC,3)=1
PSPRVQ QUIT IBSVC
+1 ;
CHKADD ;CHECK ALL ADDRESS ELEMENTS PRESENT IF NOT KILL ALL ADDRESS ELEMENTS
+1 ;EXPECT IBXSAVE("CADR") AS SOURCE ARRAY
+2 NEW Z,CHECK
+3 SET Z=""
SET CHECK=0
+4 FOR Z=1,4,5,6
Begin DoDot:1
+5 IF $PIECE($GET(IBXSAVE("CADR")),"^",Z)=""
SET CHECK=1
End DoDot:1
+6 IF CHECK=1
SET IBXSAVE("CADR")=""
+7 QUIT
+8 ;
