source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBPU2.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.2 KB
Line 
1IBPU2 ;ALB/BGA - IB PURGE FILE CLEAN UP ; 17-FEB-94
2 ;;Version 2.0 ; INTEGRATED BILLING ;**48**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine requires IBN from routine IBPP
6 ; and deletes entries in FILE #399
7 ;
8 ; The following procedures remove references which
9 ; point to the IBN about to be deleted. This routine is
10 ; invoked by IBPU.
11 ;
12 Q:'$G(IBN)
13 D CTARNB ; adds a Reason Not Billable (.19) to 356: PURGED
14 D CLBCOM ; deletes Rec from file 362.1
15 D CLPSTE ; deletes Rec from file 362.3,362.4,362.5
16 D CLCTRK ; deletes ptr from file 356 field .11
17 D CLCTBI ; deletes Rec from file 356.399
18 D IBPBIL ; sets the ptr in fld .17 to its self
19 D IBCYTO ; checks the ptr in fld .15
20 Q
21 ;
22CTARNB ; add a RNB (356,.19) for every episode found on the bill, if none exists (non-cancelled bills)
23 N ARRAY,IBA,IBX,DIE,DIC,DA,DR,IBRNB K ARRAY S IBRNB=$O(^IBE(356.8,"B","BILL PURGED",0)) Q:'IBRNB
24 D IFNTRN^IBCU83(IBN,.ARRAY) S IBA=0 F S IBA=$O(ARRAY(IBA)) Q:'IBA I +ARRAY(IBA)'=5 S ^TMP($J,"IBPPTRN",IBA)=""
25 I $P($G(^DGCR(399,+IBN,0)),U,13)'=7 S IBA=0 F S IBA=$O(ARRAY(IBA)) Q:'IBA S IBX=$G(^IBT(356,+IBA,0)) D
26 . I +IBX,'$P(IBX,U,19),+ARRAY(IBA)'=5 S DIE="^IBT(356,",DA=IBA,DR=".19////"_IBRNB D ^DIE
27 Q
28CLBCOM ; uses "D" xref to find all recs to be deleted
29 N IBA,DIK,DA
30 S IBA="" F S IBA=$O(^IBA(362.1,"D",IBN,IBA)) Q:'IBA S DIK="^IBA(362.1,",DA=IBA D ^DIK
31 Q
32CLPSTE ; uses "AIFN_IBN" to find all recs pointing to the rec to be deleted
33 N IBA,IBB,REF,DIK,DA
34 S REF="AIFN"_IBN
35 F IBI=362.5,362.3,362.4 S (IBA,IBB)="" F S IBA=$O(^IBA(IBI,REF,IBA)) Q:'IBA F S IBB=$O(^IBA(IBI,REF,IBA,IBB)) Q:'IBB S DIK="^IBA("_IBI_",",DA=IBB D ^DIK
36 Q
37CLCTBI ; uses "C" xref to find all recs pointing to 399 then deletes
38 N IBA,IBB,DIK,DA
39 S IBA="" F S IBA=$O(^IBT(356.399,"C",IBN,IBA)) Q:'IBA D
40 . S IBB=$P($G(^IBT(356.399,IBA,0)),U,1) I +IBB S ^TMP($J,"IBPPTRN",+IBB)=""
41 . S DIK="^IBT(356.399,",DA=IBA D ^DIK
42 Q
43CLCTRK ; uses "E" xref to find all recs ptr to 399 then sets them to null
44 N IBA,DIE,DA,DR
45 S IBA="" F S IBA=$O(^IBT(356,"E",IBN,IBA)) Q:'IBA S ^TMP($J,"IBPPTRN",+IBA)="",DIE="^IBT(356,",DA=IBA,DR=".11///@" D ^DIE
46 Q
47IBPBIL ; uses "AC" xref to find all recs ptr to 399 then sets to the bill #
48 N IBA,DIE,DA,DR
49 S IBA="" F S IBA=$O(^DGCR(399,"AC",IBN,IBA)) Q:'IBA I IBN'=IBA S DIE="^DGCR(399,",DA=IBA,DR=".17///"_IBA D ^DIE
50 Q
51IBCYTO ; uses "C" xref to find all recs ptr to 399 then sets the recs to null
52 N IBA,IBB,DFN,DIE,DA,DR
53 S (IBA,IBB)="",DFN=+$P($G(^DGCR(399,IBN,0)),U,2)
54 F S IBA=$O(^DGCR(399,"C",DFN,IBA)) Q:'IBA I +$P($G(^DGCR(399,IBA,0)),U,15)=IBN S DIE="^DGCR(399,",DA=IBA,DR=".15///@"
55 Q
56 ;
57 ;
58PTCH48 ; CODE FOR PATCH IB*2*48 TO ADD NEW REASON NOT BILLABLE
59 N IBI,DINUM,DIC,Y
60 I $D(^IBE(356.8,"B","BILL PURGED")) W !!,"*** REASON NOT BILLABLE of 'BILL PURGED' already exists in FILE #356.8, new entry NOT added.",!! Q
61 W !!,">>> Adding new REASON NOT BILLABLE of 'BILL PURGED' to FILE #356.8"
62 F IBI=19:1:999 I '$D(^IBE(356.8,IBI,0)) D Q
63 . S DINUM=IBI I '$D(^IBE(356.8,DINUM,0)) K DD,DO S DIC="^IBE(356.8,",DIC(0)="L",X="BILL PURGED" D FILE^DICN
64 I $G(Y)<1 W !!,"**** Unable to add new entry to FILE #356.8, contact Field Support ****",!!
65 I $G(Y)>0 W !,"Done.",!!
66 K DIC,DINUM,Y,DD,DO
67 Q
Note: See TracBrowser for help on using the repository browser.