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