- 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 Jan 18, 2025@03:11:23 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 ;