IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
;;2.0;INTEGRATED BILLING;**34,54,190,206,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, 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 I $D(ZTQUEUED) Q
D ^%ZISC,KVAR^VADPT
K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
K IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
K BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST",$J)
Q
;
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!",!
Q
;
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=""
Q
;
SCR ; -- don't send letters to deceased patients, non-vets, vfa exempt
; 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
Q
;
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
Q
;
ONE ; -- print one letter
N IBCONF ; Confidential Address Flag
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 !?TAB 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),$E($P(IBDATA,"^")),$P($P(IBDATA,"^",2),"-",3),!
S IBCNT=IBCNT+2
; don't print renewal date if they are VFA OK
S IBX=$$RXST^IBARXEU(DFN,DT) I $P($G(^IBE(354.6,IBLET,0)),"^",3)'=2,$P(IBX,"^",3)=120 S Y=$$PLUS^IBARXEU0($P(IBX,"^",5)) I '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$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
S IBCONF=$$CONFADD^IBARXEL() ; Should we use Confidential Address?
W !?TAB,VAPA($S(IBCONF:13,1:1)) S IBCNT=IBCNT+1
I VAPA($S(IBCONF:14,1:2))'="" W !?TAB,VAPA($S(IBCONF:14,1:2)) I VAPA($S(IBCONF:15,1:3))'="" W ", ",VAPA($S(IBCONF:15,1:3)) S IBCNT=IBCNT+1
W !?TAB,VAPA($S(IBCONF:16,1:4)),", ",$P($G(^DIC(5,+VAPA($S(IBCONF:17,1:5)),0)),"^",2)," ",$S(IBCONF:$P(VAPA(18),"^",2),1: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
K ^UTILITY($J,"W"),DIWR,DIWL,DIWF,DN S DIWL=1,DIWF="C80WN"
S IB=0 F S IB=$O(^IBE(354.6,IBLET,1,IB)) Q:IB="" S X=$G(^(IB,0)) D ^DIWP S IBCNT=IBCNT+1 ; W !,X
D ^DIWW K ^UTILITY($J,"W")
I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
W:$E(IOST,1,2)'="C-" @IOF
Q
;
FINAL ; -- Print last page
W @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
W !!,?20,$G(IBCNTL)," LETTERS PRINTED"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPL 4930 printed Apr 09, 2024@21:25:32 Page 2
IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
+1 ;;2.0;INTEGRATED BILLING;**34,54,190,206,385**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, 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 ;
END IF $DATA(ZTQUEUED)
QUIT
+1 DO ^%ZISC
DO KVAR^VADPT
+2 KILL C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
+3 KILL IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
+4 KILL BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^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, vfa exempt
+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 ; Confidential Address Flag
NEW IBCONF
+2 SET TAB=5
+3 IF '$DATA(IOF)
DO HOME^%ZIS
+4 SET IBCNTL=$GET(IBCNTL)+1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 SET IB=0
+6 ;
+7 ; -- print header
+8 SET IBCNT=0
+9 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
+10 WRITE !?TAB
SET Y=DT
DO DT^DIQ
SET IBCNT=IBCNT+1
+11 FOR IBCNT=IBCNT:1:6
WRITE !
SET IBCNT=IBCNT+1
+12 WRITE !?(IOM-28),"In Reply Refer To:"
SET IBCNT=IBCNT+1
+13 WRITE !?(IOM-28),$EXTRACT($PIECE(IBDATA,"^")),$PIECE($PIECE(IBDATA,"^",2),"-",3),!
+14 SET IBCNT=IBCNT+2
+15 ; don't print renewal date if they are VFA OK
+16 SET IBX=$$RXST^IBARXEU(DFN,DT)
IF $PIECE($GET(^IBE(354.6,IBLET,0)),"^",3)'=2
IF $PIECE(IBX,"^",3)=120
SET Y=$$PLUS^IBARXEU0($PIECE(IBX,"^",5))
IF '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$PIECE(IBX,"^",5)))
WRITE ?(IOM-28),"Renewal Date: "
DO DT^DIQ
+17 ;
+18 ; -- print pt. name and address
+19 FOR IBCNT=IBCNT:1:(IBALIN-1)
WRITE !
+20 WRITE !?TAB,$PIECE(IBNAM,",",2)," ",$PIECE(IBNAM,",")
DO ADD^VADPT
SET IBCNT=IBCNT+1
+21 ; Should we use Confidential Address?
SET IBCONF=$$CONFADD^IBARXEL()
+22 WRITE !?TAB,VAPA($SELECT(IBCONF:13,1:1))
SET IBCNT=IBCNT+1
+23 IF VAPA($SELECT(IBCONF:14,1:2))'=""
WRITE !?TAB,VAPA($SELECT(IBCONF:14,1:2))
IF VAPA($SELECT(IBCONF:15,1:3))'=""
WRITE ", ",VAPA($SELECT(IBCONF:15,1:3))
SET IBCNT=IBCNT+1
+24 WRITE !?TAB,VAPA($SELECT(IBCONF:16,1:4)),", ",$PIECE($GET(^DIC(5,+VAPA($SELECT(IBCONF:17,1:5)),0)),"^",2)," ",$SELECT(IBCONF:$PIECE(VAPA(18),"^",2),1:VAPA(6))
SET IBCNT=IBCNT+1
+25 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^IBOUTL
if IBQUIT
QUIT
+26 ;
+27 ; -- print main body
+28 WRITE !!
SET IBCNT=IBCNT+2
+29 KILL ^UTILITY($JOB,"W"),DIWR,DIWL,DIWF,DN
SET DIWL=1
SET DIWF="C80WN"
+30 ; W !,X
SET IB=0
FOR
SET IB=$ORDER(^IBE(354.6,IBLET,1,IB))
if IB=""
QUIT
SET X=$GET(^(IB,0))
DO ^DIWP
SET IBCNT=IBCNT+1
+31 DO ^DIWW
KILL ^UTILITY($JOB,"W")
+32 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^IBOUTL
if IBQUIT
QUIT
+33 if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+34 QUIT
+35 ;
FINAL ; -- Print last page
+1 WRITE @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
+2 WRITE !!,?20,$GET(IBCNTL)," LETTERS PRINTED"
+3 QUIT
