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

IBCEF7.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. 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
  1. I +$G(IBXSAVE("PROVINF",IBXIEN))=0 D
  1. . N IBZ
  1. . D PROVIDER(IBXIEN,"C",.IBZ),PROVIDER(IBXIEN,"O",.IBZ) S IBXSAVE("PROVINF",IBXIEN)=IBXIEN M IBXSAVE("PROVINF",IBXIEN)=IBZ
  1. Q
  1. ;for PRV1
  1. ;Input:
  1. ; IB399 ien of #399
  1. PRV1(IB399) ;
  1. N IBN,IBZ,IBZ1,IBZN,IBZD,IBRES,IBIND,IBDEF,IBDEFTYP,IBQ,IBFRMTYP,IBZNAME
  1. S IBFRMTYP=+$$FT^IBCEF(IB399)
  1. S IBN=0,IBIND=0,IBRES="",IBQ=0
  1. S IBDEF=$P($G(^DGCR(399,IB399,"M1")),U,$$COBN^IBCEF(IB399)+1),IBDEFTYP=""
  1. I IBDEF'="" S IBDEFTYP=$$SOP^IBCEP2B(IB399,"")
  1. ;JRA IB*2.0*592 Treat new Dental form 7 (J430D)
  1. ;I IBDEFTYP'="",$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0 S (IBDEF,IBDEFTYP)="" ;JRA IB*2.0*592 ';'
  1. 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
  1. I IBDEF'="",IBDEFTYP'="" S IBIND=IBIND+2,$P(IBRES,U,IBIND)=(IBDEFTYP_U_IBDEF)
  1. F S IBN=$O(^IBE(355.97,IBN)) Q:+IBN=0!(IBQ=1) D
  1. . S IBZ=$G(^IBE(355.97,IBN,0)),IBZ1=$G(^(1))
  1. . Q:$P(IBZ,"^",4)=""!$P(IBZ1,U,9) ;if no FACILITY'S DEFAULT ID #
  1. . Q:$P(IBZ1,"^",4)!(IBDEFTYP=$P(IBZ,U,3))
  1. . S IBZN=$P(IBZ,"^",3),IBZNAME=$P(IBZ,"^",1)
  1. . ;I IBFRMTYP=2 Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500 ;JRA IB*2.0*592 ';'
  1. . I IBFRMTYP=2!(IBFRMTYP=7) Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500 or J430D ;JRA IB*2.0*592
  1. . I IBFRMTYP=3 Q:IBZN="1B"!(IBZNAME="MEDICARE PART B") ;UB
  1. . ;Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0 ;JRA IB*2.0*592 ';'
  1. . Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=7:7,IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0 ;JRA IB*2.0*592
  1. . I $P(IBZ,"^",2)=0!($P(IBZ,"^",2)=2) D
  1. . . S IBIND=IBIND+2
  1. . . I IBIND>14 S IBQ=1 Q
  1. . . S $P(IBRES,"^",IBIND)=IBZN_"^"_$P(IBZ,"^",4)
  1. ;Remove any duplicate entries
  1. N I,Q,QUAL,QUALC,IBRESTMP,SEQ
  1. F I=2:2:($L(IBRES,"^")-1) D
  1. . S QUAL=$P(IBRES,"^",I)
  1. . I $G(IBRESTMP(QUAL))="" S IBRESTMP(QUAL)=$P(IBRES,"^",(I+1))
  1. S Q=2
  1. S I="",QUAL=""
  1. K IBRES
  1. S IBRES=""
  1. S SEQ=0
  1. F S QUAL=$O(IBRESTMP(QUAL)) Q:QUAL="" D
  1. . S SEQ=SEQ+2
  1. . S $P(IBRES,"^",SEQ)=QUAL,$P(IBRES,"^",(SEQ+1))=IBRESTMP(QUAL)
  1. Q IBRES
  1. ;
  1. ; creates array of SUBSCR IDs for all "other insurances"
  1. ;Input :
  1. ; IBXIEN - ien in #399
  1. ;Output:
  1. ; IBZOUT(Z) - array with ien of #36
  1. OTHSBID(IBXIEN,IBZOUT) ;
  1. N Z,Z0,Z1,IBZ,C
  1. D F^IBCEF("N-ALL INSURANCE CO 837 ID","IBZ")
  1. F Z=1,2,3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,2,$E("PST",Z))
  1. K IBXDATA
  1. S C=$$OTHINS1^IBCEF2(IBXIEN)
  1. F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
  1. . S IBZOUT(Z)=IBZ(+$E(C,Z))
  1. Q
  1. ;Input :
  1. ; IBXIEN - ien in #399
  1. ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
  1. ;Output:
  1. ; IBARR - output array m by reference
  1. ELMADD2(IBXIEN,IBP,IBARR) ;
  1. N IBZZZ,A,CHECK,IB1
  1. I '$D(IBXSAVE("OTH_INSURED_ADDR")) D OTHADD2(IBXIEN,.IBZZZ) M IBXSAVE("OTH_INSURED_ADDR")=IBZZZ
  1. S IB1=0
  1. F S IB1=$O(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q:'IB1 D
  1. . ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
  1. . S CHECK=0
  1. . F A=1,3,4,5 I $P(IBXSAVE("OTH_INSURED_ADDR",IB1),"|",A)="" S CHECK=1 K IBXSAVE("OTH_INSURED_ADDR",IB1) Q
  1. . I 'CHECK D
  1. . . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q
  1. . . S IBARR(IB1)=$P($G(IBXSAVE("OTH_INSURED_ADDR",IB1)),"|",IBP)
  1. Q
  1. ;creates an array with address info for all other insured persons
  1. ;Input :
  1. ; IBXIEN - ien in #399
  1. ;Output:
  1. ; IBZOUT(Z) - array with STR LINE1|STR LINE2|CITY|STATE|ZIP
  1. OTHADD2(IBXIEN,IBZOUT) ;
  1. N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBDFN1
  1. S IBZOUT=""
  1. D OTHP36^IBCEF72(IBXIEN,.IBZ) ;array with iens of file #36
  1. K IBXDATA
  1. S C=$$OTHINS1^IBCEF2(IBXIEN)
  1. F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
  1. . S IBINS=+IBZ(+$E(C,Z))
  1. . S IBDFN1=$P($G(^DGCR(399,IBXIEN,0)),"^",2)
  1. . S IBZOUT(Z)=$$FR2PAT(IBDFN1,IBINS)
  1. Q
  1. ;Input:
  1. ; IBDFN-patient ien
  1. ; IBINS - input array with insurance pointers to 36
  1. ;Output
  1. ; STR LINE1|STR LINE2|CITY|STATE|ZIP
  1. FR2PAT(IBDFN,IBINS) ;information about "other insured" address
  1. N Z3,Z4,Z5,IBZIP
  1. S Z3=$O(^DPT(IBDFN,.312,"B",$G(IBINS),0))
  1. Q:+Z3=0 "||||"
  1. S Z4=$G(^DPT(IBDFN,.312,Z3,3))
  1. S IBZIP=$P($G(^DIC(5,+$P(Z4,"^",9),0)),"^",2)
  1. S Z5=$P(Z4,"^",6,8)_"^"_IBZIP_"^"_$P(Z4,"^",10)
  1. Q $TR(Z5,"^","|")
  1. ;
  1. ;Input :
  1. ; IBXIEN - ien in #399
  1. ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
  1. ; if IBP=0 then returns whole string
  1. ;Output:
  1. ; IBARR - output array m by reference
  1. ELMADDR(IBXIEN,IBP,IBARR) ;
  1. N IB1,A,CHECK
  1. D:'$D(IBXSAVE("OTH_PROV_ADDR")) OTHADDR(IBXIEN)
  1. S IB1=0
  1. F S IB1=$O(IBXSAVE("OTH_PROV_ADDR",IB1)) Q:'IB1 D
  1. . S CHECK=0
  1. . ;EXCLUDE ADD LINE 2 SECOND PC SINCE IT'S OK FOR THAT TO BE EMPTY
  1. . F A=1,3,4,5 I $P(IBXSAVE("OTH_PROV_ADDR",IB1),"|",A)="" D Q
  1. . . ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
  1. . . S CHECK=1 K IBXSAVE("OTH_PROV_ADDR",IB1)
  1. . I 'CHECK D
  1. . . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_PROV_ADDR",IB1)) Q
  1. . . S IBARR(IB1)=$P($G(IBXSAVE("OTH_PROV_ADDR",IB1)),"|",IBP)
  1. Q
  1. ;
  1. ;creates an array with address info for all insurances
  1. ;Input :
  1. ; IBXIEN - ien in #399
  1. ;Output:
  1. ; IBXSAVE("OTH_PROV_ADDR",Z)
  1. OTHADDR(IBXIEN) ;
  1. N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBINS
  1. D F^IBCEF("N-OTH INSURANCE CO IEN 36") ;array with iens of file #36
  1. M IBZ=IBXDATA
  1. K IBXDATA
  1. S C=$$OTHINS1^IBCEF2(IBXIEN)
  1. F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
  1. . S IBINS=+IBZ(+$E(C,Z))
  1. . S IBZIP=$P($G(^DIC(5,+$P($G(^DIC(36,IBINS,.11)),"^",5),0)),"^",2)
  1. . 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)
  1. . S IBXSAVE("OTH_PROV_ADDR",Z)=$TR(IB1,"^","|")
  1. Q
  1. ;
  1. ;Retrieves pointer to get info about the service provider
  1. ;IBIEN399 - ien in #399
  1. ;IBFUNC -function (3-RENDERING,etc)
  1. ;Output: VARIABLE POINTER (PTR;file_root)
  1. PROVPTR(IBIEN399,IBFUNC) ;
  1. ;*432/TAZ - No longer used for IBXSAVE array setup
  1. N IBN
  1. S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
  1. I +IBN=0 Q 0
  1. Q $P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",2)
  1. ;
  1. ;Retrieves SSN from #200
  1. ;IBPTR- VARIABLE POINTER to #200
  1. PROVSSN(IBIEN399) ;
  1. N IBRETVAL S IBRETVAL=""
  1. N IBPTR,IBFT
  1. F IBFT=1:1:9 D
  1. . S IBPTR=$$PROVPTR(IBIEN399,IBFT)
  1. . S $P(IBRETVAL,"^",IBFT)=$$GETSSN^IBCEF72(IBPTR)
  1. Q IBRETVAL
  1. ;
  1. ;Input:
  1. ; IBPTR- ptr to ^VA(200 or ^IBA(355.93
  1. ;Output:
  1. ; SSN or null
  1. GETNMEL(IBFULL,IBEL) ;Get name element
  1. D NAMECOMP^XLFNAME(.IBFULL)
  1. Q $G(IBFULL(IBEL))
  1. ;-
  1. ;PROVIDER
  1. ;Input:
  1. ; IB399 - ien of #399
  1. ; IBPROV:
  1. ; "C"- to get info for CURRENT provider
  1. ; "O"- to get info for all others (in this case the array will contain info fot two providers
  1. ; IBRES - array for results (by reference)
  1. ;
  1. ;Output:
  1. ; IBRES - array to get back info (by reference)
  1. ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
  1. ; where:
  1. ; IBPROV - see input parameter
  1. ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
  1. ; PRTYPE: Provider type(FUNCTION)
  1. ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
  1. ; PROV : provider/VARIABLEPTR
  1. ; INSUR: Insurance PTR #36 or NONE
  1. ; IDTYPE: ID type
  1. ; ID: ID
  1. ; FORMTYP: Form type 1=UB,2=1500
  1. ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
  1. PROVIDER(IB399,IBPROV,IBRES) ;
  1. N IBCURR,IBZ,IBRESARR
  1. S IBRESARR=""
  1. S IBCURR=$$COB^IBCEF(IB399) ;current bill payer sequence
  1. Q:IBPROV="A" ;PATIENT's bill
  1. I IBPROV="C" D
  1. . D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV)
  1. I IBPROV="O" D
  1. . 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)
  1. . 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)
  1. . 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)
  1. M IBRES(IBPROV)=IBRESARR
  1. Q
  1. ;
  1. PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
  1. D PROVINF^IBCEF74(IB399,IBPRNUM,.IBRES,IBSORT,IBINSTP)
  1. Q
  1. ;
  1. PSPRV(IBIFN) ; Returns information for bill ien IBIFN for purchased svc
  1. ; Returns 4 digit data in following format:
  1. ; 1st digit: 0 if not outside facility
  1. ; 1 if outside facility
  1. ; 2nd digit: 0 if not non-VA provider for rendering/attending
  1. ; 1 if non-VA provider for rendering/attending
  1. ; 3rd digit: 0 if not purchased svc
  1. ; 1 if purchased svc
  1. ; 4th digit: 0 if 1500 bill
  1. ; 1 if UB bill
  1. N IBSVC,Z,Z0,IBU2
  1. S IBSVC="000"_+$$INSFT^IBCEU5(IBIFN),IBU2=$G(^DGCR(399,IBIFN,"U2"))
  1. I $P(IBU2,U,10) S $E(IBSVC,1)=1 ; NON-VA FACILITY
  1. S Z=($$FT^IBCEF(IBIFN)=3)+3,Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
  1. I $P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,2)["IBA(355.93" S $E(IBSVC,2)=1
  1. I $P(IBU2,U,11)>0,$P(IBU2,U,11)'>2 S $E(IBSVC,3)=1
  1. PSPRVQ Q IBSVC
  1. ;
  1. CHKADD ;CHECK ALL ADDRESS ELEMENTS PRESENT IF NOT KILL ALL ADDRESS ELEMENTS
  1. ;EXPECT IBXSAVE("CADR") AS SOURCE ARRAY
  1. N Z,CHECK
  1. S Z="",CHECK=0
  1. F Z=1,4,5,6 D
  1. . I $P($G(IBXSAVE("CADR")),"^",Z)="" S CHECK=1
  1. I CHECK=1 S IBXSAVE("CADR")=""
  1. Q
  1. ;