- IBCEF78 ;ALB/WCJ - Provider ID functions ;13 May 2007
- ;;2.0;INTEGRATED BILLING;**371,516,592,742**;21-MAR-94;Build 36
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;
- G AWAY
- AWAY Q
- ;
- PAYERIDS(IBXIEN,IBRET) ; This function returns all the PAYER IDS for the current and other insurance(s)
- ;
- D PRIPAYID(IBXIEN,.IBRET)
- D SECPAYID(IBXIEN,.IBRET)
- Q
- ;
- PRIPAYID(IBXIEN,IBXRET) ; Primary Payer IDs
- ; Incoming:
- ; IBXIEN = IEN for File # 399
- ; IBXRET = Return Array for Qualifiers and IDs
- ;
- ; Outgoing
- ; IBXRET("CI_PID",1)=QUAL^ID
- ; IBXRET("OI_PID",#)=QUAL^ID
- ;
- N RET,I
- S RET=$$PAYERID^IBCEF2(IBXIEN)
- ;JWS;EBILL-3155;11/30/22;IB*2.0*742;if PayerID is all spaces, set to null to prevent sending PI qualifier with null PayerID to FSC
- I $L($TR(RET," ",""))=0 S RET=""
- I RET]"" S IBXRET("CI_PID",1)="PI"_U_RET
- ;
- ; MRD;IB*2.0*516 - Added HPID here (CI) and below (OI).
- S RET=$$HPID(IBXIEN)
- I RET]"" S IBXRET("CI_HPID",1)="XV"_U_RET
- ;
- S RET=""
- D OTHINSID^IBCEF72(IBXIEN,.RET)
- F I=1,2 D
- . I $P($G(RET(I)),U)]"" S IBXRET("OI_PID",I)="PI"_U_$P(RET(I),U)
- . I $P($G(RET(I)),U,2)]"" S IBXRET("OI_HPID",I)="XV"_U_$P(RET(I),U,2)
- . Q
- Q
- ;
- SECPAYID(IBXIEN,IBXRET) ; This returns all of the secondary payer IDs from file #36
- ; for the insurance companies on a given claim
- ;
- ; Incoming:
- ; IBXIEN = IEN for File # 399
- ; IBXRET = Return Array for Qualifiers and IDs
- ;
- ; Outgoing
- ; IBXRET("CI_PSIDS",1)=QUAL^ID^QUAL^ID
- ; IBXRET("OI_PSIDS",#)=QUAL^ID^QUAL^ID
- ;
- N Z,C,IBZ,Z0,FT
- F Z=1:1:3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,1,Z)
- S Z0=0,C=$$COBN^IBCEF(IBXIEN),FT=$$FT^IBCEF(IBXIEN)
- F Z=1:1:3 S:C'=Z Z0=Z0+1 S IBXRET($S(C=Z:"CI_PSIDS",1:"OI_PSIDS"),$S(C=Z:1,1:Z0))=$$SPIDS(+IBZ(Z),FT)
- Q
- ;
- SPIDS(INS,FT) ;
- ; FT = FORM TYPE (2 PROFESSIONAL 3 INSTITUTIONAL)
- ; INS = INSURANCE COMPANY (FILE #36) IEN
- ; Returns String (^ delimited)
- ; [1] = QUAL 1
- ; [2] = PAYER ID 1
- ; [3] = QUAL 2
- ; [4] = PAYER ID 2
- Q:'+INS ""
- ;
- N DATA,PCE
- ;JWS;IB*2.0*592;Dental form 7 same as form 2 - no secondaries for Dental
- S DATA=$S(FT=3:$P($G(^DIC(36,+INS,6)),U,1,4),FT=2:$P($G(^DIC(36,+INS,6)),U,5,8),1:"")
- ;
- ; Check for dangling IDs/Qualifiers
- F PCE=1,3 D
- . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
- . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
- ;
- ; fill in the gap if there is one
- I $P(DATA,U,1)="",$P(DATA,U,3)'="" D
- . S $P(DATA,U,1)=$P(DATA,U,3)
- . S $P(DATA,U,2)=$P(DATA,U,4)
- . S ($P(DATA,U,3),$P(DATA,U,4))=""
- ;
- Q DATA
- ;
- HPID(IBXIEN) ; Determine HPID for current payer.
- ; MRD;IB*2.0*516 - Added HPID.
- ;
- N IBHPID,IBSEQ
- S IBSEQ=$$COBN^IBCEF(IBXIEN) ; IBSEQ should be 1, 2 or 3.
- I IBSEQ S IBHPID=$P($G(^DGCR(399,IBXIEN,"M1")),U,12+IBSEQ) ; Pull piece 13, 14 or 15.
- Q IBHPID
- ;
- CLEANUP(IBRET) ;
- K IBRET("CI_PID"),IBRET("OI_PID"),IBRET("CI_PSIDS"),IBRET("OI_PSIDS"),IBRET("CI_HPID"),IBRET("OI_HPID")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF78 2935 printed Feb 18, 2025@23:36:44 Page 2
- IBCEF78 ;ALB/WCJ - Provider ID functions ;13 May 2007
- +1 ;;2.0;INTEGRATED BILLING;**371,516,592,742**;21-MAR-94;Build 36
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;
- +4 GOTO AWAY
- AWAY QUIT
- +1 ;
- PAYERIDS(IBXIEN,IBRET) ; This function returns all the PAYER IDS for the current and other insurance(s)
- +1 ;
- +2 DO PRIPAYID(IBXIEN,.IBRET)
- +3 DO SECPAYID(IBXIEN,.IBRET)
- +4 QUIT
- +5 ;
- PRIPAYID(IBXIEN,IBXRET) ; Primary Payer IDs
- +1 ; Incoming:
- +2 ; IBXIEN = IEN for File # 399
- +3 ; IBXRET = Return Array for Qualifiers and IDs
- +4 ;
- +5 ; Outgoing
- +6 ; IBXRET("CI_PID",1)=QUAL^ID
- +7 ; IBXRET("OI_PID",#)=QUAL^ID
- +8 ;
- +9 NEW RET,I
- +10 SET RET=$$PAYERID^IBCEF2(IBXIEN)
- +11 ;JWS;EBILL-3155;11/30/22;IB*2.0*742;if PayerID is all spaces, set to null to prevent sending PI qualifier with null PayerID to FSC
- +12 IF $LENGTH($TRANSLATE(RET," ",""))=0
- SET RET=""
- +13 IF RET]""
- SET IBXRET("CI_PID",1)="PI"_U_RET
- +14 ;
- +15 ; MRD;IB*2.0*516 - Added HPID here (CI) and below (OI).
- +16 SET RET=$$HPID(IBXIEN)
- +17 IF RET]""
- SET IBXRET("CI_HPID",1)="XV"_U_RET
- +18 ;
- +19 SET RET=""
- +20 DO OTHINSID^IBCEF72(IBXIEN,.RET)
- +21 FOR I=1,2
- Begin DoDot:1
- +22 IF $PIECE($GET(RET(I)),U)]""
- SET IBXRET("OI_PID",I)="PI"_U_$PIECE(RET(I),U)
- +23 IF $PIECE($GET(RET(I)),U,2)]""
- SET IBXRET("OI_HPID",I)="XV"_U_$PIECE(RET(I),U,2)
- +24 QUIT
- End DoDot:1
- +25 QUIT
- +26 ;
- SECPAYID(IBXIEN,IBXRET) ; This returns all of the secondary payer IDs from file #36
- +1 ; for the insurance companies on a given claim
- +2 ;
- +3 ; Incoming:
- +4 ; IBXIEN = IEN for File # 399
- +5 ; IBXRET = Return Array for Qualifiers and IDs
- +6 ;
- +7 ; Outgoing
- +8 ; IBXRET("CI_PSIDS",1)=QUAL^ID^QUAL^ID
- +9 ; IBXRET("OI_PSIDS",#)=QUAL^ID^QUAL^ID
- +10 ;
- +11 NEW Z,C,IBZ,Z0,FT
- +12 FOR Z=1:1:3
- SET IBZ(Z)=$$POLICY^IBCEF(IBXIEN,1,Z)
- +13 SET Z0=0
- SET C=$$COBN^IBCEF(IBXIEN)
- SET FT=$$FT^IBCEF(IBXIEN)
- +14 FOR Z=1:1:3
- if C'=Z
- SET Z0=Z0+1
- SET IBXRET($SELECT(C=Z:"CI_PSIDS",1:"OI_PSIDS"),$SELECT(C=Z:1,1:Z0))=$$SPIDS(+IBZ(Z),FT)
- +15 QUIT
- +16 ;
- SPIDS(INS,FT) ;
- +1 ; FT = FORM TYPE (2 PROFESSIONAL 3 INSTITUTIONAL)
- +2 ; INS = INSURANCE COMPANY (FILE #36) IEN
- +3 ; Returns String (^ delimited)
- +4 ; [1] = QUAL 1
- +5 ; [2] = PAYER ID 1
- +6 ; [3] = QUAL 2
- +7 ; [4] = PAYER ID 2
- +8 if '+INS
- QUIT ""
- +9 ;
- +10 NEW DATA,PCE
- +11 ;JWS;IB*2.0*592;Dental form 7 same as form 2 - no secondaries for Dental
- +12 SET DATA=$SELECT(FT=3:$PIECE($GET(^DIC(36,+INS,6)),U,1,4),FT=2:$PIECE($GET(^DIC(36,+INS,6)),U,5,8),1:"")
- +13 ;
- +14 ; Check for dangling IDs/Qualifiers
- +15 FOR PCE=1,3
- Begin DoDot:1
- +16 IF $PIECE(DATA,U,PCE)'=""
- IF $PIECE(DATA,U,PCE+1)'=""
- QUIT
- +17 SET ($PIECE(DATA,U,PCE),$PIECE(DATA,U,PCE+1))=""
- End DoDot:1
- +18 ;
- +19 ; fill in the gap if there is one
- +20 IF $PIECE(DATA,U,1)=""
- IF $PIECE(DATA,U,3)'=""
- Begin DoDot:1
- +21 SET $PIECE(DATA,U,1)=$PIECE(DATA,U,3)
- +22 SET $PIECE(DATA,U,2)=$PIECE(DATA,U,4)
- +23 SET ($PIECE(DATA,U,3),$PIECE(DATA,U,4))=""
- End DoDot:1
- +24 ;
- +25 QUIT DATA
- +26 ;
- HPID(IBXIEN) ; Determine HPID for current payer.
- +1 ; MRD;IB*2.0*516 - Added HPID.
- +2 ;
- +3 NEW IBHPID,IBSEQ
- +4 ; IBSEQ should be 1, 2 or 3.
- SET IBSEQ=$$COBN^IBCEF(IBXIEN)
- +5 ; Pull piece 13, 14 or 15.
- IF IBSEQ
- SET IBHPID=$PIECE($GET(^DGCR(399,IBXIEN,"M1")),U,12+IBSEQ)
- +6 QUIT IBHPID
- +7 ;
- CLEANUP(IBRET) ;
- +1 KILL IBRET("CI_PID"),IBRET("OI_PID"),IBRET("CI_PSIDS"),IBRET("OI_PSIDS"),IBRET("CI_HPID"),IBRET("OI_HPID")
- +2 QUIT
- +3 ;