91 lines
5.3 KiB
Mathematica
91 lines
5.3 KiB
Mathematica
|
PSACREDR ;BIR/JMB-Credit Resolution ;7/23/97
|
||
|
|
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,64**; 10/24/97;Build 4
|
||
|
|
;This routine allows the user to apply credit memos to invoices.
|
||
|
|
;
|
||
|
|
I '$D(^XUSEC("PSA ORDERS",DUZ)) W !,"You do not hold the key to enter the option." Q
|
||
|
|
I '$D(^XUSEC("PSAMGR",DUZ)) W !,"You do not hold the key to enter the option." Q
|
||
|
|
I '$O(^PSD(58.811,"AC",1,0)) W !!,"There are no outstanding credit memos." Q
|
||
|
|
S PSASLN="",$P(PSASLN,"-",80)=""
|
||
|
|
START W ! S DIC="^PSD(58.811,",DIC(0)="AEQM",DIC("S")="I $D(^PSD(58.811,""AC"",1,+Y))" D ^DIC K DIE G:Y<0 EXIT
|
||
|
|
G:'$D(^PSD(58.811,+Y,0)) START
|
||
|
|
S PSAIEN=+Y,(PSAIEN1,PSAOUT)=0
|
||
|
|
F S PSAIEN1=$O(^PSD(58.811,"AC",1,PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
|
||
|
|
.Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
|
||
|
|
.S (PSACRED,PSAAECST,PSAIECST)=0
|
||
|
|
.S PSAIEN2=0 F S PSAIEN2=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2)) Q:'PSAIEN2!(PSAOUT) D LINE Q:PSAOUT
|
||
|
|
.D CREDITS
|
||
|
|
D LIST
|
||
|
|
G:PSAOUT EXIT G START
|
||
|
|
;
|
||
|
|
EXIT ;Kills printing variables only
|
||
|
|
K DA,DIC,DIE,DIR,DIRUT,DR,PSA,PSAAECST,PSACIEN,PSACNT,PSACRED,PSADATA,PSADIF,PSADJ,PSADJD,PSADJDA,PSADJP,PSADJQ,PSADJSUP
|
||
|
|
K PSAIECST,PSAIEN,PSAIEN1,PSAIEN2,PSAINV,PSALEN,PSAMENU,PSANODE,PSAOUT,PSAPC,PSAPRICE,PSASEL,PSASLN,Y
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
LINE ;Get line item data
|
||
|
|
Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0))
|
||
|
|
K PSADJQ,PSADJP,PSADJD
|
||
|
|
S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0),PSADJSUP=0
|
||
|
|
;Next line added 4dec97 to bypass checking drug name change
|
||
|
|
G DAVE
|
||
|
|
DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","D",0))
|
||
|
|
I $G(PSADJ) D Q:'PSADJSUP
|
||
|
|
.S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0))
|
||
|
|
.S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
|
||
|
|
.Q:$G(PSADJD)&($L(PSADJD)=+$L(PSADJD))
|
||
|
|
.S PSADJSUP=1
|
||
|
|
DAVE S PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5))
|
||
|
|
PRICE S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","P",0))
|
||
|
|
I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0)),PSAPRICE=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
|
||
|
|
I '+PSADJ S PSAPRICE=$P(PSADATA,"^",5)
|
||
|
|
QTY S PSADJQ=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","Q",0))
|
||
|
|
I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
|
||
|
|
I $G(PSADJQ) S PSAAECST=PSAAECST+(PSADJQ*PSAPRICE)
|
||
|
|
I '$G(PSADJQ) S PSAAECST=PSAAECST+($P(PSADATA,"^",3)*PSAPRICE)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CREDITS ;Adds existing credits to adjusted extended cost.
|
||
|
|
S PSACIEN=0 F S PSACIEN=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN)) Q:'PSACIEN D
|
||
|
|
.Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0))
|
||
|
|
.S PSACRED=PSACRED+$P(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0),"^",3)
|
||
|
|
S:PSAAECST'=PSAIECST PSA(PSAIEN1)=PSAIECST_"^"_$J(PSAAECST,$L($P(PSAAECST,".")),2)_"^"_PSACRED
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
LIST ;Displays the invoices with outstanding credits
|
||
|
|
W @IOF,!,"Order#: "_$P($G(^PSD(58.811,PSAIEN,0)),"^")
|
||
|
|
W !?28,"Invoice",?42,"Adjusted",?56,"Received",!?4,"Invoice#",?31,"Cost",?46,"Cost",?57,"Credits",?69,"Difference",!,PSASLN
|
||
|
|
S (PSACNT,PSAIEN1)=0 F S PSAIEN1=+$O(PSA(PSAIEN1)) Q:'PSAIEN1 D
|
||
|
|
.S PSAIECST=+$P(PSA(PSAIEN1),"^"),PSAAECST=+$P(PSA(PSAIEN1),"^",2),PSACRED=+$P(PSA(PSAIEN1),"^",3)
|
||
|
|
.S PSACNT=PSACNT+1,PSAMENU(PSACNT,PSAIEN1)=PSA(PSAIEN1)
|
||
|
|
.W !,($J(PSACNT,2)),".",?4,$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)),"^"),?26,$J(PSAIECST,9,2),?41,$J(PSAAECST,9,2)
|
||
|
|
.W ?55,$J(PSACRED,9,2)
|
||
|
|
.S PSADIF=PSAIECST-(PSAAECST+PSACRED)
|
||
|
|
.W ?70,$J(PSADIF,9,2)
|
||
|
|
I PSACNT'>0 W !!!,?10,"NO INVOICES ON THIS ORDER # FOR CREDITING PURPOSES",! Q ;Dave Blocker 3Dec97
|
||
|
|
W ! K DIR S DIR(0)="LO^1:"_PSACNT,DIR("A")="Select invoices",DIR("?")="Select the invoices to which you want to apply credit memos.",DIR("??")="^D CREDHELP^PSACREDR"
|
||
|
|
D ^DIR K DIR Q:Y="" I $G(DIRUT) S PSAOUT=1 Q
|
||
|
|
S PSASEL=Y
|
||
|
|
;
|
||
|
|
SELECT ;Selects invoices for credit memos
|
||
|
|
F PSAPC=1:1 S PSACNT=+$P(PSASEL,",",PSAPC) Q:'PSACNT D Q:PSAOUT
|
||
|
|
.S PSAINV=$O(PSAMENU(PSACNT,0)),PSAIECST=$P(PSAMENU(PSACNT,PSAINV),"^"),PSAAECST=$P(PSAMENU(PSACNT,PSAINV),"^",2),PSACRED=$P(PSAMENU(PSACNT,PSAINV),"^",3)
|
||
|
|
.W !!,"Invoice: "_$P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"),!
|
||
|
|
.S DA(2)=PSAIEN,DA(1)=PSAINV,DA=PSAIEN2
|
||
|
|
.S:'$D(^PSD(58.811,PSAIEN,1,PSAINV,2,0)) DIC("P")=$P(^DD(58.8112,6,0),"^",2)
|
||
|
|
.S DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",2,",DIC(0)="AEMQL",DIC("A")="CREDIT MEMO: ",DR=.01,DLAYGO=58.811
|
||
|
|
.F L +^PSD(58.811,PSAIEN,1,PSAINV,2,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
|
||
|
|
.D ^DIC K DLAYGO I Y<0 S PSAOUT=1 K DIC Q
|
||
|
|
.S DIE=DIC,DR="1;2;3",(PSADJDA,DA)=+Y D ^DIE K DA,DIE,DIC L -^PSD(58.811,PSAIEN,1,PSAINV,2,0)
|
||
|
|
.S PSACRED=PSACRED+$P($G(^PSD(58.811,PSAIEN,1,PSAINV,2,PSADJDA,0)),"^",3)
|
||
|
|
.I PSAIECST=$J((PSAAECST+PSACRED),2) S DA(1)=PSAIEN,DA=PSAINV,DIE="^PSD(58.811,"_DA(1)_",1,",DR="10////0" D ^DIE K DIE
|
||
|
|
.W !!,"Invoice: "_$P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^") S PSALEN=$L($P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"))+11
|
||
|
|
.W ?PSALEN,"Total Invoiced Cost: "_$J(PSAIECST,9,2),!?PSALEN,"Total Adjusted Cost: "_$J(PSAAECST,9,2)
|
||
|
|
.W !?PSALEN,"Total Credits : "_$J(PSACRED,9,2)
|
||
|
|
.W !?PSALEN,"Difference : "_$J((PSAIECST-(PSAAECST+PSACRED)),9,2),!
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
CREDHELP ;Extended help to 'Select invoices'
|
||
|
|
W !?5,"Enter the numbers to the left of the invoices for which you want to",!?5,"enter credit memos. To select more than one invoice number, enter"
|
||
|
|
W !?5,"the numbers to the left of the invoices separated by a comma or a dash.",!!?5,"For example: Enter 1,2,3,5 or 1-3,5"
|
||
|
|
Q
|