source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEQ1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1IBCEQ1 ;BSL,ALB/TMK - PROVIDER ID QUERY ;25-AUG-03
2 ;;2.0;INTEGRATED BILLING;**232,356,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;QUERY TOOL HELPS IDENTIFY PLANS THAT ARE LACKING PROVIDER ID
6 ;INFO OR HAVE BAD PROVIDER ID DATA FOR E-BILLING
7 ;
8 ;CONDITIONS TO IDENTIFY:
9 ;1-BLUE CROSS LINKED TO 1500 ONLY (1) HARD ERROR
10 ;2-BLUE SHIELD LINKED TO UB-04 ONLY (2) WARNING
11 ;3-BLUE CROSS ID APPLIED TO BOTH FORMS (0) WARNING
12 ;4-BLUE CROSS OR BLUE SHIELD IDs EXIST FOR AN INS CO, BUT ONE OR
13 ; MORE OF THE INSURANCE COMPANY'S PLANS DOES NOT HAVE AN
14 ; ELECTRONIC PLAN TYPE OF 'BL'
15 ;5-NON BLUE CROSS/SHIELD ID FOR AN INS COMPANY WITH BLUE PLAN(S)
16 ;6-VAD000 as an ID but not flagged as a UPIN
17 ;
18EN ;
19 N POP,%ZIS,ZTSK,ZTRTN,ZTDESC,IBREBLD,IBSENDM,IBTO,DIR,X,Y,DUOUT,DTOUT,Z
20 S IBREBLD=$S('$D(^XTMP("IB_PLAN232")):1,1:0)
21 I $D(^XTMP("IB_PLAN232")) D
22 . 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"
23 . 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
24 . Q:$D(DUOUT)!$D(DTOUT)!'Y
25 . S IBREBLD=1
26 ;
27 N XMINSTR,Z,ZTSAVE
28 K ^TMP("XMY",$J),^TMP("XMY0",$J)
29 S XMINSTR("ADDR FLAGS")="R"
30 D TOWHOM^XMXAPIU(DUZ,"","S",.XMINSTR)
31 S Z="" F S Z=$O(^TMP("XMY",$J,Z)) Q:Z="" S IBTO(Z)=""
32 K ^TMP("XMY",$J),^TMP("XMY0",$J)
33 ;
34 S %ZIS="QM" D ^%ZIS G:POP EN1Q
35 I $D(IO("Q")) D G EN1Q
36 . S ZTRTN="ENT^IBCEQ1("_IBREBLD_",.IBTO)",ZTDESC="IB - HIPAA ENHANCEMENTS PROV ID QUERY",ZTSAVE("IBTO(")=""
37 . D ^%ZTLOAD
38 . W !!,$S($D(ZTSK):"Task # "_ZTSK_" has been queued.",1:"Unable to queue this job.")
39 . K ZTSK,IO("Q") D HOME^%ZIS
40 U IO
41 D ENT(IBREBLD,.IBTO)
42EN1Q Q
43 ;
44ENT(IBREBLD,IBTO) ; Queued job enter here
45 ;
46 N LOOP,Z
47 K ^TMP($J,"SENDMSG")
48 S ^TMP($J,"SENDMSG")=$S(IBREBLD:1,1:0)
49 S Z="" F S Z=$O(IBTO(Z)) Q:Z="" S ^TMP($J,"SENDMSG",0,Z)=""
50 I $G(IBREBLD) D
51 . ; Rebld query
52 . K ^XTMP("IB_PLAN232")
53 . S ^XTMP("IB_PLAN232")="",^XTMP("IB_PLAN232",0)=$$FMADD^XLFDT(DT,45)_U_DT_"^IB PATCH 232 PROV ID QUERY"
54 . ;
55 . ; loop thru 355.91 (IB INSURANCE CO LEVEL BILLING PROV ID)
56 . ; then 355.9 (IB BILLING PRACTITIONER ID)
57 . F LOOP=355.91,355.9 D LP
58 . ;
59 ;
60 D RPTOUT^IBCEQ1A
61 K ^TMP($J,"SENDMSG")
62 Q
63 ;
64LP ; Loop through ids
65 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
66 S (SEQ,X,TOT,NBLUE,BLUE)=0,(BCR,BSH,UPIN)=""
67 S Z="" F S Z=$O(^IBE(355.97,Z)) Q:'Z S Z0=$G(^(Z,0)) D
68 . I $P(Z,U)["BLUE CROSS" S BCR=Z Q
69 . I $P(Z,U)["BLUE SHIELD" S BSH=Z Q
70 . I $P(Z,U)["UPIN" S UPIN=Z Q
71 S:UPIN="" UPIN=22 S:BCR="" BCR=1 S:BSH="" BSH=2
72 F S X=$O(^IBA(LOOP,X)) Q:+X=0 D
73 . S (PAYER,FTA,PLANIEN,IEPLAN,IPROV,PPROV,EDII,EDIP,PAYERP,TYPCOV,IBPMBPID,PTYPNM)=""
74 . S SEQ=SEQ+1
75 . S IB=$G(^IBA(LOOP,X,0))
76 . S PTYP=$P(IB,U,6) ; prov id type ien
77 . Q:PTYP="" ; no prov type
78 . S PTYPNM=$P($G(^IBE(355.97,PTYP,0)),U) ; prov id type desc
79 . S PAYERP=$S(LOOP[".91":+IB,1:+$P(IB,U,2)) ;ins co ien
80 . S IBI0=$G(^DIC(36,PAYERP,0)),IBI3=$G(^(3)),PAYER=$P(IBI0,U)
81 . Q:$P(IBI0,U,5)!(IBI0="") ; ins co inactive/deleted
82 . S EDIP=$P(IBI3,U,2) ; edi id# prof
83 . S EDII=$P(IBI3,U,4) ; edi id# inst
84 . S IEPLAN=$P(IBI3,U,9) ; elec ins type ?1N
85 . S PPROV=$P(IBI0,U,17) ; prof. prov#
86 . S IPROV=$P(IBI0,U,11) ; hosp. prov#
87 . S TYPCOV=$P(IBI0,U,13) ; type of cov ien;file 355.2
88 . S FTA=$P(IB,U,4) ; form type applied; 0:both, 1:ub, 2:1500
89 . S IBPMBPID=X_";"_LOOP
90 . I $P(IB,U,7)="VAD000",PTYP'=UPIN D SET(6)
91 . ;
92 . I PTYP'=BCR&(PTYP'=BSH) D Q ; not BC/BS
93 .. ; Only do following check once per insurance co
94 .. Q:$D(^XTMP("IB_PLAN232",3,PAYERP))
95 .. S ^XTMP("IB_PLAN232",3,PAYERP)=""
96 .. ; Check if BC/BS ids exist at all for ins co
97 .. 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))
98 .. S BL=0
99 .. S Z1=0 F S Z1=$O(^IBA(355.3,"B",PAYERP,Z1)) Q:'Z1 D
100 ... I '$P($G(^IBA(355.3,Z1,0)),U,11),$P($G(^(0)),U,15)="BL" S PLANIEN=Z1,BL=1 D SET(5)
101 .. S:BL NBLUE=NBLUE+1
102 . ;
103 . S BLUE=BLUE+1
104 . ; ERROR - FORM TYPE=2:1500 AND PTYP=1:BC
105 . I PTYP=1&(FTA=2) D SET(1) Q
106 . ;
107 . I PTYP=2&(FTA=1) D SET(2) Q ; BS applied to just UB
108 . I FTA=0&(PTYP=1) D SET(3) Q ; BC applied to both forms
109 . ;
110 . ; Only do following check once per insurance co
111 . I '$D(^XTMP("IB_PLAN232",2,PAYERP)) D ; Checks plans not BL
112 .. S Z1=0,^XTMP("IB_PLAN232",2,PAYERP)=""
113 .. F S Z1=$O(^IBA(355.3,"B",PAYERP,Z1)) Q:'Z1 D
114 ... I $P($G(^IBA(355.3,Z1,0)),U,15)'="BL",'$P(^(0),U,11) S PLANIEN=Z1 D SET(4) Q
115 ;
116 ; 3RD PC XTMP(IB_PLAN232)=TOTAL BLUES WITH NO BLUE IDS
117 S $P(^XTMP("IB_PLAN232"),U,3)=$P($G(^XTMP("IB_PLAN232")),U,3)+NBLUE
118 ;
119 ; 4TH PC XTMP(IB_PLAN232)=TOT NUMBER SCANNED
120 S $P(^XTMP("IB_PLAN232"),U,4)=$P($G(^XTMP("IB_PLAN232")),U,4)+SEQ
121 ;
122 ; 5TH PC XTMP(IB_PLAN232)=TOT BLUES IDS FOUND
123 S $P(^XTMP("IB_PLAN232"),U,5)=$P($G(^XTMP("IB_PLAN232")),U,5)+BLUE
124 ;
125 ; 6TH PC XTMP(IB_PLAN232)=TOTAL ERRORS FOUND
126 S $P(^XTMP("IB_PLAN232"),U,6)=$P($G(^XTMP("IB_PLAN232")),U,6)+TOT
127 Q
128 ;
129SET(Z) ;SET VALUES INTO SAVE GLOBAL
130 ; Z=REASON WHY WE'RE SETTING IT
131 ; 1. PAYER-ins co name (36)
132 ; 2. PLAN-grp name (355.3)
133 ; 3. GROUP-grp # (355.3)
134 ; 4. FTA-form typ (355.9)
135 ; 5. EPLAN-"BL" (355.3)
136 ; 6. IEPLAN-elec ins typ (36)
137 ; 7. IPROV-hosp prov# (36)
138 ; 8. PPROV-prof prov# (36)
139 ; 9. EDII-inst edi id# (36)
140 ;10. EDIP-prof edi id# (36)
141 ;11. PAYERP-ins co ien (36)
142 ;12. TYPCOV-type of cov ien (36)
143 ;13. PLANIEN-ien of file (355.3)
144 ;14. IBPMBPID-355.9 or 355.91;ien of file
145 ;15. PTYPNM-prov id type desc (355.9)
146 ;16. Z-reason
147 ;
148 N A,DUP
149 ;
150 S A=$O(^XTMP("IB_PLAN232",1," "),-1)+1,TOT=TOT+1
151 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
152 Q
153 ;
Note: See TracBrowser for help on using the repository browser.