Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXEPE

IBARXEPE.m

Go to the documentation of this file.
  1. IBARXEPE ;ALB/AAS - EDIT EXEMPTION LETTER - 28-APR-93
  1. ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. % I '$D(DT) D DT^DICRW
  1. ;
  1. EDIT ; -- Edit form letter
  1. I '$D(IOF) D HOME^%ZIS
  1. W @IOF,"Edit Exemption Patient Notification Letter",!!!
  1. S IBQUIT=0
  1. S DIC(0)="AEQMNLZ",DIC="^IBE(354.6," D ^DIC K DIC G:+Y<1 EDQ S (IBLET,DA)=+Y,IBLET0=Y(0)
  1. ;
  1. S DR="" I $P($G(^IBE(354.6,DA,0)),"^",4)="" S DR=".04////15;"
  1. S DR=DR_"2;1;.04" I $P(IBLET0,"^",3)=2 S DR=DR_";.05;.07;.08"
  1. ;
  1. S DIE="^IBE(354.6," D ^DIE K DA,DIE,DR
  1. I $P(IBLET0,"^",3)=2 D SCHED
  1. ;
  1. W !!
  1. TEST S DIR(0)="Y",DIR("A")="Test Print Letter",DIR("B")="YES" D ^DIR K DIR
  1. I Y'=1 G EDQ
  1. ;
  1. 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)")
  1. S DIC("A")="Select "_$S($P(IBLET0,"^",3)=2:"",1:"Exempt ")_"BILLING PATIENT: "
  1. W ! D ^DIC K DIC I +Y<1 G EDQ
  1. S DFN=+Y,IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
  1. I $P(IBLET0,"^",3)=2 S IBEXPD="December 31, "_($E(DT,1,3)+1700)
  1. S %ZIS="QM" D ^%ZIS G:POP EDQ
  1. 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
  1. U IO
  1. ;
  1. ED1 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
  1. I IBALIN<10!(IBALIN>25) S IBALIN=15
  1. D ONE^IBARXEPL
  1. ;
  1. EDQ D END^IBARXEPL
  1. K IBLET0,IBEXPD
  1. Q
  1. ;
  1. ;
  1. SCHED ; Select days to generate the income test reminder letters.
  1. N DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBD,IBDAY,IBI,IBQ
  1. S IBD=$P(IBLET0,"^",6),IBQ=0
  1. I IBD="" W !!,"The income test reminder letters are not currently scheduled to be printed."
  1. I IBD]"" D I IBQ G SCHEDQ
  1. .W !!,"The income test reminder letters are scheduled to be printed on:",!
  1. .F IBI=1:1:$L(IBD) W !?8,$P("SUNDAY^MONDAY^TUESDAY^WEDNESDAY^THURSDAY^FRIDAY^SATURDAY","^",$E(IBD,IBI)+1)
  1. .S DIR(0)="Y",DIR("A")="Do you wish to stop this job from running"
  1. .S DIR("?")="Type 'YES' if you do not want this job to run any longer."
  1. .W ! D ^DIR I $D(DIRUT) S IBQ=1 Q
  1. .I Y S IBQ=1,$P(^IBE(354.6,IBLET,0),"^",6)="" W !,"The job has been unscheduled." Q
  1. ;
  1. S IBDAY=$$ASK I IBDAY]"" S $P(^IBE(354.6,IBLET,0),"^",6)=IBDAY
  1. SCHEDQ Q
  1. ;
  1. ASK() ; Ask what days to generate letters.
  1. N DIR,DIRUT,DUOUT,DTOUT,DIROUT,I,X,Y
  1. W !!?4,"Your printed letters may be picked up on the following mornings:"
  1. W !!?8,"0 SUNDAY"
  1. W !?8,"1 MONDAY"
  1. W !?8,"2 TUESDAY"
  1. W !?8,"3 WEDNESDAY"
  1. W !?8,"4 THURSDAY"
  1. W !?8,"5 FRIDAY"
  1. W !?8,"6 SATURDAY",!
  1. S DIR("A")=" Select, by number, those mornings to pick up letters"
  1. S DIR(0)="L^0:6" D ^DIR I Y'["," S Y="" G ASKQ
  1. F I=1:1:$L(Y,",") I $P(Y,",",I)]"" S X($P(Y,",",I))=""
  1. S (I,Y)="" F S I=$O(X(I)) Q:I="" S Y=Y_I
  1. ASKQ Q Y