IBECPTE ;ALB/ARH - ENTER/EDIT CPT BILLING TIME SENS DATA (350.4&350.5) ; 11/5/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)
;
EN4 ;entry point - enter/edit procedure and rate group for amb surg billing (350.4)
Q ; 133
D HOME^%ZIS
CPT W !! S DIC("A")="Select AMBULATORY SURGERY PROCEDURE: "
S DIC="^SD(409.71,",DIC(0)="AEQL" D ^DIC K DIC G:Y<0 CPTQ S IBCPT=+Y
I $P(Y,"^",3) S DIE="^SD(409.71,",DA=IBCPT,DR="[SD-AMB-PROC-EDIT]" D ^DIE K DIE,DR,DIC,Y G:'$D(DA) CPT K DA
S IBEDT=0 D DISCPT,EFFCPT D:IBEDT DISCPT G CPT
CPTQ K IBCPT,IBEDT,DA,DTOUT,DUOUT,X,Y
Q
;
EN5 ;entry point - enter/edit division and wage percentage data for amb surg billing (350.5)
D HOME^%ZIS
DIV W !! S DIC("A")="Select MEDICAL CENTER DIVISION: "
S DIC="^DG(40.8,",DIC(0)="AEQ" D ^DIC K DIC G:Y<0 DIVQ S IBDIV=+Y
S IBEDT=0 D DISDIV,EFFDIV D:IBEDT DISDIV G DIV
DIVQ K IBDIV,IBEDT,DA,DTOUT,DUOUT,X,Y
Q
;
EFFCPT ;enter/edit time sensitve procedure data
;DIR was used instead of DIC because of the size of the file and number of entries DIC would search through
S DIR("?")="Enter the date the new rate or status becomes effective",DIR("??")="^D LISTCPT^IBECPTE"
S DIR(0)="DO^::AEX",DIR("A")="Select PROCEDURE EFFECTIVE DATE" D ^DIR K DIR G:$D(DIRUT) EFFCPTQ S IBEFF=+Y
I $D(^IBE(350.4,"AIVDT",IBCPT,-IBEFF)) S Y=$O(^(-IBEFF,"")) G EDITC
S DIR(0)="Y",DIR("A")="Are you adding a new RATE GROUP entry to this PROCEDURE" D ^DIR K DIR G:'Y EFFCPT
K DO,DD S DIC="^IBE(350.4,",DIC(0)="",X=IBEFF,DIC("DR")=".02////"_IBCPT D FILE^DICN K DIC G:Y<0 EFFCPTQ
EDITC S IBEDT=1,DR=".01;.04;I X=0 S Y=0;.03",DA=+Y,DIE="^IBE(350.4,",DIE("NO^")="BACK" D ^DIE K DIE,DIC,DR,DA,Y
W ! G EFFCPT
EFFCPTQ K IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
Q
;
EFFDIV ;enter/edit time sensitve division data
S DIR("?")="Enter the date the new percentages or status becomes effective",DIR("??")="^D LISTDIV^IBECPTE"
S DIR(0)="DO^::AEX",DIR("A")="Select PROCEDURE EFFECTIVE DATE" D ^DIR K DIR G:$D(DIRUT) EFFDIVQ S IBEFF=+Y
I $D(^IBE(350.5,"AIVDT",IBDIV,-IBEFF)) S Y=$O(^(-IBEFF,"")) G EDITD
S DIR(0)="Y",DIR("A")="Are you adding a new WAGE PERCENTAGE entry to this DIVISION" D ^DIR K DIR G:'Y EFFDIV
K DO,DD S DIC="^IBE(350.5,",DIC(0)="",X=IBEFF,DIC("DR")=".02////"_IBDIV D FILE^DICN K DIC G:Y<0 EFFDIV
EDITD S DA=+Y,DIE="^IBE(350.5,",DR=".01;.04;I X=0 S Y=0;.05;.07",DIE("NO^")="BACK",IBEDT=1 D ^DIE K DIE,DIC,DR,DA,Y
W ! G EFFDIV
EFFDIVQ K IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
Q
;
DISCPT ;display data on procedure
S X="IBXCPTR" X ^%ZOSF("TEST") Q:'$T
W:$D(IOF) @IOF,?24,"Ambulatory Surgery Procedure Billing Profile"
;S D0=IBCPT D ^IBXCPTR K X,DXS,D0
Q
;
DISDIV ;display data on division
S X="IBXDIVD" X ^%ZOSF("TEST") Q:'$T
W:$D(IOF) @IOF,?24,"Medical Center Division Billing Profile"
S D0=IBDIV D ^IBXDIVD K X,DXS,D0
Q
;
LISTCPT ;provide list of effective dates already defined for CPT
Q:'$D(^IBE(350.4,"AIVDT",IBCPT)) N Y,IBX,IBY,IBLN
S IBX="" F S IBX=$O(^IBE(350.4,"AIVDT",IBCPT,IBX)) Q:IBX="" D
. S IBY="" F S IBY=$O(^IBE(350.4,"AIVDT",IBCPT,IBX,IBY)) Q:IBY="" D
.. S IBLN=$G(^IBE(350.4,IBY,0)) Q:IBLN="" S Y=-IBX X ^DD("DD")
.. W !,?5,Y,?20,$P($$CPT^ICPTCOD(+$P(IBLN,"^",2)),"^",2),?30,$S($P(IBLN,"^",4):"ACTIVE",1:"INACTIVE"),?43,$P($G(^IBE(350.1,+$P(IBLN,"^",3),0)),"^",1)
Q
;
LISTDIV ;provide list of effective dates already defined for division
Q:'$D(^IBE(350.5,"AIVDT",IBDIV)) N Y,IBX,IBY,IBLN
S IBX="" F S IBX=$O(^IBE(350.5,"AIVDT",IBDIV,IBX)) Q:IBX="" D
. S IBY="" F S IBY=$O(^IBE(350.5,"AIVDT",IBDIV,IBX,IBY)) Q:IBY="" D
.. S IBLN=$G(^IBE(350.5,IBY,0)) Q:IBLN="" S Y=-IBX X ^DD("DD")
.. W !,?4,Y,?20,$E($P($G(^DG(40.8,+$P(IBLN,"^",2),0)),"^",1),1,20),?43,$S($P(IBLN,"^",4):"ACTIVE",1:"INACTIVE"),?52,$J($P(IBLN,"^",5),7),?61,$J($P(IBLN,"^",6),7),?70,$J($P(IBLN,"^",7),7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECPTE 4047 printed Apr 09, 2024@21:38:04 Page 2
IBECPTE ;ALB/ARH - ENTER/EDIT CPT BILLING TIME SENS DATA (350.4&350.5) ; 11/5/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 ;
EN4 ;entry point - enter/edit procedure and rate group for amb surg billing (350.4)
+1 ; 133
QUIT
+2 DO HOME^%ZIS
CPT WRITE !!
SET DIC("A")="Select AMBULATORY SURGERY PROCEDURE: "
+1 SET DIC="^SD(409.71,"
SET DIC(0)="AEQL"
DO ^DIC
KILL DIC
if Y<0
GOTO CPTQ
SET IBCPT=+Y
+2 IF $PIECE(Y,"^",3)
SET DIE="^SD(409.71,"
SET DA=IBCPT
SET DR="[SD-AMB-PROC-EDIT]"
DO ^DIE
KILL DIE,DR,DIC,Y
if '$DATA(DA)
GOTO CPT
KILL DA
+3 SET IBEDT=0
DO DISCPT
DO EFFCPT
if IBEDT
DO DISCPT
GOTO CPT
CPTQ KILL IBCPT,IBEDT,DA,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
EN5 ;entry point - enter/edit division and wage percentage data for amb surg billing (350.5)
+1 DO HOME^%ZIS
DIV WRITE !!
SET DIC("A")="Select MEDICAL CENTER DIVISION: "
+1 SET DIC="^DG(40.8,"
SET DIC(0)="AEQ"
DO ^DIC
KILL DIC
if Y<0
GOTO DIVQ
SET IBDIV=+Y
+2 SET IBEDT=0
DO DISDIV
DO EFFDIV
if IBEDT
DO DISDIV
GOTO DIV
DIVQ KILL IBDIV,IBEDT,DA,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
EFFCPT ;enter/edit time sensitve procedure data
+1 ;DIR was used instead of DIC because of the size of the file and number of entries DIC would search through
+2 SET DIR("?")="Enter the date the new rate or status becomes effective"
SET DIR("??")="^D LISTCPT^IBECPTE"
+3 SET DIR(0)="DO^::AEX"
SET DIR("A")="Select PROCEDURE EFFECTIVE DATE"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EFFCPTQ
SET IBEFF=+Y
+4 IF $DATA(^IBE(350.4,"AIVDT",IBCPT,-IBEFF))
SET Y=$ORDER(^(-IBEFF,""))
GOTO EDITC
+5 SET DIR(0)="Y"
SET DIR("A")="Are you adding a new RATE GROUP entry to this PROCEDURE"
DO ^DIR
KILL DIR
if 'Y
GOTO EFFCPT
+6 KILL DO,DD
SET DIC="^IBE(350.4,"
SET DIC(0)=""
SET X=IBEFF
SET DIC("DR")=".02////"_IBCPT
DO FILE^DICN
KILL DIC
if Y<0
GOTO EFFCPTQ
EDITC SET IBEDT=1
SET DR=".01;.04;I X=0 S Y=0;.03"
SET DA=+Y
SET DIE="^IBE(350.4,"
SET DIE("NO^")="BACK"
DO ^DIE
KILL DIE,DIC,DR,DA,Y
+1 WRITE !
GOTO EFFCPT
EFFCPTQ KILL IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+1 QUIT
+2 ;
EFFDIV ;enter/edit time sensitve division data
+1 SET DIR("?")="Enter the date the new percentages or status becomes effective"
SET DIR("??")="^D LISTDIV^IBECPTE"
+2 SET DIR(0)="DO^::AEX"
SET DIR("A")="Select PROCEDURE EFFECTIVE DATE"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EFFDIVQ
SET IBEFF=+Y
+3 IF $DATA(^IBE(350.5,"AIVDT",IBDIV,-IBEFF))
SET Y=$ORDER(^(-IBEFF,""))
GOTO EDITD
+4 SET DIR(0)="Y"
SET DIR("A")="Are you adding a new WAGE PERCENTAGE entry to this DIVISION"
DO ^DIR
KILL DIR
if 'Y
GOTO EFFDIV
+5 KILL DO,DD
SET DIC="^IBE(350.5,"
SET DIC(0)=""
SET X=IBEFF
SET DIC("DR")=".02////"_IBDIV
DO FILE^DICN
KILL DIC
if Y<0
GOTO EFFDIV
EDITD SET DA=+Y
SET DIE="^IBE(350.5,"
SET DR=".01;.04;I X=0 S Y=0;.05;.07"
SET DIE("NO^")="BACK"
SET IBEDT=1
DO ^DIE
KILL DIE,DIC,DR,DA,Y
+1 WRITE !
GOTO EFFDIV
EFFDIVQ KILL IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+1 QUIT
+2 ;
DISCPT ;display data on procedure
+1 SET X="IBXCPTR"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+2 if $DATA(IOF)
WRITE @IOF,?24,"Ambulatory Surgery Procedure Billing Profile"
+3 ;S D0=IBCPT D ^IBXCPTR K X,DXS,D0
+4 QUIT
+5 ;
DISDIV ;display data on division
+1 SET X="IBXDIVD"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+2 if $DATA(IOF)
WRITE @IOF,?24,"Medical Center Division Billing Profile"
+3 SET D0=IBDIV
DO ^IBXDIVD
KILL X,DXS,D0
+4 QUIT
+5 ;
LISTCPT ;provide list of effective dates already defined for CPT
+1 if '$DATA(^IBE(350.4,"AIVDT",IBCPT))
QUIT
NEW Y,IBX,IBY,IBLN
+2 SET IBX=""
FOR
SET IBX=$ORDER(^IBE(350.4,"AIVDT",IBCPT,IBX))
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBY=""
FOR
SET IBY=$ORDER(^IBE(350.4,"AIVDT",IBCPT,IBX,IBY))
if IBY=""
QUIT
Begin DoDot:2
+4 SET IBLN=$GET(^IBE(350.4,IBY,0))
if IBLN=""
QUIT
SET Y=-IBX
XECUTE ^DD("DD")
+5 WRITE !,?5,Y,?20,$PIECE($$CPT^ICPTCOD(+$PIECE(IBLN,"^",2)),"^",2),?30,$SELECT($PIECE(IBLN,"^",4):"ACTIVE",1:"INACTIVE"),?43,$PIECE($GET(^IBE(350.1,+$PIECE(IBLN,"^",3),0)),"^",1)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
LISTDIV ;provide list of effective dates already defined for division
+1 if '$DATA(^IBE(350.5,"AIVDT",IBDIV))
QUIT
NEW Y,IBX,IBY,IBLN
+2 SET IBX=""
FOR
SET IBX=$ORDER(^IBE(350.5,"AIVDT",IBDIV,IBX))
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBY=""
FOR
SET IBY=$ORDER(^IBE(350.5,"AIVDT",IBDIV,IBX,IBY))
if IBY=""
QUIT
Begin DoDot:2
+4 SET IBLN=$GET(^IBE(350.5,IBY,0))
if IBLN=""
QUIT
SET Y=-IBX
XECUTE ^DD("DD")
+5 WRITE !,?4,Y,?20,$EXTRACT($PIECE($GET(^DG(40.8,+$PIECE(IBLN,"^",2),0)),"^",1),1,20),?43,$SELECT($PIECE(IBLN,"^",4):"ACTIVE",1:"INACTIVE"),?52,$JUSTIFY($PIECE(IBLN,"^",5),7),?61,$JUSTIFY($PIECE(IBLN,"^",6),7),?70,$JUSTIFY($PIECE(
IBLN,"^",7),7)
End DoDot:2
End DoDot:1
+6 QUIT
