source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP7C.m@ 1610

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1IBCEP7C ;ALB/TMP - Functions for fac level PROVIDER ID MAINT ;11-07-00
2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 G AWAY
6AWAY Q
7 ;
8 ; IBDA - IEN for file 355.92
9 ; IBFUNC = "A"dd or "E"dit
10FACFLDS(IBDA,IBINS,IBITYP,IBFORM,IBDIV,IBFUNC,IBCAREUN,IBEFTFL) ; Chk for dups on fac id fld combos
11 ;
12 N IB,IBOK,DIC,DIR,X,Y,DTOUT,DUOUT,Z,Z0,DIE,DA,IBMAIN,IBQUIT,IBPARAM,IBCUF,IBDA0,IBCNTADD,I,IBLIMIT
13 ;
14 S IBOK=0,IBDA0=""
15 I $G(IBDA) S IBDA0=$G(^IBA(355.92,IBDA,0))
16 S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J))
17 S IBCUF=$S($P(IBDA0,U,3)]"":1,1:0) ; Care Unit Flag
18 ;
19 I IBEFTFL="E",IBFUNC="A" D G:$D(DTOUT)!$D(DUOUT) FLDSQ
20 . K DIR
21 . S DIR("A")="Define Billing Provider Secondary IDs by Care Units? "
22 . S DIR("B")="No"
23 . S DIR(0)="YAO"
24 . S DIR("?",1)="Enter No to define a Billing Provider Secondary ID for the Division."
25 . S DIR("?",2)="Enter Yes to define a Billing Provider Secondary ID for a specific Care Unit."
26 . S DIR("?",3)="If no Care Unit is entered on Billing Screen 3, the Billing Provider"
27 . S DIR("?")="Secondary ID defined for the Division will be transmitted in the claim."
28 . D ^DIR
29 . S IBCUF=$G(Y) ; Care Unit Flag
30 ;
31 ; Get the Division
32 S IBMAIN=$$MAIN^IBCEP2B()
33 S IBDIV=0
34 I IBEFTFL="E"!(IBEFTFL="LF") D G:$D(DTOUT)!$D(DUOUT) FLDSQ
35 . K DIR
36 . S (IBQUIT,IBOK)=0,DA=$G(IBDA)
37 . S DIR("A")="Division: ",DIR(0)="355.92,.05AOr"
38 . ; Default Division - Main if adding or Existing if editing
39 . I IBFUNC="E" S DIR("B")=$P($$DIV^IBCEP7($P(IBDA0,U,5)),"/")
40 . I IBFUNC="A" S DIR("B")=$P($$EXTERNAL^DILFD(355.92,.05,"",IBMAIN),"/")
41 . D ^DIR K DIR
42 . Q:$D(DTOUT)!$D(DUOUT)
43 . S IBDIV=+$S(Y>0:+Y,1:0)
44 ;
45 ; See if there are any Care Units
46 S IBCAREUN="*N/A*"
47 I IBEFTFL="E",IBCUF D
48 . N TAR
49 . D LIST^DIC(355.95,,.01,,,,,,"I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",,"TAR")
50 . Q:+$G(TAR("DILIST",0))
51 . S IBCUF=0
52 . W !!,"There are no Care Units defined for this Division.",!
53 ;
54 ; Get the Care Unit
55 I IBEFTFL="E",IBCUF D I Y<1 G FLDSQ
56 . K DIC
57 . S DIC("A")="Care Unit: "
58 . I IBFUNC="E" D ; default only if editing
59 .. Q:IBDIV'=$P(IBDA0,U,5) ; don't default if division has changed
60 .. S DIC("B")=$$EXTERNAL^DILFD(355.92,.03,"",$P(IBDA0,U,3))
61 . S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
62 . D ^DIC
63 . I Y>0 S IBCAREUN=+Y
64 ;
65 ; Think this is done for sorting purposes. Makes the main division first
66 I IBDIV=IBMAIN S IBDIV=0
67 ;
68 ; Get the Provider ID Type
69 K DIR
70 S IBQUIT=0
71 I $P(IBPARAM,U,3)'=1 D
72 . S DIR("?")="Can NOT be State LIC # or Billing Facility Primary"
73 . S DIR("A")="ID Qualifier: "
74 . S DIR(0)="355.92,.06A^^K:'$$FACID^IBCEP7(+Y)!$P($G(^IBE(355.97,+Y,1)),U,9)!($P($G(^(0)),U,3)=""0B"") X"
75 . W ! D ^DIR K DIR
76 . I $D(DTOUT)!$D(DUOUT) S IBQUIT=1
77 E D G:$D(DTOUT)!$D(DUOUT) FLDSQ
78 . S DIR("A")="ID Qualifier: " ;,DIR(0)="355.92,.06Ar"
79 . S DIR(0)="PAr^355.97:AEMQ"
80 . S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
81 . ; Default Type of ID - Electronic Plan Type if adding or Existing if editing
82 . N PITIEN S PITIEN=$S(IBFUNC="A"&(IBEFTFL="E"):$$BF^IBCU(),IBFUNC="E":$P(IBDA0,U,6),1:"")
83 . I PITIEN]"" S DIR("B")=$P($G(^IBE(355.97,PITIEN,0)),U)
84 . I IBEFTFL="E" D
85 .. S DIR("?",1)=" The current default ID Qualifier is based upon the Electronic Plan Type."
86 .. S DIR("?",2)=" You may change the ID Qualifier and the change will apply to all Plan"
87 .. S DIR("?")=" Types."
88 .. S DIR("S")="I ($P($G(^(0)),U,3)=$P($G(^IBE(355.97,PITIEN,0)),U,3))!$$BPS^IBCEPU(Y)"
89 . I IBEFTFL="A" S DIR("S")="I $$BPS^IBCEPU(Y)"
90 . I IBEFTFL="LF" S DIR("S")="I $$LFINS^IBCEPU(Y)"
91 . D ^DIR K DIR
92 G:IBQUIT FLDSQ
93 S IBITYP=$P(Y,U)
94 ;
95 ; Get Form Type
96 K DIR
97 S DIR("A")="Form Type: "
98 S DIR(0)=$S(IBEFTFL="LF":"SA^0:BOTH;1:UB-04;2:CMS-1500",1:"SA^1:UB-04;2:CMS-1500")
99 ;
100 I $G(IBDA) S DIR("B")=$S(+$P($G(^IBA(355.92,IBDA,0)),U,4)=0:"BOTH",1:$P("UB-04^CMS-1500",U,+$P($G(^IBA(355.92,IBDA,0)),U,4)))
101 ;
102 D ^DIR K DIR
103 G:$D(DTOUT)!$D(DUOUT) FLDSQ
104 S IBFORM=$P(Y,U)
105 ;
106 ; Set up array of exisiting IDs by form type, divison, and care units to avoid duplications
107 S Z=0 F S Z=$O(^IBA(355.92,"B",IBINS,Z)) Q:'Z D
108 . S Z0=$G(^IBA(355.92,Z,0))
109 . I '(IBFUNC="E"&(Z=IBDA)) D
110 .. I IBEFTFL="LF",$P(Z0,U,8)'="LF" Q ; If lab/facility ID, it only needs to be unique among lab/facility IDs
111 .. I IBEFTFL'="LF",$P(Z0,U,8)="LF" Q ; If not lab/facility ID, it must be unigue for the others (secondary and additional)
112 .. I IBEFTFL="A",$P(Z0,U,8)="E" Q
113 .. I $P(Z0,U,8)="E",IBEFTFL'="A" S IB("*N/A*",$P(Z0,U,4),+$P(Z0,U,5),$S($P(Z0,U,3)]"":$P(Z0,U,3),1:"*N/A*"))=Z
114 .. S IB($P(Z0,U,6),$P(Z0,U,4),+$P(Z0,U,5),$S($P(Z0,U,3)]"":$P(Z0,U,3),1:"*N/A*"))=Z
115 . ;
116 . ; count them
117 . I IBFUNC="A",$P(Z0,U,8)=IBEFTFL,IBDIV=$P(Z0,U,5)!(IBDIV=0&($P(Z0,U,5)="")) D
118 .. I ".1.2."[("."_$P(Z0,U,4)_".") S IBCNTADD($P(Z0,U,4))=$G(IBCNTADD($P(Z0,U,4)))+1 Q
119 .. N I
120 .. F I=1,2 S IBCNTADD(I)=$G(IBCNTADD(I))+1
121 ; Check for duplications
122 S IBOK=1
123 ; Don't check if nothing is being changed. The ID itself can be changed after return to calling program.
124 I IBFUNC="E" S Z0=$G(^IBA(355.92,IBDA,0)) I $P(Z0,U,3)=IBCAREUN!($P(Z0,U,3)=""&(IBCAREUN="*N/A*")),IBFORM=$P(Z0,U,4),IBDIV=$P(Z0,U,5),IBITYP=$P(Z0,U,6) G FLDSQ
125 I $G(IB($S(IBEFTFL="E":"*N/A*",1:IBITYP),IBFORM,IBDIV,IBCAREUN)) D
126 . N Z,ZPC8 S Z=$G(IB($S(IBEFTFL="E":"*N/A*",1:IBITYP),IBFORM,IBDIV,IBCAREUN))
127 . S ZPC8=""
128 . I +Z S ZPC8=$P($G(^IBA(355.92,Z,0)),U,8)
129 . S IBOK="0^DUPLICATE"_U_ZPC8
130 I IBOK,IBFORM=0,$S($D(IB($S(IBEFTFL="E":"*N/A*",1:IBITYP),1,IBDIV,IBCAREUN))!$D(IB($S(IBEFTFL="E":"*N/A*",1:IBITYP),2,IBDIV,IBCAREUN)):1,1:0) S IBOK="0^FORM^SPECIFIC"
131 I IBOK,IBFORM'=0,IBFORM'=3,$S($D(IB($S(IBEFTFL="E":"*N/A*",1:IBITYP),0,IBDIV,IBCAREUN)):1,1:0) S IBOK="0^FORM^BOTH"
132 ;
133 S IBLIMIT=$S(IBEFTFL="A":6,IBEFTFL="LF":5,1:"")
134 I IBOK,IBFUNC="A",IBEFTFL'="E" D
135 . I ".1.2."[("."_IBFORM_".") D Q
136 .. I $G(IBCNTADD(IBFORM))>(IBLIMIT-1) S IBOK="0^LIMIT"
137 . N I
138 . I IBFORM=0 F I=1,2 I $G(IBCNTADD(I))>IBLIMIT S IBOK="0^LIMIT" Q
139 ;
140 I 'IBOK D
141 . I $P(IBOK,U,2)="DUPLICATE" D Q
142 .. S DIR("A",1)="This ID combination is already defined",DIR("A",2)=""
143 .. ; under "_$S($P(IBOK,U,3)="A":" Additonal IDs",$P(IBOK,U,3)="E":"Billing Provider Secondary ID",1:"VA Lab/Facility IDs")_$S(IBFUNC="A":" - try editing it instead",1:""),DIR("A",2)=" "
144 . ;
145 . I $P(IBOK,U,2)="BOTH" D Q
146 .. S DIR("A",1)="An ID combination for both form types already exists. Delete this one",DIR("A",2)="before defining and form specific IDs"_$S(IBDIV:" for this division"),DIR("A",4)=" "
147 . ;
148 . I $P(IBOK,U,2)="FORM" D Q
149 .. I $P(IBOK,U,3)="BOTH" S DIR("A",1)="This ID already exists for both form types - Delete it to enter this ID for",DIR("A",2)=" a specific form type",DIR("A",3)=" " Q
150 .. S DIR("A",1)="This ID already exists for a specific form type - Delete specific form type",DIR("A",2)=" ID(s) before entering one for both form types",DIR("A",3)=" "
151 . ;
152 . I $P(IBOK,U,2)="LIMIT" D Q
153 .. S DIR("A",1)="Limit is "_IBLIMIT_" IDs for each form type",DIR("A",2)=" "
154 .. I IBEFTFL="A" D
155 ... S DIR("A",1)="A maximum of 6 Additional Billing Provider Sec IDs can be entered for each Form"
156 ... S DIR("A",2)="Type. Before you can add another ID, you must delete an existing ID."
157 ... S DIR("A",3)=" "
158 ;
159 I 'IBOK S DIR(0)="EA",DIR("A")="PRESS RETURN TO CONTINUE: " W ! D ^DIR K DIR
160 ;
161FLDSQ Q +IBOK
Note: See TracBrowser for help on using the repository browser.