source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBECPTE.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IBECPTE ;ALB/ARH - ENTER/EDIT CPT BILLING TIME SENS DATA (350.4&350.5) ; 11/5/91
2 ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; THIS FUNCTION IS OBSOLETE AND THE ROUTINE SHOULD BE DELETED WHEN 350.4 AND 350.5 ARE DELETED (133)
6 ;
7EN4 ;entry point - enter/edit procedure and rate group for amb surg billing (350.4)
8 Q ; 133
9 D HOME^%ZIS
10CPT W !! S DIC("A")="Select AMBULATORY SURGERY PROCEDURE: "
11 S DIC="^SD(409.71,",DIC(0)="AEQL" D ^DIC K DIC G:Y<0 CPTQ S IBCPT=+Y
12 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
13 S IBEDT=0 D DISCPT,EFFCPT D:IBEDT DISCPT G CPT
14CPTQ K IBCPT,IBEDT,DA,DTOUT,DUOUT,X,Y
15 Q
16 ;
17EN5 ;entry point - enter/edit division and wage percentage data for amb surg billing (350.5)
18 D HOME^%ZIS
19DIV W !! S DIC("A")="Select MEDICAL CENTER DIVISION: "
20 S DIC="^DG(40.8,",DIC(0)="AEQ" D ^DIC K DIC G:Y<0 DIVQ S IBDIV=+Y
21 S IBEDT=0 D DISDIV,EFFDIV D:IBEDT DISDIV G DIV
22DIVQ K IBDIV,IBEDT,DA,DTOUT,DUOUT,X,Y
23 Q
24 ;
25EFFCPT ;enter/edit time sensitve procedure data
26 ;DIR was used instead of DIC because of the size of the file and number of entries DIC would search through
27 S DIR("?")="Enter the date the new rate or status becomes effective",DIR("??")="^D LISTCPT^IBECPTE"
28 S DIR(0)="DO^::AEX",DIR("A")="Select PROCEDURE EFFECTIVE DATE" D ^DIR K DIR G:$D(DIRUT) EFFCPTQ S IBEFF=+Y
29 I $D(^IBE(350.4,"AIVDT",IBCPT,-IBEFF)) S Y=$O(^(-IBEFF,"")) G EDITC
30 S DIR(0)="Y",DIR("A")="Are you adding a new RATE GROUP entry to this PROCEDURE" D ^DIR K DIR G:'Y EFFCPT
31 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
32EDITC 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
33 W ! G EFFCPT
34EFFCPTQ K IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
35 Q
36 ;
37EFFDIV ;enter/edit time sensitve division data
38 S DIR("?")="Enter the date the new percentages or status becomes effective",DIR("??")="^D LISTDIV^IBECPTE"
39 S DIR(0)="DO^::AEX",DIR("A")="Select PROCEDURE EFFECTIVE DATE" D ^DIR K DIR G:$D(DIRUT) EFFDIVQ S IBEFF=+Y
40 I $D(^IBE(350.5,"AIVDT",IBDIV,-IBEFF)) S Y=$O(^(-IBEFF,"")) G EDITD
41 S DIR(0)="Y",DIR("A")="Are you adding a new WAGE PERCENTAGE entry to this DIVISION" D ^DIR K DIR G:'Y EFFDIV
42 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
43EDITD 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
44 W ! G EFFDIV
45EFFDIVQ K IBEFF,%DT,DR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
46 Q
47 ;
48DISCPT ;display data on procedure
49 S X="IBXCPTR" X ^%ZOSF("TEST") Q:'$T
50 W:$D(IOF) @IOF,?24,"Ambulatory Surgery Procedure Billing Profile"
51 ;S D0=IBCPT D ^IBXCPTR K X,DXS,D0
52 Q
53 ;
54DISDIV ;display data on division
55 S X="IBXDIVD" X ^%ZOSF("TEST") Q:'$T
56 W:$D(IOF) @IOF,?24,"Medical Center Division Billing Profile"
57 S D0=IBDIV D ^IBXDIVD K X,DXS,D0
58 Q
59 ;
60LISTCPT ;provide list of effective dates already defined for CPT
61 Q:'$D(^IBE(350.4,"AIVDT",IBCPT)) N Y,IBX,IBY,IBLN
62 S IBX="" F S IBX=$O(^IBE(350.4,"AIVDT",IBCPT,IBX)) Q:IBX="" D
63 . S IBY="" F S IBY=$O(^IBE(350.4,"AIVDT",IBCPT,IBX,IBY)) Q:IBY="" D
64 .. S IBLN=$G(^IBE(350.4,IBY,0)) Q:IBLN="" S Y=-IBX X ^DD("DD")
65 .. 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)
66 Q
67 ;
68LISTDIV ;provide list of effective dates already defined for division
69 Q:'$D(^IBE(350.5,"AIVDT",IBDIV)) N Y,IBX,IBY,IBLN
70 S IBX="" F S IBX=$O(^IBE(350.5,"AIVDT",IBDIV,IBX)) Q:IBX="" D
71 . S IBY="" F S IBY=$O(^IBE(350.5,"AIVDT",IBDIV,IBX,IBY)) Q:IBY="" D
72 .. S IBLN=$G(^IBE(350.5,IBY,0)) Q:IBLN="" S Y=-IBX X ^DD("DD")
73 .. 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)
74 Q
Note: See TracBrowser for help on using the repository browser.