IBARXEPE ;ALB/AAS - EDIT EXEMPTION LETTER - 28-APR-93
;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% I '$D(DT) D DT^DICRW
;
EDIT ; -- Edit form letter
I '$D(IOF) D HOME^%ZIS
W @IOF,"Edit Exemption Patient Notification Letter",!!!
S IBQUIT=0
S DIC(0)="AEQMNLZ",DIC="^IBE(354.6," D ^DIC K DIC G:+Y<1 EDQ S (IBLET,DA)=+Y,IBLET0=Y(0)
;
S DR="" I $P($G(^IBE(354.6,DA,0)),"^",4)="" S DR=".04////15;"
S DR=DR_"2;1;.04" I $P(IBLET0,"^",3)=2 S DR=DR_";.05;.07;.08"
;
S DIE="^IBE(354.6," D ^DIE K DA,DIE,DR
I $P(IBLET0,"^",3)=2 D SCHED
;
W !!
TEST S DIR(0)="Y",DIR("A")="Test Print Letter",DIR("B")="YES" D ^DIR K DIR
I Y'=1 G EDQ
;
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)")
S DIC("A")="Select "_$S($P(IBLET0,"^",3)=2:"",1:"Exempt ")_"BILLING PATIENT: "
W ! D ^DIC K DIC I +Y<1 G EDQ
S DFN=+Y,IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
I $P(IBLET0,"^",3)=2 S IBEXPD="December 31, "_($E(DT,1,3)+1700)
S %ZIS="QM" D ^%ZIS G:POP EDQ
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
U IO
;
ED1 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
I IBALIN<10!(IBALIN>25) S IBALIN=15
D ONE^IBARXEPL
;
EDQ D END^IBARXEPL
K IBLET0,IBEXPD
Q
;
;
SCHED ; Select days to generate the income test reminder letters.
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBD,IBDAY,IBI,IBQ
S IBD=$P(IBLET0,"^",6),IBQ=0
I IBD="" W !!,"The income test reminder letters are not currently scheduled to be printed."
I IBD]"" D I IBQ G SCHEDQ
.W !!,"The income test reminder letters are scheduled to be printed on:",!
.F IBI=1:1:$L(IBD) W !?8,$P("SUNDAY^MONDAY^TUESDAY^WEDNESDAY^THURSDAY^FRIDAY^SATURDAY","^",$E(IBD,IBI)+1)
.S DIR(0)="Y",DIR("A")="Do you wish to stop this job from running"
.S DIR("?")="Type 'YES' if you do not want this job to run any longer."
.W ! D ^DIR I $D(DIRUT) S IBQ=1 Q
.I Y S IBQ=1,$P(^IBE(354.6,IBLET,0),"^",6)="" W !,"The job has been unscheduled." Q
;
S IBDAY=$$ASK I IBDAY]"" S $P(^IBE(354.6,IBLET,0),"^",6)=IBDAY
SCHEDQ Q
;
ASK() ; Ask what days to generate letters.
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,I,X,Y
W !!?4,"Your printed letters may be picked up on the following mornings:"
W !!?8,"0 SUNDAY"
W !?8,"1 MONDAY"
W !?8,"2 TUESDAY"
W !?8,"3 WEDNESDAY"
W !?8,"4 THURSDAY"
W !?8,"5 FRIDAY"
W !?8,"6 SATURDAY",!
S DIR("A")=" Select, by number, those mornings to pick up letters"
S DIR(0)="L^0:6" D ^DIR I Y'["," S Y="" G ASKQ
F I=1:1:$L(Y,",") I $P(Y,",",I)]"" S X($P(Y,",",I))=""
S (I,Y)="" F S I=$O(X(I)) Q:I="" S Y=Y_I
ASKQ Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPE 2808 printed Dec 13, 2024@02:07:17 Page 2
IBARXEPE ;ALB/AAS - EDIT EXEMPTION LETTER - 28-APR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% IF '$DATA(DT)
DO DT^DICRW
+1 ;
EDIT ; -- Edit form letter
+1 IF '$DATA(IOF)
DO HOME^%ZIS
+2 WRITE @IOF,"Edit Exemption Patient Notification Letter",!!!
+3 SET IBQUIT=0
+4 SET DIC(0)="AEQMNLZ"
SET DIC="^IBE(354.6,"
DO ^DIC
KILL DIC
if +Y<1
GOTO EDQ
SET (IBLET,DA)=+Y
SET IBLET0=Y(0)
+5 ;
+6 SET DR=""
IF $PIECE($GET(^IBE(354.6,DA,0)),"^",4)=""
SET DR=".04////15;"
+7 SET DR=DR_"2;1;.04"
IF $PIECE(IBLET0,"^",3)=2
SET DR=DR_";.05;.07;.08"
+8 ;
+9 SET DIE="^IBE(354.6,"
DO ^DIE
KILL DA,DIE,DR
+10 IF $PIECE(IBLET0,"^",3)=2
DO SCHED
+11 ;
+12 WRITE !!
TEST SET DIR(0)="Y"
SET DIR("A")="Test Print Letter"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+1 IF Y'=1
GOTO EDQ
+2 ;
+3 SET DIC="^DPT("
SET DIC(0)="AEQM"
SET DIC("S")=$SELECT($PIECE(IBLET0,"^",3)=2:"I $G(^IBA(354,+Y,0))",1:"I $P($G(^IBA(354,+Y,0)),U,4)")
+4 SET DIC("A")="Select "_$SELECT($PIECE(IBLET0,"^",3)=2:"",1:"Exempt ")_"BILLING PATIENT: "
+5 WRITE !
DO ^DIC
KILL DIC
IF +Y<1
GOTO EDQ
+6 SET DFN=+Y
SET IBDATA=$$PT^IBEFUNC(DFN)
SET IBNAM=$PIECE(IBDATA,"^")
+7 IF $PIECE(IBLET0,"^",3)=2
SET IBEXPD="December 31, "_($EXTRACT(DT,1,3)+1700)
+8 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EDQ
+9 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ED1^IBARXEPE"
SET ZTSAVE("IB*")=""
SET ZTSAVE("DFN")=""
SET ZTDESC="Test Print Exemption Letter"
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
GOTO EDQ
+10 USE IO
+11 ;
ED1 SET IBALIN=$PIECE($GET(^IBE(354.6,IBLET,0)),"^",4)
+1 IF IBALIN<10!(IBALIN>25)
SET IBALIN=15
+2 DO ONE^IBARXEPL
+3 ;
EDQ DO END^IBARXEPL
+1 KILL IBLET0,IBEXPD
+2 QUIT
+3 ;
+4 ;
SCHED ; Select days to generate the income test reminder letters.
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBD,IBDAY,IBI,IBQ
+2 SET IBD=$PIECE(IBLET0,"^",6)
SET IBQ=0
+3 IF IBD=""
WRITE !!,"The income test reminder letters are not currently scheduled to be printed."
+4 IF IBD]""
Begin DoDot:1
+5 WRITE !!,"The income test reminder letters are scheduled to be printed on:",!
+6 FOR IBI=1:1:$LENGTH(IBD)
WRITE !?8,$PIECE("SUNDAY^MONDAY^TUESDAY^WEDNESDAY^THURSDAY^FRIDAY^SATURDAY","^",$EXTRACT(IBD,IBI)+1)
+7 SET DIR(0)="Y"
SET DIR("A")="Do you wish to stop this job from running"
+8 SET DIR("?")="Type 'YES' if you do not want this job to run any longer."
+9 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET IBQ=1
QUIT
+10 IF Y
SET IBQ=1
SET $PIECE(^IBE(354.6,IBLET,0),"^",6)=""
WRITE !,"The job has been unscheduled."
QUIT
End DoDot:1
IF IBQ
GOTO SCHEDQ
+11 ;
+12 SET IBDAY=$$ASK
IF IBDAY]""
SET $PIECE(^IBE(354.6,IBLET,0),"^",6)=IBDAY
SCHEDQ QUIT
+1 ;
ASK() ; Ask what days to generate letters.
+1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,I,X,Y
+2 WRITE !!?4,"Your printed letters may be picked up on the following mornings:"
+3 WRITE !!?8,"0 SUNDAY"
+4 WRITE !?8,"1 MONDAY"
+5 WRITE !?8,"2 TUESDAY"
+6 WRITE !?8,"3 WEDNESDAY"
+7 WRITE !?8,"4 THURSDAY"
+8 WRITE !?8,"5 FRIDAY"
+9 WRITE !?8,"6 SATURDAY",!
+10 SET DIR("A")=" Select, by number, those mornings to pick up letters"
+11 SET DIR(0)="L^0:6"
DO ^DIR
IF Y'[","
SET Y=""
GOTO ASKQ
+12 FOR I=1:1:$LENGTH(Y,",")
IF $PIECE(Y,",",I)]""
SET X($PIECE(Y,",",I))=""
+13 SET (I,Y)=""
FOR
SET I=$ORDER(X(I))
if I=""
QUIT
SET Y=Y_I
ASKQ QUIT Y
