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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1IBCRED ;ALB/ARH - RATES: CM DELETE CHARGE ITEMS OPTION ; 22-MAY-1996
2 ;;2.0;INTEGRATED BILLING;**52,106,148,307**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6ENTER ; OPTION ENTRY POINT: delete charge items for a specific charge set, may be inactive by a date or all
7 ;
8 W @IOF W !,?12,"**** DELETE INACTIVE CHARGE ITEMS FROM A CHARGE SET ****"
9 W !!,?5,"For a given Charge Set, this option allows deletion of all chargeable items",!,?5,"that have been inactivated or replaced before a certain date.",!
10 W !,?5,"Since all charges for a billing rate and date range may be deleted with",!,?5,"this option, caution is advised.",!
11 ;
12 N IBCS,IBDT,IBCSDEL,IBQUIT,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBDT=0,IBCSDEL=0 K ^TMP($J,"IBCRED")
13 ;
14 W !!,"The Charge Set to delete Charge items from:" S IBCS=$$GETCS^IBCRU1 I +IBCS<1 Q
15 ;
16 W ! S DIR(0)="YO",DIR("A")="Delete ALL charges for this Charge Set" D ^DIR K DIR Q:$D(DIRUT) I Y=1 S IBDT="ALL"
17 I IBDT="ALL" I IBCS>999!($P(IBCS,U,2)["RC-")!($P(IBCS,U,2)["CMAC") D
18 . S DIR("?")="Enter Yes to delete the Charge Set and it's links with Rate Schedules and Special Groups. The sets Region will also be deleted if not associated with another set."
19 . S DIR(0)="YO",DIR("A")="Also delete the Charge Set "_$P(IBCS,U,2) D ^DIR K DIR Q:$D(DIRUT) I Y=1 S IBCSDEL=1
20 ;
21 I IBDT'="ALL" W !!,"All charges inactive before this date will be deleted:" S IBDT=$$GETDT^IBCRU1(,"Select INACTIVE DATE") I IBDT'?7N W !,"No deletions",! Q
22 ;
23 S DIR(0)="SO^1:Print List of Charges that will be Deleted;2:Delete Charges" D ^DIR K DIR I +Y<1!$D(DIRUT) Q
24 I +Y=1 D DEV Q:+$G(IBQUIT) G RPT
25 ;
26 W !!!,"All charges",$S('IBDT:"",1:" inactive before "_$$DATE(IBDT))," for ",$P(IBCS,U,2)," will be deleted.",!
27 ;
28 S DIR(0)="YO",DIR("A")="Is this correct, do you want to continue" D ^DIR K DIR I Y'=1 W !,"No deletions",!
29 ;
30 I Y=1 D
31 . W !,"Beginning Deletions" W !,$$DELETE(IBCS,IBDT)," charges deleted."
32 . I +IBCSDEL W !!,$P(IBCS,U,2)," ",$P($$CSDELETE(+IBCS),U,2)
33 Q
34 ;
35DELETE(CS,INDT,SAVE) ; delete all charge items in a set inactive before a certain date
36 ; Input: CS - set to delete charges from,
37 ; INDT - charges not active on this date will be deleted, if ALL- all charges will be deleted from set
38 ; SAVE - if true, charge items that would be deleted are entered into TMP array for printing instead
39 ; Output: returns the count of the charge items deleted
40 ;
41 N IBXRF,IBCNT,IBSUB2,IBEFDT,IBITM,IBCIFN,IBINDTCI
42 S IBXRF="AIVDTS"_+$G(CS),IBCNT=0,INDT=$G(INDT),IBSUB2="" I INDT="ALL" S INDT=9999999
43 I +$G(SAVE) S IBSUB2=$$TMPHDR($G(CS),INDT)
44 ;
45 S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
46 . S IBEFDT=0 F S IBEFDT=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT),-1) Q:'IBEFDT!(IBEFDT'>-INDT) D
47 .. S IBCIFN=0 F S IBCIFN=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT,IBCIFN)) Q:'IBCIFN D
48 ... ;
49 ... S IBINDTCI=$$INACTCI^IBCRU4(IBCIFN)
50 ... I INDT=9999999 D DELCI(IBCIFN,IBSUB2) S IBCNT=IBCNT+1 Q
51 ... I +IBINDTCI,IBINDTCI<INDT D DELCI(IBCIFN,IBSUB2) S IBCNT=IBCNT+1
52 ;
53 Q IBCNT
54 ;
55DELCI(CI,SUB2) ; either save in TMP arry to print or delete
56 I $G(SUB2)'="" D TMPLN^IBCROI1(CI,"IBCRED",SUB2,1) Q
57 I $G(^IBA(363.2,+$G(CI),0)) S DA=CI,DIK="^IBA(363.2," D ^DIK K DA,DIK
58 Q
59 ;
60DATE(X) ;
61 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
62 ;
63TMPHDR(CS,INDT) ; set up array header for printed report
64 N IBHDR,IBHDR2,IBDT,SUB2 S SUB2=$P($G(^IBE(363.1,+CS,0)),U,1)
65 S IBHDR="Charges (to be deleted) in "_SUB2_" set"
66 S IBHDR2=" inactive before",IBDT=INDT I IBDT=9999999 S IBHDR2=" (ALL CHARGES IN SET)",IBDT=""
67 D TMPHDR^IBCROI1("IBCRED",SUB2,+CS,IBHDR_IBHDR2,"2^1",IBDT)
68 Q SUB2
69 ;
70 ;
71DEV ; get device for printed report
72 S IBQUIT=0 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP S IBQUIT=1 Q
73 I $D(IO("Q")) S ZTRTN="RPT^IBCRED",ZTDESC="Delete Charges Report",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") S IBQUIT=1
74 Q
75 ;
76RPT ; print report - entry point for tasked jobs
77 N IBSCRPT,IBCNT S IBSCRPT="IBCRED" K ^TMP($J,"IBCRED")
78 S IBCNT=$$DELETE(IBCS,IBDT,1)
79 I $D(^TMP($J,"IBCRED")) S $P(^TMP($J,"IBCRED"),U,4)=IBCNT_" Charges to be deleted"
80 G RPT^IBCROI
81 Q
82 ;
83CSDELETE(IBCS) ; delete a Charge Set, including all pointers to it, also delete region if not assigned to another set
84 N IBFN,IB11,IBRG,IBER,DA,DIC,DIE,DIK,X,Y S IBER="0^Charge Set not deleted"
85 I '$D(^IBE(363.1,+$G(IBCS),0)) G CSDELQ
86 I $O(^IBA(363.2,"AIVDTS"_+IBCS,"")) S IBER="0^Charge Set has associated Charge Items, can not delete." G CSDELQ
87 I $P($G(^IBE(350.9,1,9)),U,12)=+IBCS S IBER="0^Charge Set pointed to by AWP CHARGE SET Site Parameter, can not delete." G CSDELQ
88 ;
89 ; remove from Rate Schedule
90 S IBFN=0 F S IBFN=$O(^IBE(363,"C",+IBCS,IBFN)) Q:'IBFN D
91 . S IB11="" F S IB11=$O(^IBE(363,"C",+IBCS,IBFN,IB11)) Q:'IB11 D
92 .. I +$G(^IBE(363,+IBFN,11,+IB11,0))=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363,"_DA(1)_",11," D ^DIK K DIK
93 ;
94 ; remove from Special Groups
95 S IBFN=0 F S IBFN=$O(^IBE(363.32,IBFN)) Q:'IBFN D
96 . S IB11=0 F S IB11=$O(^IBE(363.32,IBFN,11,IB11)) Q:'IB11 D
97 .. I +$P($G(^IBE(363.32,IBFN,11,IB11,0)),U,2)=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363.32,"_DA(1)_",11," D ^DIK K DIK
98 ;
99 ; delete region if not assigned to another Charge Set
100 S IBRG=$P($G(^IBE(363.1,+IBCS,0)),U,7)
101 I +IBRG S IBFN=0 F S IBFN=$O(^IBE(363.1,IBFN)) Q:'IBFN D
102 . I +IBFN'=+IBCS,$P($G(^IBE(363.1,+IBFN,0)),U,7)=IBRG S IBRG=0
103 I +IBRG S DA=+IBRG,DIK="^IBE(363.31," D ^DIK K DA,DIK
104 ;
105 ; delete Charge Set
106 S DA=+IBCS,DIK="^IBE(363.1," D ^DIK K DA,DIK
107 S IBER="1^Charge Set Deleted"_$S(+IBRG:", Region Deleted",1:"")_"."
108CSDELQ Q IBER
109 ;
110CSEMPTY(BR) ; delete Charge Sets that have no associated Charges (except VA Cost)
111 ; Input: BR may be passed to limit the check for empty Charge Sets to specific Billing Rates
112 ; only CS's of the passed Billing Rate will be checked and deleted if it has no charges
113 ; - pointer to the Billing Rate (363.3) to check
114 ; - first two characters of the Billing Rate Name (363.3,.01) to check
115 ; - if no BR passed then all Charge Sets/Billing Rates are checked
116 ; Returns: count of Charge Sets deleted
117 N IBCS,IBCS0,IBBR,IBBR0,IBX,IBCNT,X,Y S IBCNT=0
118 S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
119 . S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR=+$P(IBCS0,U,2),IBBR0=$G(^IBE(363.3,+IBBR,0))
120 . I '$P(IBBR0,U,4)!($P(IBBR0,U,5)=2) Q ; VA Cost
121 . I +$G(BR),IBBR'=BR Q ; selected Billing Rates
122 . I '$G(BR),$G(BR)'="",$E(IBBR0,1,2)'=BR Q ; selected Billing Rate names/types
123 . I '$O(^IBA(363.2,"AIVDTS"_+IBCS,"")) S IBX=$$CSDELETE(IBCS) I +IBX S IBCNT=IBCNT+1
124 Q IBCNT
Note: See TracBrowser for help on using the repository browser.