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

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1IB20P339 ;ALB/ARH - IB*2.0*339 POST INIT: IB SHAD/SWA SUPPORT ; 02-JAN-2006
2 ;;2.0;INTEGRATED BILLING;**339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6POST ;
7 N IBA S IBA(1)="",IBA(2)=" IB Support for SHAD/SWA Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
8 ;
9 D ADDRNB ; Add PROJECT 112/SHAD Reason Not Billable (#356.8)
10 D ADDCRR ; Add PROJECT 112/SHAD Charge Removal Reason (#350.3)
11 ;
12 D UPDRNB ; Replace ENV. CONTAM. with SOUTHWEST ASIA Reason Not Billable (#356.8)
13 D UPDCRR ; Replace ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED Charge Removal Reason (#350.3)
14 ;
15 S IBA(1)="",IBA(2)=" IB Support for SHAD/SWA Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
16 Q
17 ;
18 ;
19ADDRNB ; Add Reason Not Billable of PROJECT 112/SHAD (#356.8)
20 N IBA,IBJ,IBNX,IBRNB,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
21 ;
22 S IBRNB="PROJECT 112/SHAD"
23 ;
24 I $O(^IBE(356.8,"B",IBRNB,0)) S IBA(1)=" >>> "_IBRNB_" Reason Not Billable (#356.8) exists, not re-added." G ADDRNBQ
25 ;
26 F IBJ=32:1 S IBNX=$G(^IBE(356.8,IBJ,0)) I IBNX="" S DINUM=IBJ Q ; find next available ien, before 999
27 ;
28 K DD,DO S DLAYGO=356.8,DIC="^IBE(356.8,",DIC(0)="L",X=IBRNB D FILE^DICN K DIC
29 I Y<1 S IBA(1)=" >>> Unable to add "_IBRNB_" Reason Not Billable (#356.8), contact Support." G ADDRNBQ
30 ;
31 S IBA(1)=" >>> "_IBRNB_" Reason Not Billable (#356.8) Added."
32 ;
33ADDRNBQ D MES^XPDUTL(.IBA)
34 Q
35 ;
36 ;
37ADDCRR ; Add Charge Removal Reason of PROJECT 112/SHAD (#350.3)
38 N IBA,IBJ,IBNX,IBCRR,IBABBR,IBLMT,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
39 ;
40 S IBCRR="PROJECT 112/SHAD",IBABBR="SHAD",IBLMT="GENERIC"
41 ;
42 I $O(^IBE(350.3,"B",IBCRR,0)) S IBA(1)=" >>> "_IBCRR_" Charge Removal Reason (#350.3) exists, not re-added." G ADDCRRQ
43 ;
44 F IBJ=46:1 S IBNX=$G(^IBE(350.3,IBJ,0)) I IBNX="" S DINUM=IBJ Q ; find next available ien
45 ;
46 K DD,DO S DLAYGO=350.3,DIC="^IBE(350.3,",DIC(0)="L",X=IBCRR D FILE^DICN S IBFN=+Y
47 I Y<1 S IBA(1)=" >>> Unable to add "_IBCRR_" Charge Removal Reason (#350.3), contact Support." G ADDCRRQ
48 ;
49 S DIE="^IBE(350.3,",DA=+IBFN,DR=".02///"_IBABBR_";.03///"_IBLMT D ^DIE
50 ;
51 S IBA(1)=" >>> "_IBCRR_" Charge Removal Reason (#350.3) Added."
52 ;
53ADDCRRQ D MES^XPDUTL(.IBA)
54 Q
55 ;
56 ;
57UPDRNB ; Update Reason Not Billable of ENV. CONTAM. with SOUTHWEST ASIA (#356.8)
58 N IBA,IBFN,IBRNBO,IBRNBN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
59 ;
60 S IBRNBO="ENV. CONTAM."
61 S IBRNBN="SOUTHWEST ASIA"
62 ;
63 I $O(^IBE(356.8,"B",IBRNBN,0)) S IBA(1)=" >>> "_IBRNBN_" Reason Not Billable (#356.8) exists, not re-added." G UPDRNBQ
64 ;
65 S IBFN=$O(^IBE(356.8,"B",IBRNBO,0)) I 'IBFN S IBA(1)=" >>> ERROR: "_IBRNBO_" Reason Not Billable (#356.8) not found, could not be replaced, contact support." G UPDRNBQ
66 ;
67 S DIE="^IBE(356.8,",DA=+IBFN,DR=".01///"_IBRNBN D ^DIE
68 ;
69 S IBA(1)=" >>> "_IBRNBO_" Reason Not Billable (#356.8) Replaced with "_IBRNBN
70 ;
71UPDRNBQ D MES^XPDUTL(.IBA)
72 Q
73 ;
74 ;
75UPDCRR ; Update Charge Removal Reason of ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED (#350.3)
76 N IBA,IBFN,IBCRRO,IBCRRN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
77 ;
78 S IBCRRO="ENV CONTAMINANT RELATED"
79 S IBCRRN="SOUTHWEST ASIA RELATED"
80 ;
81 I $O(^IBE(350.3,"B",IBCRRN,0)) S IBA(1)=" >>> "_IBCRRN_" Charge Removal Reason (#350.3) exists, not re-added." G UPDCRRQ
82 ;
83 S IBFN=$O(^IBE(350.3,"B",IBCRRO,0)) I 'IBFN S IBA(1)=" >>> ERROR: "_IBCRRO_" Charge Removal Reason (#350.3) not found, could not be replaced, contact support." G UPDCRRQ
84 ;
85 S DIE="^IBE(350.3,",DA=+IBFN,DR=".01///"_IBCRRN_";.02///SWA" D ^DIE
86 ;
87 S IBA(1)=" >>> "_IBCRRO_" Charge Removal Reason (#350.3) Replaced with "_IBCRRN
88 ;
89UPDCRRQ D MES^XPDUTL(.IBA)
90 Q
91 ;
92 ;
93MSG(X) ;
94 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
95 S IBA(IBX)=$G(X)
96 Q
Note: See TracBrowser for help on using the repository browser.