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

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1IBYPSM ;ALB/ARH - IB*2.0*390 POST INIT: REASONABLE CHARGES V3.1 ; 25-JAN-2008
2 ;;2.0;INTEGRATED BILLING;**390**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;
6 Q
7 ;
8POST ;
9 N IBA
10 S IBA(1)="",IBA(2)=" Reasonable Charges v3.1 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
11 ;
12 D CHGINA("") ; inactivate all RC charges in #363.2
13 ;
14 S IBA(1)="",IBA(2)=" Reasonable Charges v3.1 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
15 ;
16 Q
17 ;
18 ;
19 ;
20CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
21 ; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
22 ; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
23 ; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
24 ;
25 N IBA,IBI,IBX,IBSTART,IBENDATE,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
26 N DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT S IBCNT=0
27 ;
28 S IBA(1)=" >> Inactivating Existing Reasonable Charges, Please Wait..." D MES^XPDUTL(.IBA) K IBA
29 ;
30 S IBSTART="" I $G(VERS)'="" S IBSTART=$$VERSDT^IBCRHBRV(VERS)
31 S IBENDATE=$$VERSEND^IBCRHBRV
32 ;
33 S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
34 . S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
35 . S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I $E(IBBR0,1,3)'="RC " Q
36 . ;
37 . S IBXRF="AIVDTS"_IBCS
38 . S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
39 .. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" Q:-IBNEF<IBSTART D
40 ... ;
41 ... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
42 .... S IBCI0=$G(^IBA(363.2,IBCI,0)) Q:IBCI0=""
43 .... S IBCIEF=$P(IBCI0,U,3),IBCIIA=$P(IBCI0,U,4),IBNEWIA=""
44 .... ;
45 .... F IBI=2:1 S IBX=+$P(IBENDATE,";",IBI) S IBNEWIA=IBX Q:'IBX Q:IBCIEF'>IBX
46 .... ;
47 .... I 'IBNEWIA Q
48 .... I +IBCIIA,IBCIIA'>IBNEWIA Q
49 .... ;
50 .... S DR=".04////"_+IBNEWIA,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIE,DIC,DA,DR,X,Y S IBCNT=IBCNT+1
51 ;
52 S IBA(1)=" Done. "_IBCNT_" existing charges inactivated " D MES^XPDUTL(.IBA) K IBA
53 Q
54 ;
55 ;
56 ;
57MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
58 N IBX,IBY S IBY=""
59 I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
60 Q IBY
61 ;
62MSG(X) ;
63 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
64 S IBA(IBX)=$G(X)
65 Q
Note: See TracBrowser for help on using the repository browser.