IBECPTT ;ALB/ARH - TRANSFERS CPT RATE UPDATES TO 350.4 ; 10/22/91
;;2.0;INTEGRATED BILLING;**133**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; THIS FUNCTION IS OBSOLETE AND THE ROUTINE SHOULD BE DELETED WHEN 350.4 AND 350.5 ARE DELETED (133)
Q
;
;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($$CPT^ICPTCOD(+IBCD),U,7) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECPTT 3506 printed Apr 09, 2024@21:05:52 Page 2
IBECPTT ;ALB/ARH - TRANSFERS CPT RATE UPDATES TO 350.4 ; 10/22/91
+1 ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; THIS FUNCTION IS OBSOLETE AND THE ROUTINE SHOULD BE DELETED WHEN 350.4 AND 350.5 ARE DELETED (133)
+5 QUIT
+6 ;
+7 ;transfer all entrys in 350.41 to 350.4 that are valid
+8 WRITE !!!,?18,"Transfer HCFA updates to the Permanent BASC File",!!!
+9 WRITE !!,"This option transfers the HCFA updates from the temporary BASC file to the"
+10 WRITE !,"permanent BASC file."
+11 SET DIR(0)="Y"
SET DIR("A")="Proceed with transfer"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO END
+12 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($$CPT^ICPTCOD(+IBCD),U,7)
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
