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

IBCEF78.m

Go to the documentation of this file.
  1. IBCEF78 ;ALB/WCJ - Provider ID functions ;13 May 2007
  1. ;;2.0;INTEGRATED BILLING;**371,516,592,742**;21-MAR-94;Build 36
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;
  1. G AWAY
  1. AWAY Q
  1. ;
  1. PAYERIDS(IBXIEN,IBRET) ; This function returns all the PAYER IDS for the current and other insurance(s)
  1. ;
  1. D PRIPAYID(IBXIEN,.IBRET)
  1. D SECPAYID(IBXIEN,.IBRET)
  1. Q
  1. ;
  1. PRIPAYID(IBXIEN,IBXRET) ; Primary Payer IDs
  1. ; Incoming:
  1. ; IBXIEN = IEN for File # 399
  1. ; IBXRET = Return Array for Qualifiers and IDs
  1. ;
  1. ; Outgoing
  1. ; IBXRET("CI_PID",1)=QUAL^ID
  1. ; IBXRET("OI_PID",#)=QUAL^ID
  1. ;
  1. N RET,I
  1. S RET=$$PAYERID^IBCEF2(IBXIEN)
  1. ;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
  1. I $L($TR(RET," ",""))=0 S RET=""
  1. I RET]"" S IBXRET("CI_PID",1)="PI"_U_RET
  1. ;
  1. ; MRD;IB*2.0*516 - Added HPID here (CI) and below (OI).
  1. S RET=$$HPID(IBXIEN)
  1. I RET]"" S IBXRET("CI_HPID",1)="XV"_U_RET
  1. ;
  1. S RET=""
  1. D OTHINSID^IBCEF72(IBXIEN,.RET)
  1. F I=1,2 D
  1. . I $P($G(RET(I)),U)]"" S IBXRET("OI_PID",I)="PI"_U_$P(RET(I),U)
  1. . I $P($G(RET(I)),U,2)]"" S IBXRET("OI_HPID",I)="XV"_U_$P(RET(I),U,2)
  1. . Q
  1. Q
  1. ;
  1. SECPAYID(IBXIEN,IBXRET) ; This returns all of the secondary payer IDs from file #36
  1. ; for the insurance companies on a given claim
  1. ;
  1. ; Incoming:
  1. ; IBXIEN = IEN for File # 399
  1. ; IBXRET = Return Array for Qualifiers and IDs
  1. ;
  1. ; Outgoing
  1. ; IBXRET("CI_PSIDS",1)=QUAL^ID^QUAL^ID
  1. ; IBXRET("OI_PSIDS",#)=QUAL^ID^QUAL^ID
  1. ;
  1. N Z,C,IBZ,Z0,FT
  1. F Z=1:1:3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,1,Z)
  1. S Z0=0,C=$$COBN^IBCEF(IBXIEN),FT=$$FT^IBCEF(IBXIEN)
  1. 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)
  1. Q
  1. ;
  1. SPIDS(INS,FT) ;
  1. ; FT = FORM TYPE (2 PROFESSIONAL 3 INSTITUTIONAL)
  1. ; INS = INSURANCE COMPANY (FILE #36) IEN
  1. ; Returns String (^ delimited)
  1. ; [1] = QUAL 1
  1. ; [2] = PAYER ID 1
  1. ; [3] = QUAL 2
  1. ; [4] = PAYER ID 2
  1. Q:'+INS ""
  1. ;
  1. N DATA,PCE
  1. ;JWS;IB*2.0*592;Dental form 7 same as form 2 - no secondaries for Dental
  1. 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:"")
  1. ;
  1. ; Check for dangling IDs/Qualifiers
  1. F PCE=1,3 D
  1. . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
  1. . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
  1. ;
  1. ; fill in the gap if there is one
  1. I $P(DATA,U,1)="",$P(DATA,U,3)'="" D
  1. . S $P(DATA,U,1)=$P(DATA,U,3)
  1. . S $P(DATA,U,2)=$P(DATA,U,4)
  1. . S ($P(DATA,U,3),$P(DATA,U,4))=""
  1. ;
  1. Q DATA
  1. ;
  1. HPID(IBXIEN) ; Determine HPID for current payer.
  1. ; MRD;IB*2.0*516 - Added HPID.
  1. ;
  1. N IBHPID,IBSEQ
  1. S IBSEQ=$$COBN^IBCEF(IBXIEN) ; IBSEQ should be 1, 2 or 3.
  1. I IBSEQ S IBHPID=$P($G(^DGCR(399,IBXIEN,"M1")),U,12+IBSEQ) ; Pull piece 13, 14 or 15.
  1. Q IBHPID
  1. ;
  1. CLEANUP(IBRET) ;
  1. K IBRET("CI_PID"),IBRET("OI_PID"),IBRET("CI_PSIDS"),IBRET("OI_PSIDS"),IBRET("CI_HPID"),IBRET("OI_HPID")
  1. Q
  1. ;