source: FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSACREDO.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSACREDO ;BIR/JMB-Outstanding Credits ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,16**; 10/24/97
3 ;This routine prints detailed or summary outstanding credits report.
4 ;
5 ;References to ^PSDRUG( are covered by DBIA #2095
6 ;PSA*3*16 (DAVE B) Changed PSADJQ=0 to PSADJQ=""
7 ;
8 I '$D(^XUSEC("PSA ORDERS",DUZ)) W !,"You do not hold the key to enter the option." Q
9 I '$O(^PSD(58.811,"AC",1,0)) W !!,"There are no outstanding credit memos." Q
10 S DIR(0)="S^D:Detailed Report;S:Summary Report",DIR("A")="Print a detailed or summary report",DIR("??")="^D RPT^PSACREDO" D ^DIR K DIR I $G(DIRUT) G EXIT
11 S PSARPT=Y W:PSARPT="D" !!,"The report must be sent to a 132 column printer."
12DEVICE W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
13 ;I PSARPT="D",$E(IOST,1,2)="C-" W !!,"The report must be sent to a 132 column printer." G DEVICE
14 I $D(IO("Q")) D G EXIT
15 .S ZTDESC="Drug Acct. - Print Outstanding Credits",ZTRTN="DQ^PSACREDO"
16 .S ZTSAVE("PSARPT")="" D ^%ZTLOAD
17DQ S PSASLN="",$P(PSASLN,"-",80)="",PSALSLN="",$P(PSALSLN,"-",132)=""
18 S (PSAGDF,PSA,PSAOUT,PSAPG)=0
19 F S PSA=+$O(^PSD(58.811,"AC",1,PSA)) Q:'PSA D Q:PSAOUT
20 .Q:'$D(^PSD(58.811,PSA,0))
21 .S PSAORD=$P(^PSD(58.811,PSA,0),"^"),(PSA1,PSAOECST,PSAODF)=0
22 .F S PSA1=+$O(^PSD(58.811,"AC",1,PSA,PSA1)) Q:'PSA1 D Q:PSAOUT
23 ..Q:'$D(^PSD(58.811,PSA,1,PSA1,0))
24 ..S PSAINV=$P(^PSD(58.811,PSA,1,PSA1,0),"^"),(PSACRED,PSAAECST,PSAIECST)=0
25 ..S PSA2=0 F S PSA2=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2)) Q:'PSA2!(PSAOUT) D Q:PSAOUT
26 ...Q:'$D(^PSD(58.811,PSA,1,PSA1,1,PSA2,0))
27 ...S PSADATA=^PSD(58.811,PSA,1,PSA1,1,PSA2,0)
28 ...D LINE
29 ..D CREDITS S PSAODF=PSAODF+$G(PSADF),PSAOECST=PSAOECST+PSAAECST
30 .S PSA(PSAORD)=$J(PSAOECST,$L($P(PSAOECST,".")),2)_"^"_$J(PSAODF,$L($P(PSAODF,".")),2)
31 .S PSAGDF=PSAGDF+PSAODF
32 ;
33 S PSAORD="" F S PSAORD=$O(PSA(PSAORD)) Q:PSAORD="" S PSAINV="" F S PSAINV=$O(^PSD(58.811,"AORD",PSAORD,PSAINV)) Q:PSAINV="" D
34 .Q:$D(PSA(PSAORD,PSAINV)) S (PSA,PSAAECST,PSAIECST)=0
35 .F S PSA=$O(^PSD(58.811,"AORD",PSAORD,PSAINV,PSA)) Q:'PSA S PSA1=0 F S PSA1=$O(^PSD(58.811,"AORD",PSAORD,PSAINV,PSA,PSA1)) Q:'PSA1 D
36 ..D GETLINE
37 ..I 'PSAAECST&(+PSAIECST) S $P(PSA(PSAORD),"^")=+$P(PSA(PSAORD),"^")+PSAIECST,$P(PSA(PSAORD),"^")=$J($P(PSA(PSAORD),"^"),$L($P($P(PSA(PSAORD),"^"),".")),2)
38 ..I PSAAECST S $P(PSA(PSAORD),"^")=+$P(PSA(PSAORD),"^")+PSAAECST,$P(PSA(PSAORD),"^")=$J($P(PSA(PSAORD),"^"),$L($P($P(PSA(PSAORD),"^"),".")),2)
39 D PRINT
40 ;
41EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
42 K %ZIS,DIR,DIRUT,PSA,PSA1,PSA2,PSAACST,PSAAECST,PSAAVAL,PSAC,PSACRED,PSADATA,PSADF,PSADJ,PSADJD,PSADJP,PSADJQ,PSADRG,PSADT,PSAFLD,PSAGDF,PSAICST
43 K PSAIDF,PSAIECST,PSAINV,PSAINVDT,PSAIVAL,PSAKK,PSALN,PSALSLN,PSAN,PSAODF,PSAOECST,PSAORD,PSAOUT,PSAPFLD,PSAPG,PSAPRC,PSAPRT,PSAQFLD,PSAREA,PSARPDT,PSARPT,PSASLN,PSASS,Y,ZTDESC,ZTRTN,ZTSAVE
44 Q
45 ;
46LINE ;Get line item data
47 S PSARPDT=$E($$HTFM^XLFDT($H),1,12),PSADT=$P(PSARPDT,".")
48 S PSARPDT=$E(PSADT,4,5)_"/"_$E(PSADT,6,7)_"/"_$E(PSADT,2,3)_"@"_$P(PSARPDT,".",2)
49 S (PSADJQ,PSADJP,PSADJD,PSAPFLD,PSAQFLD,PSAREA)="",(PSADRG,PSAACST,PSAICST)=0
50 S PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","D",0))
51 I $G(PSADJ) D
52 .S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0))
53 .S PSADJD=$S($P(PSAN,"^",6)'="":$P(PSAN,"^",6),1:$P(PSAN,"^",2)),PSADRG=PSADJD
54 .Q:$G(PSADJD)&($L(PSADJD)=+$L(PSADJD))
55 E S PSADRG=$P(PSADATA,"^",2)
56 S PSAICST=$P(PSADATA,"^",3)*$P(PSADATA,"^",5),PSAIECST=PSAIECST+PSAICST
57 S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","P",0))
58 I $G(PSADJ) D
59 .S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0)),PSAPRC=$S($P(PSAN,"^",6)'="":$P(PSAN,"^",6),1:+$P(PSAN,"^",2)),PSADJP=PSAPRC
60 .S PSAPFLD="P"
61 I '$G(PSADJ) S PSAPRC=$P(PSADATA,"^",5)
62 S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","Q",0))
63 I $G(PSADJ) D
64 .S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0))
65 .S PSADJQ=$S($P(PSAN,"^",6)'="":+$P(PSAN,"^",6),1:+$P(PSAN,"^",2))
66 .S PSAREA=$S($P(PSAN,"^",7)'="":$P(PSAN,"^",7),1:$P(PSAN,"^",3)),PSAQFLD="Q"
67 I $G(PSADJQ) S PSAACST=PSADJQ*PSAPRC,PSAAECST=PSAAECST+PSAACST
68 I '$G(PSADJQ) S PSAACST=$P(PSADATA,"^",3)*PSAPRC,PSAAECST=PSAAECST+PSAACST
69 I PSAICST'=PSAACST D
70 .S PSALN=$P(PSADATA,"^")
71 .S PSADRG=$S(+PSADRG&($P($G(^PSDRUG(PSADRG,0)),"^")'=""):$P(^PSDRUG(PSADRG,0),"^"),'PSADRG:PSADRG,1:"UNKNOWN DRUG")
72 .I PSAPFLD="P" S PSA(PSAORD,PSAINV,PSALN,PSAPFLD)=PSADRG_"^^"_$J($P(PSADATA,"^",5),$L($P(PSADATA,"^",5)),2)_"^"_$J(PSADJP,$L(PSADJP),2)
73 .I PSAQFLD="Q" S PSA(PSAORD,PSAINV,PSALN,PSAQFLD)=PSADRG_"^"_$S(PSAREA'="":PSAREA,1:"UNK")_"^"_$P(PSADATA,"^",3)_"^"_PSADJQ
74 Q
75 ;
76GETLINE ;Gets invoice cost from line items
77 S PSA2=0 F S PSA2=$O(^PSD(58.811,PSA,1,PSA1,1,PSA2)) Q:'PSA2 D
78 .Q:'$D(^PSD(58.811,PSA,1,PSA1,1,PSA2,0))
79 .S PSADATA=^PSD(58.811,PSA,1,PSA1,1,PSA2,0),PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5))
80 .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","P",0))
81 .I +PSADJ S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0)),PSAPRC=$S($P(PSAN,"^",6)'="":$P(PSAN,"^",6),1:+$P(PSAN,"^",2)),PSADJP=PSAPRC
82 .S:'+PSADJ PSAPRC=$P(PSADATA,"^",5)
83 .;
84 .S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","Q",0))
85 .S:+PSADJ PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0)),PSADJQ=$S($P(PSAN,"^",6)'="":+$P(PSAN,"^",6),1:+$P(PSAN,"^",2))
86 .S:$G(PSADJQ)'="" PSAAECST=PSAAECST+(PSADJQ*PSAPRC)
87 .S:$G(PSADJQ)="" PSAAECST=PSAAECST+($P(PSADATA,"^",3)*PSAPRC)
88 Q
89 ;
90CREDITS ;Adds existing credits to adjusted extended cost.
91 S PSAC=0 F S PSAC=$O(^PSD(58.811,PSA,1,PSA1,2,PSAC)) Q:'PSAC D
92 .Q:'$D(^PSD(58.811,PSA,1,PSA1,2,PSAC,0))
93 .S PSACRED=PSACRED+$P(^PSD(58.811,PSA,1,PSA1,2,PSAC,0),"^",3)
94 I PSAAECST'=PSAIECST D
95 .S PSADF=PSAIECST-(PSAAECST+PSACRED)
96 .S PSA(PSAORD,PSAINV)=$J(PSAIECST,$L(PSAIECST),2)_"^"_$J(PSAAECST,$L($P(PSAAECST,".")),2)_"^"_$J(PSACRED,$L(PSACRED),2)_"^"_$J(PSADF,$L(PSADF),2)_"^"_+$P($G(^PSD(58.811,PSA,1,PSA1,0)),"^",2)
97 Q
98 ;
99PRINT ;Displays the invoices with outstanding credits
100 D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET
101 S PSAORD="" F S PSAORD=$O(PSA(PSAORD)) Q:PSAORD=""!(PSAOUT) D
102 .S PSAODF=$P(PSA(PSAORD),"^",2)
103 .I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
104 .W:PSARPT="S" ! W:PSARPT="D" !,PSALSLN W !,"ORDER#: "_PSAORD_" ($"_$P(PSA(PSAORD),"^")_")"
105 .S PSAINV="" F S PSAINV=$O(PSA(PSAORD,PSAINV)) Q:PSAINV="" D
106 ..S PSAIECST=$P(PSA(PSAORD,PSAINV),"^"),PSAAECST=$P(PSA(PSAORD,PSAINV),"^",2),PSACRED=$P(PSA(PSAORD,PSAINV),"^",3),PSAIDF=$P(PSA(PSAORD,PSAINV),"^",4)
107 ..S PSAINVDT=$P(PSA(PSAORD,PSAINV),"^",5),PSAINVDT=$E(PSAINVDT,4,5)_"/"_$E(PSAINVDT,6,7)_"/"_$E(PSAINVDT,2,3)
108 ..S PSAPRT=0,PSALN="" F S PSALN=$O(PSA(PSAORD,PSAINV,PSALN)) Q:PSALN="" D
109 ...S PSAFLD="" F S PSAFLD=$O(PSA(PSAORD,PSAINV,PSALN,PSAFLD)) Q:PSAFLD="" D
110 ....S PSADATA=PSA(PSAORD,PSAINV,PSALN,PSAFLD),PSADRG=$P(PSADATA,"^"),PSAREA=$P(PSADATA,"^",2),PSAIVAL=$P(PSADATA,"^",3),PSAAVAL=$P(PSADATA,"^",4),PSAPRT=PSAPRT+1
111 ....I PSARPT="D",$Y+5>IOSL D HDRDET Q:PSAOUT
112 ....I PSARPT="D" D:PSAPRT=1 PRTDLINE D:PSAPRT>1 PRTDLIN1
113 ..I PSARPT="S",$Y+5>IOSL D HDRSUM Q:PSAOUT
114 ..D:PSARPT="S" PRTSLINE
115 .I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
116 .I PSAODF'=PSADF W !,"ORDER TOTAL" W:PSARPT="D" ?65 W:PSARPT="S" ?69 W $J(PSAODF,9,2)
117 I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
118 W ! W:PSARPT="S" PSASLN W:PSARPT="D" PSALSLN
119 W !,"GRAND TOTAL" W:PSARPT="D" ?65 W:PSARPT="S" ?69 W $J(PSAGDF,9,2),!
120 I $E(IOST,1,2)="C-" D END^PSAPROC
121 E W @IOF
122 Q
123 ;
124HDRDET ;Header for detail report
125 I $E(IOST,1,2)="C-" W:'PSAPG @IOF D:+PSAPG END^PSAPROC Q:PSAOUT
126 I $E(IOST)'="C",+PSAPG W @IOF
127 S PSAPG=PSAPG+1
128 W ! W:$E(IOST)'="C" "RUN DATE: "_PSARPDT
129 W ?46,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
130 W !?53,"OUTSTANDING CREDITS REPORT",!?124,"PAGE "_PSAPG
131 W !!?36,"INVOICE",?46,"ADJUSTED",?58,"RECEIVED",?68,"OUTST.",?84,"DRUG &"
132 W !,"INVOICE#",?28,"DATE",?39,"COST",?50,"COST",?59,"CREDITS",?68,"CREDIT",?77,"LINE#",?84,"ADJUSTMENT REASON",?117,"INVOICE",?129,"ADJ",!
133 W:PSAPG'=1 PSALSLN
134 Q
135 ;
136PRTDLINE ;Prints a line of data on the detailed report
137 W !,PSAINV,?26,PSAINVDT,?30,$J(PSAIECST,9,2),?45,$J(PSAAECST,9,2),?57,$J(PSACRED,9,2),?67,$J(PSAIDF,7,2),?74,$J(PSALN,8,0),?84,$E(PSADRG,1,33),?117,$J(PSAIVAL,7),?125,$J(PSAAVAL,7)
138 W !?84,$S(PSAFLD="P":"ORDER UNIT PRICE CHANGED ",PSAFLD="Q":"QTY: "_PSAREA,1:"")
139 Q
140 ;
141PRTDLIN1 ;Prints a line of data on the detailed report
142 W !?74,$J(PSALN,8,0),?84,PSADRG,?117,$J(PSAIVAL,7),?125,$J(PSAAVAL,7)
143 W !?84,$S(PSAFLD="P":"ORDER UNIT PRICE CHANGED ",PSAFLD="Q":"QTY: "_PSAREA,1:"")
144 Q
145 ;
146HDRSUM ;Header for summary report
147 I $E(IOST,1,2)="C-" W:'PSAPG @IOF D:+PSAPG END^PSAPROC Q:PSAOUT
148 I $E(IOST)'="C",+PSAPG W @IOF
149 S PSAPG=PSAPG+1
150 W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
151 W !?27,"OUTSTANDING CREDITS REPORT",!?72,"PAGE "_PSAPG
152 W ! W:$E(IOST)'="C" "RUN DATE: "_PSARPDT
153 W !?36,"INVOICE",?46,"ADJUSTED",?58,"RECEIVED",?72,"OUTST."
154 W !,"INVOICE#",?28,"DATE",?39,"COST",?50,"COST",?59,"CREDITS",?72,"CREDIT",!,PSASLN
155 Q
156 ;
157PRTSLINE ;Prints a line of data on the summary report
158 W !,PSAINV,?26,PSAINVDT,?30,$J(PSAIECST,9,2),?45,$J(PSAAECST,9,2),?57,$J(PSACRED,9,2),?71,$J(PSAIDF,7,2)
159 Q
160 ;
161RPT ;Extended help for "Print a detailed or summary report"
162 W !?5,"Select DETAILED to print the order number, invoice number, invoice date,",!?5,"total invoice cost, adjusted cost, received credits, and Derence."
163 W !!?5,"Select SUMMARY to print all of the data on the detailed report plus the",!?5,"line item data that created the need for a credit. The line item data is"
164 W !?5,"the line item number, drug name, quantity invoiced, quantity received,",!?5,"reason for credit."
165 Q
Note: See TracBrowser for help on using the repository browser.