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 Oct 16, 2024@18:11:01 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 ;
