- 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 23, 2025@18:36:15 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
