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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; -- main entry point for IBCE PRV MAINT
6 N IBPRV,IBINS
7EN1 ; Entrypoint for non-VA provider ID maintenance hook
8 N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
9 K IBFASTXT
10 S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
11 D FULL^VALM1
12 S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
13 S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
14 S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";")
15 W ! D ^DIR K DIR W !
16 I Y'>0 Q
17 S IBSLEV=+Y
18 D EN^VALM("IBCE PRVPRV MAINT")
19 Q
20 ;
21HDR ; -- header code
22 N IBC,Z,IBIF
23 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
24 K VALMHDR
25 S IBC=1
26 S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider")
27 S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
28 S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1
29 I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1
30 I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1
31 I $G(IBINS) D
32 . N PCF,PCDISP
33 . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13)
34 . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
35 . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
36 Q
37 ;
38INIT ; -- init variables and list array
39 N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
40 ;
41 K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session
42 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
43 ;
44 ; Removing Care Unit under certain conditions
45 ; This list is used for multiple purposes and not all have Care Units Associated with them
46 ; Also, a different protocol menu is used with these
47 ; IBNPRV is a non VA provider
48 ; IBIF = 1 means this is a group or facility, not an individual.
49 ;
50 I $G(IBNPRV),$G(IBIF)=1 D
51 . S VALM("TITLE")="Secondary Provider ID"
52 . K VALMDDF("CAREUNIT")
53 . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2)
54 . K VALM("PROTOCOL")
55 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
56 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
57 ;
58 I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE
59 I '$G(IBPRV) D G:$G(VALMQUIT) INITQ
60 . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V"
61 . D ^DIR K DIR
62 . I "NV"'[Y!(Y="") S VALMQUIT=1 Q
63 . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,")
64 . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"")
65 . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
66 . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04"
67 . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q
68 .. D ^DIC
69 .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
70 .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q
71 .. S IBPRV=+Y_";"_IBFILE
72 ;
73AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ
74 . S AGAIN=0
75 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
76 . D ^DIR K DIR
77 . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
78 . S IBINS=$S(Y>0:+Y,1:"NO")
79 . I $G(IBPRV)'["VA(200," Q ; Only VA providers
80 . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q
81 .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted."
82 ;
83 E D
84 . S IBINS="NO"
85 D BLD
86INITQ Q
87 ;
88BLD ; Build initial display
89 ; Assumes IBPRV = the variable ptr for prov id file (355.9)
90 ; IBINS = the ien of the ins co or if null, ALL is assumed
91 ; IBSLEV = 1 to display only provider default ids
92 ; = 2 to display all provider/insurance co ids
93 N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF
94 ;
95 S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
96 ;
97 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J)
98 K Z0
99 S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1
100 F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D
101 . S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D
102 .. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D
103 ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7)
104 ;
105 I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12)
106 S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D
107 . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1))
108 . S PT=""
109 . F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D
110 .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D
111 ... S IBLCT=IBLCT+1,IBCT=IBCT+1
112 ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")
113 ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)
114 ... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*"
115 ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT)
116 ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV)
117 I IBSLEV=1,IBPRV["VA(200" D
118 . N IBP
119 . S IBP=+IBPRV
120 . Q:'$$GETLIC^IBCEP5D(.IBP)
121 . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT)
122 . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D
123 .. S IBLCT=IBLCT+1,IBCT=IBCT+1
124 .. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT)
125 .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV
126 K ^TMP("IBPRV_SORT",$J)
127 ;
128 I IBLCT=0 D G BLDQ ; No entries for ins co selected
129 . D SET^VALM10(1," ")
130 . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co"))
131 . S IBLCT=2
132 ;
133BLDQ K VALMCNT,VALMBG
134 S VALMCNT=IBLCT,VALMBG=1
135 Q
136 ;
137HELP ; -- help code
138 S X="?" D DISP^XQORM1 W !!
139 Q
140 ;
141EXIT ; -- exit code
142 D COPYPROV^IBCEP5A(IBINS)
143 K IBPRV
144 D CLEAN^VALM10
145 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL
146 Q
147 ;
148EXPND ; -- expand code
149 Q
150 ;
151SEL(IBDA,MANY) ; Select from provider id list
152 ; IBDA is passed by reference and IBDA(1) returned containing
153 ; ien's of the provider id records selected (file 355.9).
154 ; If > 1 entry can be selected, MANY is set to 1
155 N Z
156 S IBDA=0
157 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
158 S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z))
159 Q
160 ;
Note: See TracBrowser for help on using the repository browser.