| [613] | 1 | IBECPTT ;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...",!
|
|---|
| 14 | START 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"
|
|---|
| 21 | END ;
|
|---|
| 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 | ;
|
|---|
| 25 | SEARCH ;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"
|
|---|
| 43 | CREATE ;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
|
|---|
| 46 | STUFF ;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 | ;
|
|---|
| 52 | ERROR ;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
|
|---|
