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

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1IBECEA51 ;ALB/CPM - Cancel/Edit/Add... Update Event Actions ; 05-MAY-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**57**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CS ; 'Change Status' Entry Action
6 N DIE,DA,DR,IBCOMMIT,IBLINE,IBNDX,IBSTAT,IBDEST,IBNBR,IBN
7 S IBCOMMIT=0 D EN^VALM2($G(XQORNOD(0))) I '$O(VALMY(0)) G CSQ
8 S IBNBR="" F S IBNBR=$O(VALMY(IBNBR)) Q:'IBNBR D
9 .S IBLINE=^TMP("IBACME",$J,IBNBR,0),IBNDX=^TMP("IBACMEI",$J,IBNBR)
10 .S IBSTAT=$P(IBNDX,"^"),IBN=$P(IBNDX,"^",3)
11 .S IBDEST=$S(IBSTAT="OPEN":"CLOSED",1:"OPEN")
12 .W !!,"Processing Event #",IBNBR,":"
13 .Q:$$FEE(IBN)
14 .S DIR(0)="Y",DIR("A")="Change the status of this event from "_IBSTAT_" to "_IBDEST,DIR("?")="^D HCS^IBECEA51"
15 .D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) W !,"This event will remain "_IBSTAT_"." Q
16 .S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBDEST="OPEN":1,1:2)
17 .D ^DIE I $D(Y) W !,"An error occured while changing the status - event is still ",IBSTAT,"." Q
18 .S IBCOMMIT=1 W !,"The status has been changed to ",IBDEST,"."
19 .S IBLINE=$$SETSTR^VALM1(IBDEST,IBLINE,+$P(VALMDDF("STATUS"),"^",2),+$P(VALMDDF("STATUS"),"^",3))
20 .S ^TMP("IBACME",$J,IBNBR,0)=IBLINE,$P(^TMP("IBACMEI",$J,IBNBR),"^",1)=IBDEST
21 D PAUSE^VALM1
22CSQ S VALMBCK=$S(IBCOMMIT:"R",1:"")
23 Q
24 ;
25HCS ; Help for 'Change Status'
26 W !!,"Please enter 'Y' or 'YES' to change the status of this event from ",IBSTAT
27 W !,"to ",IBDEST,", or 'N', 'NO', or '^' to quit."
28 W !!,"If the status of this event is changed to open, and the patient is still an"
29 W !,"inpatient in this ward (on the specified admission date), charges will be"
30 W !,"billed starting the day after the Date Last Calculated. If the status is"
31 W !,"changed to closed, no further charges will be associated with this event."
32 Q
33 ;
34LC ; 'Last Date Calc' Entry Action
35 N IBCOMMIT,IBNBR
36 S IBCOMMIT=0 D EN^VALM2($G(XQORNOD(0))) I '$O(VALMY(0)) G LCQ
37 S IBNBR="" F S IBNBR=$O(VALMY(IBNBR)) Q:'IBNBR D LCO
38 D PAUSE^VALM1
39LCQ S VALMBCK=$S(IBCOMMIT:"R",1:"")
40 Q
41 ;
42LCO ; Update Last Calc Date for a Single Event.
43 N DIE,DR,DA,IBLINE,IBNDX,IBLCAL,IBN,IBEVDT,IBNEWV,%DT
44 S IBLINE=^TMP("IBACME",$J,IBNBR,0),IBNDX=^TMP("IBACMEI",$J,IBNBR)
45 S IBLCAL=$P(IBNDX,"^",2),IBN=$P(IBNDX,"^",3),IBEVDT=$P(IBNDX,"^",4)
46 W !!,"Processing Event #",IBNBR,":"
47 I $$FEE(IBN) G LCOQ
48LCP W !,"Date Last Calculated: " W:IBLCAL $$DAT2^IBOUTL(IBLCAL),"// "
49 R X:DTIME S:'IBLCAL&(X="") X="^" S:'$T X="^" I $E(X)="^" G LCOQ
50 I X="" W " (",$$DAT2^IBOUTL(IBLCAL),")",!,"No change!" G LCOQ
51 I $E(X)="?"!($E(X)="@") D HLC G LCP
52 S %DT="EPX" D ^%DT I Y<0 D HELP^%DTC G LCP
53 I Y<IBEVDT!(Y>$$FMADD^XLFDT(DT,-1)) D HLC G LCP
54 S IBNEWV=Y,DIE="^IB(",DA=IBN,DR=".18////"_Y
55 D ^DIE I $D(Y) W !,"An error occured while changing the Last Calc Date - no change made!" G LCOQ
56 S IBCOMMIT=1 W !,"The Date Last Calculated has been changed to ",$$DAT1^IBOUTL(IBNEWV),"."
57 S IBLINE=$$SETSTR^VALM1($$DAT1^IBOUTL(IBNEWV),IBLINE,+$P(VALMDDF("LCALC"),"^",2),+$P(VALMDDF("LCALC"),"^",3))
58 S ^TMP("IBACME",$J,IBNBR,0)=IBLINE,$P(^TMP("IBACMEI",$J,IBNBR),"^",2)=IBNEWV
59LCOQ Q
60 ;
61HLC ; Help for 'Last Calc Date'
62 W !!,"The Date Last Calculated is used to record the last date for which Means Test"
63 W !,"charges were billed for an admission."
64 W !!,"This date cannot be deleted. Please enter a date not less than the Event"
65 W !,"Date (",$$DAT1^IBOUTL(IBEVDT),") and not greater than yesterday (",$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-1)),").",!
66 Q
67 ;
68 ;
69FEE(IBN) ; If the Event Record is for Fee, it is uneditable.
70 ; Input: IBN -- Pointer to an event record in file #350
71 ; Output: IBFEE -- 1 = record is uneditable
72 ; 0 = record is editable
73 N IBFEE S IBFEE=0
74 I $P($G(^IB(+$G(IBN),0)),"^",8)["FEE" S IBFEE=1 W !,*7,"Fee Admissions cannot be edited!"
75FEEQ Q IBFEE
Note: See TracBrowser for help on using the repository browser.