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

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

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
2 ;;2.0;INTEGRATED BILLING;**34,54,190,206**;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 I '$D(IOF) D HOME^%ZIS
7 W @IOF,"Print Exemption letters to patients"
8 K ^TMP("IBEX LIST",$J)
9 S (IBTEMP,IBADDT,IBOK,IBQUIT)=""
10 ;
11 ; -- find template
12 S IBTEMP=$O(^DIBT("B","IB EXEMPTION LETTER",0))
13 ;
14 ; -- use old template or build new one
15 W !!!
16 ;
17 I IBTEMP D G:IBQUIT END
18 .S DIR(0)="Y",DIR("A")="Delete Results of Previous Search",DIR("B")="NO"
19 .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)."
20 .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
21 .I Y=1 D DELT S IBTEMP=0
22 .Q
23 ;
24 I 'IBTEMP D G:IBQUIT END D:IBADD ADDT
25 .S DIR(0)="Y",DIR("A")="Store results of Search in Template",DIR("B")="YES"
26 .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."
27 .S DIR("?",1)="Creating the search template will allow you to",DIR("?",2)="print other lists from the patients you sent the letters to."
28 .S DIR("?",3)=" "
29 .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 Q
30 .S IBADD=Y
31 .Q
32 ;
33 D PRINT
34 ;
35END I $D(ZTQUEUED) Q
36 D ^%ZISC,KVAR^VADPT
37 K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
38 K IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
39 K BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST",$J)
40 Q
41 ;
42ADDT ; -- create new template in ^dibt
43 K DD,DO
44 S DIC="^DIBT(",DIC(0)="L",X="IB EXEMPTION LETTER",DIC("DR")="2///NOW;4///354;7///NOW"
45 D FILE^DICN S IBTEMP=+Y I +Y S IBADDT=1 W !!,"<<< Search Template IB EXEMPTION LETTER created!",!
46 Q
47 ;
48DELT ; -- delete search template
49 Q:$P($G(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"
50 S DIK="^DIBT(",DA=IBTEMP D ^DIK K DIK,DA
51 W !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!
52 S IBTEMP=""
53 Q
54 ;
55SCR ; -- don't send letters to deceased patients, non-vets
56 ; called by print template IB DO NOT USE
57 S IBOK=0 N IBX
58 I +$G(^DPT(D0,.35)) G SCRQ ; deceased
59 I $P($G(^DPT(D0,"VET")),"^")="N" G SCRQ ; patient non-vet
60 S IBX=$P($G(^IBE(354.2,+$P($G(^IBA(354,D0,0)),"^",5),0)),"^",5)
61 I IBX=60 G SCRQ ;exemption is non-vet
62 I IBX=10 G SCRQ ;sc>50
63 S IBOK=1
64SCRQ Q
65 ;
66PRINT ; -- run through list of letters to PRINT
67 S X="IB NOW EXEMPT",DIC(0)="XZ",DIC="^IBE(354.6," D ^DIC S IBLET=+Y
68 Q:IBLET<1
69 ;
70 S DIC="^IBA(354,",L=0,FLDS="[IB DO NOT USE]",BY="[IB EXEMPT PATIENTS]",(FR,TO)="?,?,?",DHD="@@"
71 S DIOEND="D LET^IBARXEPL"
72 D EN1^DIP
73 Q
74 ;
75LET ; -- called by dioend, prints list from tmp array
76 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
77 I IBALIN<10!(IBALIN>25) S IBALIN=15
78 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
79 D FINAL,END
80 Q
81 ;
82ONE ; -- print one letter
83 N IBCONF ; Confidential Address Flag
84 S TAB=5
85 I '$D(IOF) D HOME^%ZIS
86 S IBCNTL=$G(IBCNTL)+1 I $E(IOST,1,2)="C-" W @IOF
87 S IB=0
88 ;
89 ; -- print header
90 S IBCNT=0
91 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
92 W !?TAB S Y=DT D DT^DIQ S IBCNT=IBCNT+1
93 F IBCNT=IBCNT:1:6 W ! S IBCNT=IBCNT+1
94 W !?(IOM-28),"In Reply Refer To:" S IBCNT=IBCNT+1
95 W !?(IOM-28),$E($P(IBDATA,"^")),$P($P(IBDATA,"^",2),"-",3),!
96 S IBCNT=IBCNT+2
97 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)) W ?(IOM-28),"Renewal Date: " D DT^DIQ
98 ;
99 ; -- print pt. name and address
100 F IBCNT=IBCNT:1:(IBALIN-1) W !
101 W !?TAB,$P(IBNAM,",",2)," ",$P(IBNAM,",") D ADD^VADPT S IBCNT=IBCNT+1
102 S IBCONF=$$CONFADD^IBARXEL() ; Should we use Confidential Address?
103 W !?TAB,VAPA($S(IBCONF:13,1:1)) S IBCNT=IBCNT+1
104 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
105 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
106 I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
107 ;
108 ; -- print main body
109 W !! S IBCNT=IBCNT+2
110 K ^UTILITY($J,"W"),DIWR,DIWL,DIWF,DN S DIWL=1,DIWF="C80WN"
111 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
112 D ^DIWW K ^UTILITY($J,"W")
113 I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
114 W:$E(IOST,1,2)'="C-" @IOF
115 Q
116 ;
117FINAL ; -- Print last page
118 W @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
119 W !!,?20,$G(IBCNTL)," LETTERS PRINTED"
120 Q
Note: See TracBrowser for help on using the repository browser.