IBCEQ1 ;BSL,ALB/TMK - PROVIDER ID QUERY ;25-AUG-03
;;2.0;INTEGRATED BILLING;**232,356,349,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
;QUERY TOOL HELPS IDENTIFY PLANS THAT ARE LACKING PROVIDER ID
;INFO OR HAVE BAD PROVIDER ID DATA FOR E-BILLING
;
;CONDITIONS TO IDENTIFY:
;1-BLUE CROSS LINKED TO 1500 ONLY (1) HARD ERROR
;2-BLUE SHIELD LINKED TO UB-04 ONLY (2) WARNING
;3-BLUE CROSS ID APPLIED TO BOTH FORMS (0) WARNING
;4-BLUE CROSS OR BLUE SHIELD IDs EXIST FOR AN INS CO, BUT ONE OR
; MORE OF THE INSURANCE COMPANY'S PLANS DOES NOT HAVE AN
; ELECTRONIC PLAN TYPE OF 'BL'
;5-NON BLUE CROSS/SHIELD ID FOR AN INS COMPANY WITH BLUE PLAN(S)
;6-VAD000 as an ID but not flagged as a UPIN
;
EN ;
N POP,%ZIS,ZTSK,ZTRTN,ZTDESC,IBREBLD,IBSENDM,IBTO,DIR,X,Y,DUOUT,DTOUT,Z
S IBREBLD=$S('$D(^XTMP("IB_PLAN232")):1,1:0)
I $D(^XTMP("IB_PLAN232")) D
. S DIR("?")="IF YOU ANSWER NO, REPORT WILL BE RUN FROM THE EXISTING QUERY DATA",DIR("?",1)="IF YOU ANSWER YES, A NEW QUERY WILL BE RUN"
. S DIR(0)="YA",DIR("A",1)="THE EXTRACT GLOBAL FOR THIS QUERY ALREADY EXISTS",DIR("A")="DO YOU WANT TO DELETE IT AND RERUN THE QUERY?: ",DIR("B")="NO" W ! D ^DIR K DIR
. Q:$D(DUOUT)!$D(DTOUT)!'Y
. S IBREBLD=1
;
N XMINSTR,Z,ZTSAVE
K ^TMP("XMY",$J),^TMP("XMY0",$J)
S XMINSTR("ADDR FLAGS")="R"
D TOWHOM^XMXAPIU(DUZ,"","S",.XMINSTR)
S Z="" F S Z=$O(^TMP("XMY",$J,Z)) Q:Z="" S IBTO(Z)=""
K ^TMP("XMY",$J),^TMP("XMY0",$J)
;
S %ZIS="QM" D ^%ZIS G:POP EN1Q
I $D(IO("Q")) D G EN1Q
. S ZTRTN="ENT^IBCEQ1("_IBREBLD_",.IBTO)",ZTDESC="IB - HIPAA ENHANCEMENTS PROV ID QUERY",ZTSAVE("IBTO(")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Task # "_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
D ENT(IBREBLD,.IBTO)
EN1Q Q
;
ENT(IBREBLD,IBTO) ; Queued job enter here
;
N LOOP,Z
K ^TMP($J,"SENDMSG")
S ^TMP($J,"SENDMSG")=$S(IBREBLD:1,1:0)
S Z="" F S Z=$O(IBTO(Z)) Q:Z="" S ^TMP($J,"SENDMSG",0,Z)=""
I $G(IBREBLD) D
. ; Rebld query
. K ^XTMP("IB_PLAN232")
. S ^XTMP("IB_PLAN232")="",^XTMP("IB_PLAN232",0)=$$FMADD^XLFDT(DT,45)_U_DT_"^IB PATCH 232 PROV ID QUERY"
. ;
. ; loop thru 355.91 (IB INSURANCE CO LEVEL BILLING PROV ID)
. ; then 355.9 (IB BILLING PRACTITIONER ID)
. F LOOP=355.91,355.9 D LP
. ;
;
D RPTOUT^IBCEQ1A
K ^TMP($J,"SENDMSG")
Q
;
LP ; Loop through ids
N IB,PTYP,PAYER,PLANIEN,FTA,IEPLAN,IPROV,PPROV,EDII,EDIP,PAYERP,TYPCOV,IBPMBPID,PTYPNM,IBI3,IBI0,SEQ,BLUE,TOT,NBLUE,DIR,DTOUT,DUOUT,X,Z,Z0,Z1,BL,UPIN,BCR,BSH
S (SEQ,X,TOT,NBLUE,BLUE)=0,(BCR,BSH,UPIN)=""
S Z="" F S Z=$O(^IBE(355.97,Z)) Q:'Z S Z0=$G(^(Z,0)) D
. I $P(Z,U)["BLUE CROSS" S BCR=Z Q
. I $P(Z,U)["BLUE SHIELD" S BSH=Z Q
. I $P(Z,U)["UPIN" S UPIN=Z Q
S:UPIN="" UPIN=22 S:BCR="" BCR=1 S:BSH="" BSH=2
F S X=$O(^IBA(LOOP,X)) Q:+X=0 D
. S (PAYER,FTA,PLANIEN,IEPLAN,IPROV,PPROV,EDII,EDIP,PAYERP,TYPCOV,IBPMBPID,PTYPNM)=""
. S SEQ=SEQ+1
. S IB=$G(^IBA(LOOP,X,0))
. S PTYP=$P(IB,U,6) ; prov id type ien
. Q:PTYP="" ; no prov type
. S PTYPNM=$P($G(^IBE(355.97,PTYP,0)),U) ; prov id type desc
. S PAYERP=$S(LOOP[".91":+IB,1:+$P(IB,U,2)) ;ins co ien
. S IBI0=$G(^DIC(36,PAYERP,0)),IBI3=$G(^(3)),PAYER=$P(IBI0,U)
. Q:$P(IBI0,U,5)!(IBI0="") ; ins co inactive/deleted
. S EDIP=$P(IBI3,U,2) ; edi id# prof
. S EDII=$P(IBI3,U,4) ; edi id# inst
. S IEPLAN=$P(IBI3,U,9) ; elec ins type ?1N
. S PPROV=$P(IBI0,U,17) ; prof. prov#
. S IPROV=$P(IBI0,U,11) ; hosp. prov#
. S TYPCOV=$P(IBI0,U,13) ; type of cov ien;file 355.2
. S FTA=$P(IB,U,4) ; form type applied; 0:both, 1:ub, 2:1500
. S IBPMBPID=X_";"_LOOP
. I $P(IB,U,7)="VAD000",PTYP'=UPIN D SET(6)
. I PTYP'=BCR&(PTYP'=BSH) D Q ; not BC/BS
.. ; Only do following check once per insurance co
.. Q:$D(^XTMP("IB_PLAN232",3,PAYERP))
.. S ^XTMP("IB_PLAN232",3,PAYERP)=""
.. ; Check if BC/BS ids exist at all for ins co
.. Q:$O(^IBA(355.9,"AC",1,PAYERP,0))!$O(^IBA(355.9,"AC",2,PAYERP,0))!$O(^IBA(355.91,"AC",PAYERP,1,0))!$O(^IBA(355.91,"AC",PAYERP,2,0))
.. S BL=0
.. S Z1=0 F S Z1=$O(^IBA(355.3,"B",PAYERP,Z1)) Q:'Z1 D
... I '$P($G(^IBA(355.3,Z1,0)),U,11),$P($G(^(0)),U,15)="BL" S PLANIEN=Z1,BL=1 D SET(5)
.. S:BL NBLUE=NBLUE+1
. ;
. S BLUE=BLUE+1
. ; ERROR - FORM TYPE=2:1500 AND PTYP=1:BC
. I PTYP=1&(FTA=2) D SET(1) Q
. I PTYP=2&(FTA=1) D SET(2) Q ; BS applied to just UB
. I FTA=0&(PTYP=1) D SET(3) Q ; BC applied to both forms
. ;
. ; Only do following check once per insurance co
. I '$D(^XTMP("IB_PLAN232",2,PAYERP)) D ; Checks plans not BL
.. S Z1=0,^XTMP("IB_PLAN232",2,PAYERP)=""
.. F S Z1=$O(^IBA(355.3,"B",PAYERP,Z1)) Q:'Z1 D
... I $P($G(^IBA(355.3,Z1,0)),U,15)'="BL",'$P(^(0),U,11) S PLANIEN=Z1 D SET(4) Q
;
; 3RD PC XTMP(IB_PLAN232)=TOTAL BLUES WITH NO BLUE IDS
S $P(^XTMP("IB_PLAN232"),U,3)=$P($G(^XTMP("IB_PLAN232")),U,3)+NBLUE
;
; 4TH PC XTMP(IB_PLAN232)=TOT NUMBER SCANNED
S $P(^XTMP("IB_PLAN232"),U,4)=$P($G(^XTMP("IB_PLAN232")),U,4)+SEQ
;
; 5TH PC XTMP(IB_PLAN232)=TOT BLUES IDS FOUND
S $P(^XTMP("IB_PLAN232"),U,5)=$P($G(^XTMP("IB_PLAN232")),U,5)+BLUE
;
; 6TH PC XTMP(IB_PLAN232)=TOTAL ERRORS FOUND
S $P(^XTMP("IB_PLAN232"),U,6)=$P($G(^XTMP("IB_PLAN232")),U,6)+TOT
Q
;
SET(Z) ;SET VALUES INTO SAVE GLOBAL
; Z=REASON WHY WE'RE SETTING IT
; 1. PAYER-ins co name (36)
; 2. PLAN-grp name (355.3)
; 3. GROUP-grp # (355.3)
; 4. FTA-form typ (355.9)
; 5. EPLAN-"BL" (355.3)
; 6. IEPLAN-elec ins typ (36)
; 7. IPROV-hosp prov# (36)
; 8. PPROV-prof prov# (36)
; 9. EDII-inst edi id# (36)
;10. EDIP-prof edi id# (36)
;11. PAYERP-ins co ien (36)
;12. TYPCOV-type of cov ien (36)
;13. PLANIEN-ien of file (355.3)
;14. IBPMBPID-355.9 or 355.91;ien of file
;15. PTYPNM-prov id type desc (355.9)
;16. Z-reason
;
N A,DUP
;
S A=$O(^XTMP("IB_PLAN232",1," "),-1)+1,TOT=TOT+1
S ^XTMP("IB_PLAN232",1,A,0)=PAYER_U_""_U_""_U_FTA_U_""_U_IEPLAN_U_""_U_""_U_""_U_""_U_PAYERP_U_TYPCOV_U_PLANIEN_U_IBPMBPID_U_PTYPNM_U_Z
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEQ1 6074 printed Sep 23, 2025@19:48:23 Page 2
IBCEQ1 ;BSL,ALB/TMK - PROVIDER ID QUERY ;25-AUG-03
+1 ;;2.0;INTEGRATED BILLING;**232,356,349,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;QUERY TOOL HELPS IDENTIFY PLANS THAT ARE LACKING PROVIDER ID
+5 ;INFO OR HAVE BAD PROVIDER ID DATA FOR E-BILLING
+6 ;
+7 ;CONDITIONS TO IDENTIFY:
+8 ;1-BLUE CROSS LINKED TO 1500 ONLY (1) HARD ERROR
+9 ;2-BLUE SHIELD LINKED TO UB-04 ONLY (2) WARNING
+10 ;3-BLUE CROSS ID APPLIED TO BOTH FORMS (0) WARNING
+11 ;4-BLUE CROSS OR BLUE SHIELD IDs EXIST FOR AN INS CO, BUT ONE OR
+12 ; MORE OF THE INSURANCE COMPANY'S PLANS DOES NOT HAVE AN
+13 ; ELECTRONIC PLAN TYPE OF 'BL'
+14 ;5-NON BLUE CROSS/SHIELD ID FOR AN INS COMPANY WITH BLUE PLAN(S)
+15 ;6-VAD000 as an ID but not flagged as a UPIN
+16 ;
EN ;
+1 NEW POP,%ZIS,ZTSK,ZTRTN,ZTDESC,IBREBLD,IBSENDM,IBTO,DIR,X,Y,DUOUT,DTOUT,Z
+2 SET IBREBLD=$SELECT('$DATA(^XTMP("IB_PLAN232")):1,1:0)
+3 IF $DATA(^XTMP("IB_PLAN232"))
Begin DoDot:1
+4 SET DIR("?")="IF YOU ANSWER NO, REPORT WILL BE RUN FROM THE EXISTING QUERY DATA"
SET DIR("?",1)="IF YOU ANSWER YES, A NEW QUERY WILL BE RUN"
+5 SET DIR(0)="YA"
SET DIR("A",1)="THE EXTRACT GLOBAL FOR THIS QUERY ALREADY EXISTS"
SET DIR("A")="DO YOU WANT TO DELETE IT AND RERUN THE QUERY?: "
SET DIR("B")="NO"
WRITE !
DO ^DIR
KILL DIR
+6 if $DATA(DUOUT)!$DATA(DTOUT)!'Y
QUIT
+7 SET IBREBLD=1
End DoDot:1
+8 ;
+9 NEW XMINSTR,Z,ZTSAVE
+10 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB)
+11 SET XMINSTR("ADDR FLAGS")="R"
+12 DO TOWHOM^XMXAPIU(DUZ,"","S",.XMINSTR)
+13 SET Z=""
FOR
SET Z=$ORDER(^TMP("XMY",$JOB,Z))
if Z=""
QUIT
SET IBTO(Z)=""
+14 KILL ^TMP("XMY",$JOB),^TMP("XMY0",$JOB)
+15 ;
+16 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EN1Q
+17 IF $DATA(IO("Q"))
Begin DoDot:1
+18 SET ZTRTN="ENT^IBCEQ1("_IBREBLD_",.IBTO)"
SET ZTDESC="IB - HIPAA ENHANCEMENTS PROV ID QUERY"
SET ZTSAVE("IBTO(")=""
+19 DO ^%ZTLOAD
+20 WRITE !!,$SELECT($DATA(ZTSK):"Task # "_ZTSK_" has been queued.",1:"Unable to queue this job.")
+21 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO EN1Q
+22 USE IO
+23 DO ENT(IBREBLD,.IBTO)
EN1Q QUIT
+1 ;
ENT(IBREBLD,IBTO) ; Queued job enter here
+1 ;
+2 NEW LOOP,Z
+3 KILL ^TMP($JOB,"SENDMSG")
+4 SET ^TMP($JOB,"SENDMSG")=$SELECT(IBREBLD:1,1:0)
+5 SET Z=""
FOR
SET Z=$ORDER(IBTO(Z))
if Z=""
QUIT
SET ^TMP($JOB,"SENDMSG",0,Z)=""
+6 IF $GET(IBREBLD)
Begin DoDot:1
+7 ; Rebld query
+8 KILL ^XTMP("IB_PLAN232")
+9 SET ^XTMP("IB_PLAN232")=""
SET ^XTMP("IB_PLAN232",0)=$$FMADD^XLFDT(DT,45)_U_DT_"^IB PATCH 232 PROV ID QUERY"
+10 ;
+11 ; loop thru 355.91 (IB INSURANCE CO LEVEL BILLING PROV ID)
+12 ; then 355.9 (IB BILLING PRACTITIONER ID)
+13 FOR LOOP=355.91,355.9
DO LP
+14 ;
End DoDot:1
+15 ;
+16 DO RPTOUT^IBCEQ1A
+17 KILL ^TMP($JOB,"SENDMSG")
+18 QUIT
+19 ;
LP ; Loop through ids
+1 NEW IB,PTYP,PAYER,PLANIEN,FTA,IEPLAN,IPROV,PPROV,EDII,EDIP,PAYERP,TYPCOV,IBPMBPID,PTYPNM,IBI3,IBI0,SEQ,BLUE,TOT,NBLUE,DIR,DTOUT,DUOUT,X,Z,Z0,Z1,BL,UPIN,BCR,BSH
+2 SET (SEQ,X,TOT,NBLUE,BLUE)=0
SET (BCR,BSH,UPIN)=""
+3 SET Z=""
FOR
SET Z=$ORDER(^IBE(355.97,Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:1
+4 IF $PIECE(Z,U)["BLUE CROSS"
SET BCR=Z
QUIT
+5 IF $PIECE(Z,U)["BLUE SHIELD"
SET BSH=Z
QUIT
+6 IF $PIECE(Z,U)["UPIN"
SET UPIN=Z
QUIT
End DoDot:1
+7 if UPIN=""
SET UPIN=22
if BCR=""
SET BCR=1
if BSH=""
SET BSH=2
+8 FOR
SET X=$ORDER(^IBA(LOOP,X))
if +X=0
QUIT
Begin DoDot:1
+9 SET (PAYER,FTA,PLANIEN,IEPLAN,IPROV,PPROV,EDII,EDIP,PAYERP,TYPCOV,IBPMBPID,PTYPNM)=""
+10 SET SEQ=SEQ+1
+11 SET IB=$GET(^IBA(LOOP,X,0))
+12 ; prov id type ien
SET PTYP=$PIECE(IB,U,6)
+13 ; no prov type
if PTYP=""
QUIT
+14 ; prov id type desc
SET PTYPNM=$PIECE($GET(^IBE(355.97,PTYP,0)),U)
+15 ;ins co ien
SET PAYERP=$SELECT(LOOP[".91":+IB,1:+$PIECE(IB,U,2))
+16 SET IBI0=$GET(^DIC(36,PAYERP,0))
SET IBI3=$GET(^(3))
SET PAYER=$PIECE(IBI0,U)
+17 ; ins co inactive/deleted
if $PIECE(IBI0,U,5)!(IBI0="")
QUIT
+18 ; edi id# prof
SET EDIP=$PIECE(IBI3,U,2)
+19 ; edi id# inst
SET EDII=$PIECE(IBI3,U,4)
+20 ; elec ins type ?1N
SET IEPLAN=$PIECE(IBI3,U,9)
+21 ; prof. prov#
SET PPROV=$PIECE(IBI0,U,17)
+22 ; hosp. prov#
SET IPROV=$PIECE(IBI0,U,11)
+23 ; type of cov ien;file 355.2
SET TYPCOV=$PIECE(IBI0,U,13)
+24 ; form type applied; 0:both, 1:ub, 2:1500
SET FTA=$PIECE(IB,U,4)
+25 SET IBPMBPID=X_";"_LOOP
+26 IF $PIECE(IB,U,7)="VAD000"
IF PTYP'=UPIN
DO SET(6)
+27 ; not BC/BS
IF PTYP'=BCR&(PTYP'=BSH)
Begin DoDot:2
+28 ; Only do following check once per insurance co
+29 if $DATA(^XTMP("IB_PLAN232",3,PAYERP))
QUIT
+30 SET ^XTMP("IB_PLAN232",3,PAYERP)=""
+31 ; Check if BC/BS ids exist at all for ins co
+32 if $ORDER(^IBA(355.9,"AC",1,PAYERP,0))!$ORDER(^IBA(355.9,"AC",2,PAYERP,0))!$ORDER(^IBA(355.91,"AC",PAYERP,1,0))!$ORDER(^IBA(355.91,"AC",PAYERP,2,0))
QUIT
+33 SET BL=0
+34 SET Z1=0
FOR
SET Z1=$ORDER(^IBA(355.3,"B",PAYERP,Z1))
if 'Z1
QUIT
Begin DoDot:3
+35 IF '$PIECE($GET(^IBA(355.3,Z1,0)),U,11)
IF $PIECE($GET(^(0)),U,15)="BL"
SET PLANIEN=Z1
SET BL=1
DO SET(5)
End DoDot:3
+36 if BL
SET NBLUE=NBLUE+1
End DoDot:2
QUIT
+37 ;
+38 SET BLUE=BLUE+1
+39 ; ERROR - FORM TYPE=2:1500 AND PTYP=1:BC
+40 IF PTYP=1&(FTA=2)
DO SET(1)
QUIT
+41 ; BS applied to just UB
IF PTYP=2&(FTA=1)
DO SET(2)
QUIT
+42 ; BC applied to both forms
IF FTA=0&(PTYP=1)
DO SET(3)
QUIT
+43 ;
+44 ; Only do following check once per insurance co
+45 ; Checks plans not BL
IF '$DATA(^XTMP("IB_PLAN232",2,PAYERP))
Begin DoDot:2
+46 SET Z1=0
SET ^XTMP("IB_PLAN232",2,PAYERP)=""
+47 FOR
SET Z1=$ORDER(^IBA(355.3,"B",PAYERP,Z1))
if 'Z1
QUIT
Begin DoDot:3
+48 IF $PIECE($GET(^IBA(355.3,Z1,0)),U,15)'="BL"
IF '$PIECE(^(0),U,11)
SET PLANIEN=Z1
DO SET(4)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;
+50 ; 3RD PC XTMP(IB_PLAN232)=TOTAL BLUES WITH NO BLUE IDS
+51 SET $PIECE(^XTMP("IB_PLAN232"),U,3)=$PIECE($GET(^XTMP("IB_PLAN232")),U,3)+NBLUE
+52 ;
+53 ; 4TH PC XTMP(IB_PLAN232)=TOT NUMBER SCANNED
+54 SET $PIECE(^XTMP("IB_PLAN232"),U,4)=$PIECE($GET(^XTMP("IB_PLAN232")),U,4)+SEQ
+55 ;
+56 ; 5TH PC XTMP(IB_PLAN232)=TOT BLUES IDS FOUND
+57 SET $PIECE(^XTMP("IB_PLAN232"),U,5)=$PIECE($GET(^XTMP("IB_PLAN232")),U,5)+BLUE
+58 ;
+59 ; 6TH PC XTMP(IB_PLAN232)=TOTAL ERRORS FOUND
+60 SET $PIECE(^XTMP("IB_PLAN232"),U,6)=$PIECE($GET(^XTMP("IB_PLAN232")),U,6)+TOT
+61 QUIT
+62 ;
SET(Z) ;SET VALUES INTO SAVE GLOBAL
+1 ; Z=REASON WHY WE'RE SETTING IT
+2 ; 1. PAYER-ins co name (36)
+3 ; 2. PLAN-grp name (355.3)
+4 ; 3. GROUP-grp # (355.3)
+5 ; 4. FTA-form typ (355.9)
+6 ; 5. EPLAN-"BL" (355.3)
+7 ; 6. IEPLAN-elec ins typ (36)
+8 ; 7. IPROV-hosp prov# (36)
+9 ; 8. PPROV-prof prov# (36)
+10 ; 9. EDII-inst edi id# (36)
+11 ;10. EDIP-prof edi id# (36)
+12 ;11. PAYERP-ins co ien (36)
+13 ;12. TYPCOV-type of cov ien (36)
+14 ;13. PLANIEN-ien of file (355.3)
+15 ;14. IBPMBPID-355.9 or 355.91;ien of file
+16 ;15. PTYPNM-prov id type desc (355.9)
+17 ;16. Z-reason
+18 ;
+19 NEW A,DUP
+20 ;
+21 SET A=$ORDER(^XTMP("IB_PLAN232",1," "),-1)+1
SET TOT=TOT+1
+22 SET ^XTMP("IB_PLAN232",1,A,0)=PAYER_U_""_U_""_U_FTA_U_""_U_IEPLAN_U_""_U_""_U_""_U_""_U_PAYERP_U_TYPCOV_U_PLANIEN_U_IBPMBPID_U_PTYPNM_U_Z
+23 QUIT
+24 ;
