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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1IBECPTT ;ALB/ARH - TRANSFERS CPT RATE UPDATES TO 350.4 ; 10/22/91
2 ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; THIS FUNCTION IS OBSOLETE AND THE ROUTINE SHOULD BE DELETED WHEN 350.4 AND 350.5 ARE DELETED (133)
6 Q
7 ;
8 ;transfer all entrys in 350.41 to 350.4 that are valid
9 W !!!,?18,"Transfer HCFA updates to the Permanent BASC File",!!!
10 W !!,"This option transfers the HCFA updates from the temporary BASC file to the"
11 W !,"permanent BASC file."
12 S DIR(0)="Y",DIR("A")="Proceed with transfer" D ^DIR K DIR G:$D(DIRUT)!('Y) END
13 W !!,"Beginning transfer, this could take some time. Please wait...",!
14START W !,"Transferring HCFA updates to permanent BASC file."
15 S IBX=0,(IBSD,IBNT,IBE,IBES,IBERR,IBCNT)=0
16 F IBI=1:1 S IBX=$O(^IBE(350.41,IBX)) Q:IBX?1A.A I '$P($G(^IBE(350.41,IBX,0)),"^",7) D SEARCH S IBCNT=IBCNT+1 I '(IBCNT#25) W "."
17 W !!,"Transfer complete: ",IBSD," Entries created in 409.71"
18 W !,?19,IBE," Entries created in 350.4",!,?19,IBES," Entries in 350.4 ""stuffed"""
19 W !!,?19,IBNT," Codes already have entries for given effective date"
20 W !,?19,IBERR," Codes unable to transfer"
21END ;
22 K IBX,IBSD,IBNT,IBE,IBES,IBCNT,IBERR,IBI,IBLN,IBLN1,IBUA,IBEDT,IBOLD,IBNEW,IBERRF,IBCD,DA,DR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
23 Q
24 ;
25SEARCH ;update/create new billing code entries if conditions meet
26 ; does not transfer to 350.4 if: - code inactive (in 81)
27 ; - date effective already defined for code
28 ; - deactivating a code not in billing
29 ; - deactivating a code already inactive
30 ; - stated old group not match current group
31 ; - entry does not cause changes in rate or status
32 S IBLN=^IBE(350.41,IBX,0),IBEDT=$E($P(IBLN,"^",2),1,7),IBNEW=$P(IBLN,"^",4)
33 S IBOLD=$P(IBLN,"^",3),IBCD=+IBLN,IBUA="@"
34 I '$P($$CPT^ICPTCOD(+IBCD),U,7) S IBERRF="CODE NOT ACTIVE IN CPT FILE (81)" G ERROR
35 I $D(^IBE(350.4,"AIVDT",IBCD,-IBEDT)) S IBNT=IBNT+1,IBERRF="DATE EFFECTIVE ALREADY DEFINED FOR CODE" G ERROR
36 S IBLN1=$G(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",IBCD,-(IBEDT+1))),0)),0))
37 S IBUA=$S('IBLN1:1,'$P(IBLN1,"^",4):2,'IBNEW:4,IBNEW'=IBOLD&(IBNEW'=$P(IBLN1,"^",3)):3,1:"@")
38 I IBOLD,$P(IBLN1,"^",3),IBOLD'=$P(IBLN1,"^",3) S IBERRF="STATED OLD GROUP DOES NOT MATCH CURRENT GROUP" G ERROR
39 I 'IBNEW,'IBLN1 S IBERRF="DEACTIVATING A CODE NOT IN BILLING" G ERROR
40 I 'IBNEW,'$P(IBLN1,"^",4) S IBERRF="DEACTIVATING A CODE ALREADY INACTIVE" G ERROR
41 I IBUA="@" S IBERRF="NO VALID UPDATE ACTION FOUND, NO CHANGE IN RATE/STATUS" G ERROR
42 S IBERRF="ERROR WHILE TRYING TO STORE THE DATA"
43CREATE ;create entries in 350.4 and 409.71
44 S DLAYGO=409.71,X="`"_IBCD,DIC="^SD(409.71,",DIC(0)="XL" D ^DIC K DIC G:Y<0 ERROR I $P(Y,"^",3) S IBSD=IBSD+1
45 K DD,DO S DLAYGO=350.4,X=IBEDT,DIC="^IBE(350.4,",DIC(0)="L" D FILE^DICN K DIC,DLAYGO G:Y<0 ERROR S IBE=IBE+1
46STUFF ;stuff data into newly created entry in 350.4
47 S DR=".02////"_IBCD_";.03////"_IBNEW_";.04////"_$S(IBNEW:1,1:0)
48 S DIE="^IBE(350.4,",DA=+Y D ^DIE K DIE,DIC,DR,DA,Y S IBES=IBES+1
49 S DR=".06///"_IBUA_";.07////1;.08///@",DIE="^IBE(350.41,",DA=IBX D ^DIE K DIE,DIC,DR,DA,Y,X
50 Q
51 ;
52ERROR ;entry can not be transfered for some reason, flag piece 7 in 350.41
53 S IBERR=IBERR+1
54 S DR=".06///"_IBUA_";.07////0;.08////"_IBERRF,DIE="^IBE(350.41,",DA=IBX D ^DIE K DIE,DIC,DR,DA,Y,X
55 Q
Note: See TracBrowser for help on using the repository browser.