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

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1IBARXEPE ;ALB/AAS - EDIT EXEMPTION LETTER - 28-APR-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% I '$D(DT) D DT^DICRW
6 ;
7EDIT ; -- Edit form letter
8 I '$D(IOF) D HOME^%ZIS
9 W @IOF,"Edit Exemption Patient Notification Letter",!!!
10 S IBQUIT=0
11 S DIC(0)="AEQMNLZ",DIC="^IBE(354.6," D ^DIC K DIC G:+Y<1 EDQ S (IBLET,DA)=+Y,IBLET0=Y(0)
12 ;
13 S DR="" I $P($G(^IBE(354.6,DA,0)),"^",4)="" S DR=".04////15;"
14 S DR=DR_"2;1;.04" I $P(IBLET0,"^",3)=2 S DR=DR_";.05;.07;.08"
15 ;
16 S DIE="^IBE(354.6," D ^DIE K DA,DIE,DR
17 I $P(IBLET0,"^",3)=2 D SCHED
18 ;
19 W !!
20TEST S DIR(0)="Y",DIR("A")="Test Print Letter",DIR("B")="YES" D ^DIR K DIR
21 I Y'=1 G EDQ
22 ;
23 S DIC="^DPT(",DIC(0)="AEQM",DIC("S")=$S($P(IBLET0,"^",3)=2:"I $G(^IBA(354,+Y,0))",1:"I $P($G(^IBA(354,+Y,0)),U,4)")
24 S DIC("A")="Select "_$S($P(IBLET0,"^",3)=2:"",1:"Exempt ")_"BILLING PATIENT: "
25 W ! D ^DIC K DIC I +Y<1 G EDQ
26 S DFN=+Y,IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
27 I $P(IBLET0,"^",3)=2 S IBEXPD="December 31, "_($E(DT,1,3)+1700)
28 S %ZIS="QM" D ^%ZIS G:POP EDQ
29 I $D(IO("Q")) K IO("Q") S ZTRTN="ED1^IBARXEPE",ZTSAVE("IB*")="",ZTSAVE("DFN")="",ZTDESC="Test Print Exemption Letter" D ^%ZTLOAD K ZTSK D HOME^%ZIS G EDQ
30 U IO
31 ;
32ED1 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
33 I IBALIN<10!(IBALIN>25) S IBALIN=15
34 D ONE^IBARXEPL
35 ;
36EDQ D END^IBARXEPL
37 K IBLET0,IBEXPD
38 Q
39 ;
40 ;
41SCHED ; Select days to generate the income test reminder letters.
42 N DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBD,IBDAY,IBI,IBQ
43 S IBD=$P(IBLET0,"^",6),IBQ=0
44 I IBD="" W !!,"The income test reminder letters are not currently scheduled to be printed."
45 I IBD]"" D I IBQ G SCHEDQ
46 .W !!,"The income test reminder letters are scheduled to be printed on:",!
47 .F IBI=1:1:$L(IBD) W !?8,$P("SUNDAY^MONDAY^TUESDAY^WEDNESDAY^THURSDAY^FRIDAY^SATURDAY","^",$E(IBD,IBI)+1)
48 .S DIR(0)="Y",DIR("A")="Do you wish to stop this job from running"
49 .S DIR("?")="Type 'YES' if you do not want this job to run any longer."
50 .W ! D ^DIR I $D(DIRUT) S IBQ=1 Q
51 .I Y S IBQ=1,$P(^IBE(354.6,IBLET,0),"^",6)="" W !,"The job has been unscheduled." Q
52 ;
53 S IBDAY=$$ASK I IBDAY]"" S $P(^IBE(354.6,IBLET,0),"^",6)=IBDAY
54SCHEDQ Q
55 ;
56ASK() ; Ask what days to generate letters.
57 N DIR,DIRUT,DUOUT,DTOUT,DIROUT,I,X,Y
58 W !!?4,"Your printed letters may be picked up on the following mornings:"
59 W !!?8,"0 SUNDAY"
60 W !?8,"1 MONDAY"
61 W !?8,"2 TUESDAY"
62 W !?8,"3 WEDNESDAY"
63 W !?8,"4 THURSDAY"
64 W !?8,"5 FRIDAY"
65 W !?8,"6 SATURDAY",!
66 S DIR("A")=" Select, by number, those mornings to pick up letters"
67 S DIR(0)="L^0:6" D ^DIR I Y'["," S Y="" G ASKQ
68 F I=1:1:$L(Y,",") I $P(Y,",",I)]"" S X($P(Y,",",I))=""
69 S (I,Y)="" F S I=$O(X(I)) Q:I="" S Y=Y_I
70ASKQ Q Y
Note: See TracBrowser for help on using the repository browser.