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

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1IBEMTBC ;ALB/RLW - IB MEANS TEST BILLING CLOCK FILE UPDATE ; 15-JAN-92
2 ;;2.0;INTEGRATED BILLING;**153,199**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; Entry point for Clock Maintenance
6 ;
7 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
8 ;S XRTL=$ZU(0),XRTN="IBEMTBC-1" D T0^%ZOSV ;start rt clock
9 ;
10 D HOME^%ZIS,NOW^%DTC S IBDT=% K % I '$D(DT) D DT^DICRW
11 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
12 S DIR(0)="PO^2:AEMQZ" D ^DIR K DIR S DFN=+Y I $D(DIRUT) G ENQ
13 I $$BILST^DGMTUB(DFN)=0 S J=5 D ERR G EN
14 I $D(^IBE(351,"ACT",DFN)) S IBSELECT="ADJUST",IBDR="[IB BILLING CYCLE ADJUST]" D ADJUST,CLEANUP G ENQ
15 S IBSELECT="ADD",IBDR="[IB BILLING CYCLE ADD]" D ADDNEW,CLEANUP
16 ;
17ENQ I '$D(DIRUT) W ! G EN
18 K DIC,IBSELECT,DFN,IBDR,IBEL,DFN,IBIEN,IBDATA,J,DIRUT,IBFAC,IBSITE,IBDT
19 ;
20 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBEMTBC" D T1^%ZOSV ;stop rt clock
21 ;
22 Q
23 ;
24ADJUST ; - show current active clock; inactivate and add a new one
25 W @IOF
26 S IBIEN=$O(^IBE(351,"ACT",DFN,0))
27 S DIC="^IBE(351,",DA=IBIEN W !! D EN^DIQ K DIC,DA
28 S DIR(0)="Y",DIR("A")="Do you want to update" D ^DIR K DIR Q:+Y<1
29 ;
30 ; - save current clock, change to cancelled and delete "ACT" xref
31 K ^IBE(351,"ACT",DFN) L +(^IBE(351,IBIEN))
32 S IBDATA=$P(^IBE(351,IBIEN,0),"^",2,10),$P(^IBE(351,IBIEN,0),"^",4)=3,$P(^(1),"^",3,4)=DUZ_"^"_IBDT
33 L -(^IBE(351,IBIEN))
34 ;
35ADDNEW ; - add a new clock and allow updating
36 I IBSELECT="ADD" D Q:'Y W !
37 .W !!,"This patient does not have an active billing clock!"
38 .S DIR(0)="Y",DIR("A")="Is it okay to add a new billing clock for this patient"
39 .D ^DIR K DIR,DIRUT,DUOUT,DTOUT
40 ;
41 D SITE^IBAUTL I 'IBSITE S J=1 G ERR
42 S I=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'I S J=3 G ERR
43 K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351,DIC("DR")=".02////"_DFN_";11////"_DUZ_";12////"_IBDT
44 F I=I:1 I I>0,'$D(^IBE(351,I)) L +^IBE(351,I):2 I $T,'$D(^IBE(351,I)) S DINUM=I,X=+IBSITE_I D FILE^DICN K DIC,DR S IBCL=+Y Q:+Y>0
45 I IBSELECT'="ADD" S $P(^IBE(351,IBCL,0),"^",2,10)=IBDATA,DIK="^IBE(351,",DA=IBCL D IX1^DIK K DIK
46 S DIE="^IBE(351,",DA=IBCL,DR=IBDR D ^DIE K DA,DIE,DR
47 L -^IBE(351,IBCL)
48 ;
49 ; - if the updated clock was cancelled, with no other changes made,
50 ; - move the update reason over to the old clock and cancel the new one.
51 I IBSELECT'="ADD" D
52 .I $L(^IBE(351,+$G(IBIEN),0),"^")=9 S $P(^IBE(351,+$G(IBIEN),0),"^",10)=""
53 .I $L(^IBE(351,IBCL,0),"^")=9 S $P(^IBE(351,IBCL,0),"^",10)=""
54 .Q:$P(^IBE(351,+$G(IBIEN),0),"^",2,10)'=$P(^IBE(351,IBCL,0),"^",2,10)
55 .W !!,"Since you only cancelled the clock, I'll delete the new clock..."
56 .I $P(^IBE(351,IBCL,0),"^",11)]"" S $P(^IBE(351,+$G(IBIEN),0),"^",11)=$P(^IBE(351,IBCL,0),"^",11) W !,"(but I'll save the update reason)..."
57 .S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
58 ;
59 ; - if the user is adding a new clock, and there is no clock
60 ; - begin date or status, delete the clock.
61 I IBSELECT="ADD" S IBDATA=^IBE(351,IBCL,0) I '$P(IBDATA,"^",3)!'$P(IBDATA,"^",4) D
62 .W !!,"This new clock is incomplete!! Deleting the clock from the system..."
63 .S DA=IBCL,DIK="^IBE(351," D ^DIK K DIK,DA
64 K IBCL
65 Q
66 ;
67ERR ; - display error messages
68 W !?5,$P($T(ERRMSG+J),";;",2)
69CLEANUP K IBCLDA,IBCLDAY,IBCLDT,IBMED,IBCLDOL,X,IBSELECT,DLAYGO,IBDT
70 Q
71 ;
72ERRMSG ; - possible error messages
73 ;;No value returned from call to SITE^IBAUTL
74 ;;Record locked, try again later!
75 ;;Problem extracting last IFN from zeroth node of MEANS TEST BILLING CLOCK file
76 ;;Unable to add record to MEANS TEST BILLING CLOCK file
77 ;;Not a Means Test copay patient!
Note: See TracBrowser for help on using the repository browser.