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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1IBCEP5B ;ALB/TMP - EDI UTILITIES for prov ID ;29-SEP-00
2 ;;2.0;INTEGRATED BILLING;**137,239,232,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5NEWID(IBFILE,IBINS,IBPRV,IBPTYP,IBIEN,IBF) ; Generic add prov id
6 ; at both prov (file 355.9) and ins co levels (355.91)
7 ; IBFILE = 355.9 or 355.91 - the file being edited
8 ; IBINS = ien of ins co (36) or *ALL* for all ins co
9 ; IBPRV = vp ien of billing prov
10 ; IBPTYP = ien of prov type (file 355.97)
11 ; IBIEN = ien of entry being added (req'd)
12 ; IBF = 1 if deleting from ins-related options, "" from prov-related
13 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT,IBQ,IBCUND,IB3559,IB35591,Q,IBDR,IBID,AFT
14 S IB35591(.03)="",IBPTYP=$G(IBPTYP)
15 F Z=.04,.05,.03 D G:Z="" NEWQ
16 . I $S(Z'=.03:1,1:$S('$G(IBINS):0,1:$G(IBCUND))) D Q:Z=""
17 .. N DA
18 .. I Z'=.03 S DIR(0)=IBFILE_","_Z
19 .. I Z=.03 D
20 ... S DIR(0)="PAO^355.95:AEMQ"
21 ... S DIR("S")="I $O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,"_$G(IB3559(.04))_","_$G(IB3559(.05))_","_IBPTYP_",0))!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,"_$G(IB3559(.04))_",0,"_IBPTYP_",0)))"
22 ... S DIR("S")=DIR("S")_"!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,0,"_$G(IB3559(.05))_","_IBPTYP_",0)))!($O(^IBA(355.96,""AUNIQ"","_IBINS_",Y,0,0,"_IBPTYP_",0)))"
23 ... S DIR("?",1)="Care unit describes areas of service and is assigned by the payer, if",DIR("?")=" applicable. Use Care Unit Maintenance to add or modify care units."
24 .. ;
25 .. I Z=.04,IBPRV["355.93",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
26 ... I $$GET1^DIQ(355.97,IBPTYP,.03,"I")="EI" S $P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
27 ... I $$GET1^DIQ(355.97,IBPTYP,.03,"I")="TJ" S $P(DIR(0),U,3)="K:Y'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
28 ... N AFT
29 ... S AFT=$$GET1^DIQ(355.97,IBPTYP,.07,"I") ; get allowable form type for this Provider ID Type
30 ... I AFT="B" S $P(DIR(0),U,3)="K:"".0.1.2.""'[("".""_Y_""."") X",DIR("?")="Provider ID Qualifier selected allows institutional, professional or both" Q
31 ... I AFT="P" S $P(DIR(0),U,3)="K:Y'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
32 ... I AFT="I" S $P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
33 .. ;
34 .. S DA=0
35 .. I Z=.04,$P($G(^IBE(355.97,+IBPTYP,0)),U,3)="1A" D SETDIR(.DIR)
36 .. D ^DIR K DIR
37 .. I $D(DTOUT)!$D(DUOUT) S Z="" K IB3559,IB35591 Q
38 .. S IB3559(Z)=$S(Z'=.03:$P(Y,U),1:$S($P(Y,U)>0:$P(Y,U),1:"*N/A*"))
39 . I Z=.05 D
40 .. S IBCUND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IB3559(.04),IB3559(.05),IB3559(.05)=3)
41 .. S:'IBCUND!($G(IB3559(.03))=0) IB3559(.03)="*N/A*"
42 .. I '$G(IBINS) S IBINS="*ALL*"
43 . I Z=.03 D CAREUN^IBCEP5C
44 ;
45 I $D(IB3559) D
46 . N Q,Z2,Z3,Z4,Z5,Z6,IBLAST,IBOK,DIR,Y,X
47 . S IBLAST=0
48 . D DISP^IBCEP4("Q",IBINS,IBPTYP,IB3559(.04),IB3559(.05),1)
49 . W !!,"THE FOLLOWING WAS CHOSEN:"
50 . S Q=0 F S Q=$O(Q(Q)) Q:'Q W !,?3,Q(Q)
51 . I IBCUND W !,?3,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB3559(.03))
52 . S Z2=IBINS,Z3=IB35591(.03),Z4=IB3559(.04),Z5=IB3559(.05),Z6=IBPTYP
53 . S IBOK=1
54 . ; If both forms, chk for specific
55 . I 'Z4 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_4_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,1,$G(IBFILE)=355.91)
56 . ; If specific form, chk for all
57 . I IBOK,Z4 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_4_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,0,$G(IBFILE)=355.91)
58 . ; If both care types, chk for specific
59 . I IBOK,'Z5 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_5_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,1,$G(IBFILE)=355.91)
60 . ; If specific care type, chk for all
61 . I IBOK,Z5 S IBOK=$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_5_U_Z2_U_Z3_U_Z4_U_Z5_U_Z6,0,$G(IBFILE)=355.91)
62 . I 'IBOK K IB3559,IB35591
63 . I IBOK D
64 .. S DIR(0)=IBFILE_",.07"
65 .. W ! D ^DIR K DIR
66 .. S IBID=Y
67 .. I $D(DTOUT)!$D(DUOUT) K IB3559,IB35591 S IBOK=0 Q
68 .. S IBDR=$S(IBFILE=355.9:$S($G(IBINS):".02////"_IBINS_";",1:""),1:"")_$S($G(IBCUND):".03////"_$S(IB35591(.03):IB35591(.03),1:"*N/A*")_";",1:"")_".04////"_IB3559(.04)_";.05////"_IB3559(.05)_";.06////"_IBPTYP_$S(IBID'="":";.07////"_IBID,1:"")
69 .. ;
70 .. I $G(IBIEN) D
71 ... S DR=IBDR,DA=IBIEN,DIE="^IBA("_IBFILE_","
72 ... D ^DIE
73 ... I $D(Y) K IB3559,IB35591 S IBOK=0
74 ;
75NEWQ ;
76 I '$D(IB3559),$G(IBIEN) D Q
77 . N DIR,DIK,DA,X,Y
78 . S DA=IBIEN,DIK="^IBA("_IBFILE_"," D ^DIK
79 . S DIR(0)="EA",DIR("A",1)=$S('$G(IBOK):"",1:"PROBLEM ENCOUNTERED FILING THE RECORD - ")_"RECORD NOT ADDED",DIR("A")="PRESS ENTER to continue " W ! D ^DIR K DIR
80 ;
81 ; Save this for Copy ID actions
82 I $G(IBIEN) D
83 . I IBFILE=355.91!(IBFILE=355.9&($P($G(^IBA(IBFILE,IBIEN,0)),U)["VA(200,")) D
84 .. N NEXTONE S NEXTONE=$$NEXTONE^IBCEP5A()
85 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBIEN_U_"ADD"_U_IBFILE
86 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=$G(^IBA(IBFILE,IBIEN,0))
87 Q
88 ;
89CHG(IBFILE,IBDA) ; Generic call - edit prov id
90 ; IBFILE = 355.9 or 355.91 (file being edited)
91 ; IBDA = ien in file
92 ;
93 N DIR,DIE,DA,DR,IBCUCHK,IBOK,IB0,IBOLD,X,Y,Z
94 F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T W !,"Attempting to lock record"
95 I '$T D G CHGQ
96 . W !,"RECORD LOCKED BY ANOTHER USER - TRY AGAIN LATER"
97 . D ENTER(.DIR)
98 . W ! D ^DIR K DIR W !
99 S (IB0,IBOLD)=$G(^IBA(IBFILE,IBDA,0))
100 G:IB0="" CHGQ
101 F Z=.04,.05,.06,.03 S IBOK=$$EDIT(IBFILE,Z,IB0,IBOLD,IBDA,0) S:IBOK="*ALL*" IBOK="" Q:$P(IBOK,U,2) S $P(IB0,U,Z*100)=$P(IBOK,U)
102 I $P(IBOK,U,2) S DIR(0)="EA",DIR("A")="NO CHANGES MADE, PRESS ENTER TO CONTINUE: " W ! D ^DIR K DIR W ! G CHGQ
103 S IBOK=$$EDIT(IBFILE,.07,IB0,IBOLD,IBDA,1)
104 I '$P(IBOK,U,2) S $P(IB0,U,7)=$P(IBOK,U)
105 I $P(IBOK,U,2)!(IB0=IBOLD) S DIR(0)="EA",DIR("A")="NO CHANGES MADE, PRESS ENTER TO CONTINUE: " W ! D ^DIR K DIR W ! G CHGQ
106 S IBCUCHK=$$CUCHK^IBCEP5C(IBDA,IB0) G:IBCUCHK CHGQ
107 S DR=""
108 F Z=2,4:1:7,3 I $P(IB0,U,Z)'=$P(IBOLD,U,Z) S DR=DR_$S(DR'="":";",1:"")_(Z/100)_"///"_$S($P(IB0,U,Z)'="@":"/",1:"")_$P(IB0,U,Z)
109 I DR'="" D
110 . I IBFILE=355.91!(IBFILE=355.9&($P(IB0,U)["VA(200,")) D
111 .. N NEXTONE
112 .. S NEXTONE=$$NEXTONE^IBCEP5A()
113 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"MOD"_U_IBFILE_U_IBDA
114 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,"OLD0")=IBOLD
115 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=IB0
116 . S DIE="^IBA("_IBFILE_",",DA=IBDA D ^DIE
117CHGQ L -^IBA(IBFILE,IBDA)
118 Q
119 ;
120DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's
121 ; IBFILE = 355.9 or 355.91 for the file
122 ; IBDA = ien of entry in file IBFILE
123 ; IBF = 1 if deleting from ins co-related options, ""
124 ; from prov-related options
125 D DEL^IBCEP5C(IBFILE,IBDA,$G(IBF))
126 Q
127 ;
128EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
129 Q $$EDIT^IBCEP5D($G(IBFILE),$G(IBFLD),$G(IB0),$G(IBOLD),$G(IBIEN),$G(IBCK1))
130 ;
131SETDIR(DIR) ; Sets dir for BLUE CROSS only UB-04 form type
132 S DIR("B")="UB-04",$P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="ONLY UB-04 FORM TYPE IS VALID FOR BLUE CROSS ID"
133 Q
134 ;
135ENTER(DIR) ;
136 S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE: "
137 Q
Note: See TracBrowser for help on using the repository browser.