Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBECPTT

IBECPTT.m

Go to the documentation of this file.
  1. IBECPTT ;ALB/ARH - TRANSFERS CPT RATE UPDATES TO 350.4 ; 10/22/91
  1. ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;transfer all entrys in 350.41 to 350.4 that are valid
  1. W !!!,?18,"Transfer HCFA updates to the Permanent BASC File",!!!
  1. W !!,"This option transfers the HCFA updates from the temporary BASC file to the"
  1. W !,"permanent BASC file."
  1. S DIR(0)="Y",DIR("A")="Proceed with transfer" D ^DIR K DIR G:$D(DIRUT)!('Y) END
  1. W !!,"Beginning transfer, this could take some time. Please wait...",!
  1. START W !,"Transferring HCFA updates to permanent BASC file."
  1. S IBX=0,(IBSD,IBNT,IBE,IBES,IBERR,IBCNT)=0
  1. 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 "."
  1. W !!,"Transfer complete: ",IBSD," Entries created in 409.71"
  1. W !,?19,IBE," Entries created in 350.4",!,?19,IBES," Entries in 350.4 ""stuffed"""
  1. W !!,?19,IBNT," Codes already have entries for given effective date"
  1. W !,?19,IBERR," Codes unable to transfer"
  1. END ;
  1. 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
  1. Q
  1. ;
  1. ; does not transfer to 350.4 if: - code inactive (in 81)
  1. ; - date effective already defined for code
  1. ; - deactivating a code not in billing
  1. ; - deactivating a code already inactive
  1. ; - stated old group not match current group
  1. ; - entry does not cause changes in rate or status
  1. S IBLN=^IBE(350.41,IBX,0),IBEDT=$E($P(IBLN,"^",2),1,7),IBNEW=$P(IBLN,"^",4)
  1. S IBOLD=$P(IBLN,"^",3),IBCD=+IBLN,IBUA="@"
  1. I $P(^ICPT(IBCD,0),"^",4) S IBERRF="CODE NOT ACTIVE IN CPT FILE (81)" G ERROR
  1. I $D(^IBE(350.4,"AIVDT",IBCD,-IBEDT)) S IBNT=IBNT+1,IBERRF="DATE EFFECTIVE ALREADY DEFINED FOR CODE" G ERROR
  1. S IBLN1=$G(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",IBCD,-(IBEDT+1))),0)),0))
  1. S IBUA=$S('IBLN1:1,'$P(IBLN1,"^",4):2,'IBNEW:4,IBNEW'=IBOLD&(IBNEW'=$P(IBLN1,"^",3)):3,1:"@")
  1. I IBOLD,$P(IBLN1,"^",3),IBOLD'=$P(IBLN1,"^",3) S IBERRF="STATED OLD GROUP DOES NOT MATCH CURRENT GROUP" G ERROR
  1. I 'IBNEW,'IBLN1 S IBERRF="DEACTIVATING A CODE NOT IN BILLING" G ERROR
  1. I 'IBNEW,'$P(IBLN1,"^",4) S IBERRF="DEACTIVATING A CODE ALREADY INACTIVE" G ERROR
  1. I IBUA="@" S IBERRF="NO VALID UPDATE ACTION FOUND, NO CHANGE IN RATE/STATUS" G ERROR
  1. S IBERRF="ERROR WHILE TRYING TO STORE THE DATA"
  1. CREATE ;create entries in 350.4 and 409.71
  1. 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
  1. 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
  1. STUFF ;stuff data into newly created entry in 350.4
  1. S DR=".02////"_IBCD_";.03////"_IBNEW_";.04////"_$S(IBNEW:1,1:0)
  1. S DIE="^IBE(350.4,",DA=+Y D ^DIE K DIE,DIC,DR,DA,Y S IBES=IBES+1
  1. S DR=".06///"_IBUA_";.07////1;.08///@",DIE="^IBE(350.41,",DA=IBX D ^DIE K DIE,DIC,DR,DA,Y,X
  1. Q
  1. ;
  1. ERROR ;entry can not be transfered for some reason, flag piece 7 in 350.41
  1. S IBERR=IBERR+1
  1. S DR=".06///"_IBUA_";.07////0;.08////"_IBERRF,DIE="^IBE(350.41,",DA=IBX D ^DIE K DIE,DIC,DR,DA,Y,X
  1. Q