Routine: IBARXEPL

IBARXEPL	;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

%	I '$D(DT) D DT^DICRW

	I '$D(IOF) D HOME^%ZIS

	W @IOF,"Print Exemption letters to patients"

	K ^TMP("IBEX LIST",$J)

	S (IBTEMP,IBADDT,IBOK,IBQUIT)=""

	; -- find template

	S IBTEMP=$O(^DIBT("B","IB EXEMPTION LETTER",0))

	; -- use old template or build new one

	W !!!

	I IBTEMP D  G:IBQUIT END

	.S DIR(0)="Y",DIR("A")="Delete Results of Previous Search",DIR("B")="NO"

	.S DIR("?")="Enter 'Yes' if you would like to delete the results of a previous search, Enter 'No' if you want to keep the results (i.e. you may be reprinting letters from the same list)."

	.D ^DIR K DIR I $D(DIRUT) S IBQUIT=1

	.I Y=1 D DELT S IBTEMP=0

.Q

	I 'IBTEMP D  G:IBQUIT END D:IBADD ADDT

	.S DIR(0)="Y",DIR("A")="Store results of Search in Template",DIR("B")="YES"

	.S DIR("?")="Enter 'Yes' if you would like the results of the search stored in a Sort Template named IB EXEMPTION LETTER.  Enter 'No' if you do not want the template created."

	.S DIR("?",1)="Creating the search template will allow you to",DIR("?",2)="print other lists from the patients you sent the letters to."

	.S DIR("?",3)=" "

	.D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 Q

	.S IBADD=Y

.Q

	D PRINT

END	Q:$D(ZTQUEUED)

	D ^%ZISC

	D KVAR^VADPT

	K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP,IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN,DIOEND

	K ^TMP("IBEX LIST",$J)

ADDT	; -- create new template in ^dibt

	K DD,DO

	S DIC="^DIBT(",DIC(0)="L",X="IB EXEMPTION LETTER",DIC("DR")="2///NOW;4///354;7///NOW"

	D FILE^DICN S IBTEMP=+Y I +Y S IBADDT=1 W !!,"<<< Search Template IB EXEMPTION LETTER created!",!

DELT	; -- delete search template

	Q:$P($G(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"

	S DIK="^DIBT(",DA=IBTEMP D ^DIK K DIK,DA

	W !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!

	S IBTEMP=""

SCR	; -- don't send letters to deceased patients, non-vets

	;    called by print template IB DO NOT USE

	S IBOK=0 N IBX

	I +$G(^DPT(D0,.35)) G SCRQ ; deceased

	I $P($G(^DPT(D0,"VET")),"^")="N" G SCRQ ; patient non-vet

	S IBX=$P($G(^IBE(354.2,+$P($G(^IBA(354,D0,0)),"^",5),0)),"^",5)

	I IBX=60 G SCRQ ;exemption is non-vet

	I IBX=10 G SCRQ ;sc>50

	S IBOK=1

SCRQ	Q

PRINT	; -- run through list of letters to PRINT

	S X="IB NOW EXEMPT",DIC(0)="XZ",DIC="^IBE(354.6," D ^DIC S IBLET=+Y

	Q:IBLET<1

	S DIC="^IBA(354,",L=0,FLDS="[IB DO NOT USE]",BY="[IB EXEMPT PATIENTS]",(FR,TO)="?,?,?",DHD="@@"

	S DIOEND="D LET^IBARXEPL"

	D EN1^DIP

LET	; -- called by dioend, prints list from tmp array

	S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)

	I IBALIN<10!(IBALIN>25) S IBALIN=15

	S IBNAM="" F  S IBNAM=$O(^TMP("IBEX LIST",$J,IBNAM)) Q:IBNAM=""!(IBQUIT)  S DFN=0 F  S DFN=$O(^TMP("IBEX LIST",$J,IBNAM,DFN)) Q:'DFN!(IBQUIT)  S IBDATA=^(DFN) D ONE

	D FINAL,END

ONE	; -- print one letter

	S TAB=5

	I '$D(IOF) D HOME^%ZIS

	S IBCNTL=$G(IBCNTL)+1 I $E(IOST,1,2)="C-" W @IOF

	S IB=0

	; -- print header

	S IBCNT=0

	F I=1:1:6 S IB=$O(^IBE(354.6,IBLET,2,IB)) Q:'IB  S X=$G(^(IB,0)) W !?(IOM-$L(X)+1/2),X S IBCNT=IBCNT+1

	W ! S Y=DT D DT^DIQ S IBCNT=IBCNT+1

	F IBCNT=IBCNT:1:6 W ! S IBCNT=IBCNT+1

	W !?(IOM-28),"In Reply Refer To:" S IBCNT=IBCNT+1

	W !?(IOM-28),$P(IBDATA,"^",2) S IBCNT=IBCNT+1

	W ! S IBCNT=IBCNT+1

	S IBX=$$RXST^IBARXEU(DFN,DT) I $P(IBX,"^",3)=120 S Y=$$PLUS^IBARXEU0($P(IBX,"^",5)) W ?(IOM-28),"Renewal Date: " D DT^DIQ

	; -- print pt. name and address

	F IBCNT=IBCNT:1:(IBALIN-1) W !

	W !?TAB,$P(IBNAM,",",2)," ",$P(IBNAM,",") D ADD^VADPT S IBCNT=IBCNT+1

	W !?TAB,VAPA(1) S IBCNT=IBCNT+1

	I VAPA(2)'="" W !?TAB,VAPA(2) I VAPA(3)'="" W ", ",VAPA(3) S IBCNT=IBCNT+1

	W !?TAB,VAPA(4),", ",$P($G(^DIC(5,+VAPA(5),0)),"^",2),"  ",VAPA(6) S IBCNT=IBCNT+1

	I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT

	; -- print main body

	W !! S IBCNT=IBCNT+2

	S IB=0 F  S IB=$O(^IBE(354.6,IBLET,1,IB)) Q:IB=""  S X=$G(^(IB,0)) W !,X S IBCNT=IBCNT+1

	I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT

	W:$E(IOST,1,2)'="C-" @IOF

FINAL	; -- Print last page

	W @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"

	W !!,?20,$G(IBCNTL)," LETTERS PRINTED"

IBARXEPL  ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

%          IF '$DATA(DT)

               DO DT^DICRW

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        WRITE @IOF,"Print Exemption letters to patients"

 +3        KILL ^TMP("IBEX LIST",$JOB)

 +4        SET (IBTEMP,IBADDT,IBOK,IBQUIT)=""

 +5       ;

 +6       ; -- find template

 +7        SET IBTEMP=$ORDER(^DIBT("B","IB EXEMPTION LETTER",0))

 +8       ;

 +9       ; -- use old template or build new one

 +10       WRITE !!!

 +11      ;

 +12       IF IBTEMP

               Begin DoDot:1

 +13               SET DIR(0)="Y"

                   SET DIR("A")="Delete Results of Previous Search"

                   SET DIR("B")="NO"

 +14               SET DIR("?")="Enter 'Yes' if you would like to delete the results of a previous search, Enter 'No' if you want to keep the results (i.e. you may be reprinting letters from the same list)."

 +15               DO ^DIR

                   KILL DIR

                   IF $DATA(DIRUT)

                       SET IBQUIT=1

 +16               IF Y=1

                       DO DELT

                       SET IBTEMP=0

 +17               QUIT

               End DoDot:1

               IF IBQUIT

                   GOTO END

 +18      ;

 +19       IF 'IBTEMP

               Begin DoDot:1

 +20               SET DIR(0)="Y"

                   SET DIR("A")="Store results of Search in Template"

                   SET DIR("B")="YES"

 +21               SET DIR("?")="Enter 'Yes' if you would like the results of the search stored in a Sort Template named IB EXEMPTION LETTER.  Enter 'No' if you do not want the template created."

 +22               SET DIR("?",1)="Creating the search template will allow you to"

                   SET DIR("?",2)="print other lists from the patients you sent the letters to."

 +23               SET DIR("?",3)=" "

 +24               DO ^DIR

                   KILL DIR

                   IF $DATA(DIRUT)

                       SET IBQUIT=1

                       QUIT

 +25               SET IBADD=Y

 +26               QUIT

               End DoDot:1

               IF IBQUIT

                   GOTO END

               IF IBADD

                   DO ADDT

 +27      ;

 +28       DO PRINT

 +29      ;

 +30      ;

END        IF $DATA(ZTQUEUED)

               QUIT

 +1        DO ^%ZISC

 +2        DO KVAR^VADPT

 +3        KILL C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP,IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN,DIOEND

 +4        KILL ^TMP("IBEX LIST",$JOB)

 +5        QUIT

 +6       ;

ADDT      ; -- create new template in ^dibt

 +1        KILL DD,DO

 +2        SET DIC="^DIBT("

           SET DIC(0)="L"

           SET X="IB EXEMPTION LETTER"

           SET DIC("DR")="2///NOW;4///354;7///NOW"

 +3        DO FILE^DICN

           SET IBTEMP=+Y

           IF +Y

               SET IBADDT=1

               WRITE !!,"<<< Search Template IB EXEMPTION LETTER created!",!

 +4        QUIT

 +5       ;

DELT      ; -- delete search template

 +1        IF $PIECE($GET(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"

               QUIT

 +2        SET DIK="^DIBT("

           SET DA=IBTEMP

           DO ^DIK

           KILL DIK,DA

 +3        WRITE !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!

 +4        SET IBTEMP=""

 +5        QUIT

 +6       ;

SCR       ; -- don't send letters to deceased patients, non-vets

 +1       ;    called by print template IB DO NOT USE

 +2        SET IBOK=0

           NEW IBX

 +3       ; deceased

           IF +$GET(^DPT(D0,.35))

               GOTO SCRQ

 +4       ; patient non-vet

           IF $PIECE($GET(^DPT(D0,"VET")),"^")="N"

               GOTO SCRQ

 +5        SET IBX=$PIECE($GET(^IBE(354.2,+$PIECE($GET(^IBA(354,D0,0)),"^",5),0)),"^",5)

 +6       ;exemption is non-vet

           IF IBX=60

               GOTO SCRQ

 +7       ;sc>50

           IF IBX=10

               GOTO SCRQ

 +8        SET IBOK=1

SCRQ       QUIT

 +1       ;

PRINT     ; -- run through list of letters to PRINT

 +1        SET X="IB NOW EXEMPT"

           SET DIC(0)="XZ"

           SET DIC="^IBE(354.6,"

           DO ^DIC

           SET IBLET=+Y

 +2        IF IBLET<1

               QUIT

 +3       ;

 +4        SET DIC="^IBA(354,"

           SET L=0

           SET FLDS="[IB DO NOT USE]"

           SET BY="[IB EXEMPT PATIENTS]"

           SET (FR,TO)="?,?,?"

           SET DHD="@@"

 +5        SET DIOEND="D LET^IBARXEPL"

 +6        DO EN1^DIP

 +7        QUIT

 +8       ;

LET       ; -- called by dioend, prints list from tmp array

 +1        SET IBALIN=$PIECE($GET(^IBE(354.6,IBLET,0)),"^",4)

 +2        IF IBALIN<10!(IBALIN>25)

               SET IBALIN=15

 +3        SET IBNAM=""

FOR

               SET IBNAM=$ORDER(^TMP("IBEX LIST",$JOB,IBNAM))

               IF IBNAM=""!(IBQUIT)

                   QUIT

               SET DFN=0

FOR

                   SET DFN=$ORDER(^TMP("IBEX LIST",$JOB,IBNAM,DFN))

                   IF 'DFN!(IBQUIT)

                       QUIT

                   SET IBDATA=^(DFN)

                   DO ONE

 +4        DO FINAL

           DO END

 +5        QUIT

 +6       ;

ONE       ; -- print one letter

 +1        SET TAB=5

 +2        IF '$DATA(IOF)

               DO HOME^%ZIS

 +3        SET IBCNTL=$GET(IBCNTL)+1

           IF $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF

 +4        SET IB=0

 +5       ;

 +6       ; -- print header

 +7        SET IBCNT=0

 +8        FOR I=1:1:6

               SET IB=$ORDER(^IBE(354.6,IBLET,2,IB))

               IF 'IB

                   QUIT

               SET X=$GET(^(IB,0))

               WRITE !?(IOM-$LENGTH(X)+1/2),X

               SET IBCNT=IBCNT+1

 +9        WRITE !

           SET Y=DT

           DO DT^DIQ

           SET IBCNT=IBCNT+1

 +10       FOR IBCNT=IBCNT:1:6

               WRITE !

               SET IBCNT=IBCNT+1

 +11       WRITE !?(IOM-28),"In Reply Refer To:"

           SET IBCNT=IBCNT+1

 +12       WRITE !?(IOM-28),$PIECE(IBDATA,"^",2)

           SET IBCNT=IBCNT+1

 +13       WRITE !

           SET IBCNT=IBCNT+1

 +14       SET IBX=$$RXST^IBARXEU(DFN,DT)

           IF $PIECE(IBX,"^",3)=120

               SET Y=$$PLUS^IBARXEU0($PIECE(IBX,"^",5))

               WRITE ?(IOM-28),"Renewal Date: "

               DO DT^DIQ

 +15      ;

 +16      ; -- print pt. name and address

 +17       FOR IBCNT=IBCNT:1:(IBALIN-1)

               WRITE !

 +18       WRITE !?TAB,$PIECE(IBNAM,",",2)," ",$PIECE(IBNAM,",")

           DO ADD^VADPT

           SET IBCNT=IBCNT+1

 +19       WRITE !?TAB,VAPA(1)

           SET IBCNT=IBCNT+1

 +20       IF VAPA(2)'=""

               WRITE !?TAB,VAPA(2)

               IF VAPA(3)'=""

                   WRITE ", ",VAPA(3)

                   SET IBCNT=IBCNT+1

 +21       WRITE !?TAB,VAPA(4),", ",$PIECE($GET(^DIC(5,+VAPA(5),0)),"^",2),"  ",VAPA(6)

           SET IBCNT=IBCNT+1

 +22       IF $EXTRACT(IOST,1,2)="C-"

               DO PAUSE^IBOUTL

               IF IBQUIT

                   QUIT

 +23      ;

 +24      ; -- print main body

 +25       WRITE !!

           SET IBCNT=IBCNT+2

 +26       SET IB=0

FOR

               SET IB=$ORDER(^IBE(354.6,IBLET,1,IB))

               IF IB=""

                   QUIT

               SET X=$GET(^(IB,0))

               WRITE !,X

               SET IBCNT=IBCNT+1

 +27       IF $EXTRACT(IOST,1,2)="C-"

               DO PAUSE^IBOUTL

               IF IBQUIT

                   QUIT

 +28       IF $EXTRACT(IOST,1,2)'="C-"

               WRITE @IOF

 +29       QUIT

 +30      ;

FINAL     ; -- Print last page

 +1        WRITE @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"

 +2        WRITE !!,?20,$GET(IBCNTL)," LETTERS PRINTED"

 +3        QUIT

IBARXEPL.m