IBCEF78 ;ALB/WCJ - Provider ID functions ;13 May 2007
 ;;2.0;INTEGRATED BILLING;**371**;21-MAR-94;Build 57
 ;;Per VHA Directive 2004-038, 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)
 I RET]"" S IBXRET("CI_PID",1)="PI"_U_RET
 ;
 D OTHINSID^IBCEF72(IBXIEN,.RET)
 F I=1,2 I $G(RET(I))]"" S IBXRET("OI_PID",I)="PI"_U_RET(I)
 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
 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
 ;
CLEANUP(IBRET) ;
 K IBRET("CI_PID"),IBRET("OI_PID"),IBRET("CI_PSIDS"),IBRET("OI_PSIDS")
 Q
 ;