Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSACREDO

PSACREDO.m

Go to the documentation of this file. 
  1. PSACREDO ;BIR/JMB-Outstanding Credits ;7/23/97
  1.  ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,16**; 10/24/97
  1.  ;This routine prints detailed or summary outstanding credits report.
  1.  ;
  1.  ;References to ^PSDRUG( are covered by DBIA #2095
  1.  ;PSA*3*16 (DAVE B) Changed PSADJQ=0 to PSADJQ=""
  1.  ;
  1.  I '$D(^XUSEC("PSA ORDERS",DUZ)) W !,"You do not hold the key to enter the option." Q
  1.  I '$O(^PSD(58.811,"AC",1,0)) W !!,"There are no outstanding credit memos." Q
  1.  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
  1.  S PSARPT=Y W:PSARPT="D" !!,"The report must be sent to a 132 column printer."
  1. DEVICE W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
  1.  ;I PSARPT="D",$E(IOST,1,2)="C-" W !!,"The report must be sent to a 132 column printer." G DEVICE
  1.  I $D(IO("Q")) D  G EXIT
  1.  .S ZTDESC="Drug Acct. - Print Outstanding Credits",ZTRTN="DQ^PSACREDO"
  1.  .S ZTSAVE("PSARPT")="" D ^%ZTLOAD
  1. DQ S PSASLN="",$P(PSASLN,"-",80)="",PSALSLN="",$P(PSALSLN,"-",132)=""
  1.  S (PSAGDF,PSA,PSAOUT,PSAPG)=0
  1.  F  S PSA=+$O(^PSD(58.811,"AC",1,PSA)) Q:'PSA  D  Q:PSAOUT
  1.  .Q:'$D(^PSD(58.811,PSA,0))
  1.  .S PSAORD=$P(^PSD(58.811,PSA,0),"^"),(PSA1,PSAOECST,PSAODF)=0
  1.  .F  S PSA1=+$O(^PSD(58.811,"AC",1,PSA,PSA1)) Q:'PSA1  D  Q:PSAOUT
  1.  ..Q:'$D(^PSD(58.811,PSA,1,PSA1,0))
  1.  ..S PSAINV=$P(^PSD(58.811,PSA,1,PSA1,0),"^"),(PSACRED,PSAAECST,PSAIECST)=0
  1.  ..S PSA2=0 F  S PSA2=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2)) Q:'PSA2!(PSAOUT)  D  Q:PSAOUT
  1.  ...Q:'$D(^PSD(58.811,PSA,1,PSA1,1,PSA2,0))
  1.  ...S PSADATA=^PSD(58.811,PSA,1,PSA1,1,PSA2,0)
  1.  ...D LINE
  1.  ..D CREDITS S PSAODF=PSAODF+$G(PSADF),PSAOECST=PSAOECST+PSAAECST
  1.  .S PSA(PSAORD)=$J(PSAOECST,$L($P(PSAOECST,".")),2)_"^"_$J(PSAODF,$L($P(PSAODF,".")),2)
  1.  .S PSAGDF=PSAGDF+PSAODF
  1.  ;
  1.  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
  1.  .Q:$D(PSA(PSAORD,PSAINV))  S (PSA,PSAAECST,PSAIECST)=0
  1.  .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
  1.  ..D GETLINE
  1.  ..I 'PSAAECST&(+PSAIECST) S $P(PSA(PSAORD),"^")=+$P(PSA(PSAORD),"^")+PSAIECST,$P(PSA(PSAORD),"^")=$J($P(PSA(PSAORD),"^"),$L($P($P(PSA(PSAORD),"^"),".")),2)
  1.  ..I PSAAECST S $P(PSA(PSAORD),"^")=+$P(PSA(PSAORD),"^")+PSAAECST,$P(PSA(PSAORD),"^")=$J($P(PSA(PSAORD),"^"),$L($P($P(PSA(PSAORD),"^"),".")),2)
  1.  D PRINT
  1.  ;
  1. EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
  1.  K %ZIS,DIR,DIRUT,PSA,PSA1,PSA2,PSAACST,PSAAECST,PSAAVAL,PSAC,PSACRED,PSADATA,PSADF,PSADJ,PSADJD,PSADJP,PSADJQ,PSADRG,PSADT,PSAFLD,PSAGDF,PSAICST
  1.  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
  1.  Q
  1.  ;
  1. LINE ;Get line item data
  1.  S PSARPDT=$E($$HTFM^XLFDT($H),1,12),PSADT=$P(PSARPDT,".")
  1.  S PSARPDT=$E(PSADT,4,5)_"/"_$E(PSADT,6,7)_"/"_$E(PSADT,2,3)_"@"_$P(PSARPDT,".",2)
  1.  S (PSADJQ,PSADJP,PSADJD,PSAPFLD,PSAQFLD,PSAREA)="",(PSADRG,PSAACST,PSAICST)=0
  1.  S PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","D",0))
  1.  I $G(PSADJ) D
  1.  .S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0))
  1.  .S PSADJD=$S($P(PSAN,"^",6)'="":$P(PSAN,"^",6),1:$P(PSAN,"^",2)),PSADRG=PSADJD
  1.  .Q:$G(PSADJD)&($L(PSADJD)=+$L(PSADJD))
  1.  E  S PSADRG=$P(PSADATA,"^",2)
  1.  S PSAICST=$P(PSADATA,"^",3)*$P(PSADATA,"^",5),PSAIECST=PSAIECST+PSAICST
  1.  S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","P",0))
  1.  I $G(PSADJ) D
  1.  .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
  1.  .S PSAPFLD="P"
  1.  I '$G(PSADJ) S PSAPRC=$P(PSADATA,"^",5)
  1.  S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","Q",0))
  1.  I $G(PSADJ) D
  1.  .S PSAN=$G(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,PSADJ,0))
  1.  .S PSADJQ=$S($P(PSAN,"^",6)'="":+$P(PSAN,"^",6),1:+$P(PSAN,"^",2))
  1.  .S PSAREA=$S($P(PSAN,"^",7)'="":$P(PSAN,"^",7),1:$P(PSAN,"^",3)),PSAQFLD="Q"
  1.  I $G(PSADJQ) S PSAACST=PSADJQ*PSAPRC,PSAAECST=PSAAECST+PSAACST
  1.  I '$G(PSADJQ) S PSAACST=$P(PSADATA,"^",3)*PSAPRC,PSAAECST=PSAAECST+PSAACST
  1.  I PSAICST'=PSAACST D
  1.  .S PSALN=$P(PSADATA,"^")
  1.  .S PSADRG=$S(+PSADRG&($P($G(^PSDRUG(PSADRG,0)),"^")'=""):$P(^PSDRUG(PSADRG,0),"^"),'PSADRG:PSADRG,1:"UNKNOWN DRUG")
  1.  .I PSAPFLD="P" S PSA(PSAORD,PSAINV,PSALN,PSAPFLD)=PSADRG_"^^"_$J($P(PSADATA,"^",5),$L($P(PSADATA,"^",5)),2)_"^"_$J(PSADJP,$L(PSADJP),2)
  1.  .I PSAQFLD="Q" S PSA(PSAORD,PSAINV,PSALN,PSAQFLD)=PSADRG_"^"_$S(PSAREA'="":PSAREA,1:"UNK")_"^"_$P(PSADATA,"^",3)_"^"_PSADJQ
  1.  Q
  1.  ;
  1. GETLINE ;Gets invoice cost from line items
  1.  S PSA2=0 F  S PSA2=$O(^PSD(58.811,PSA,1,PSA1,1,PSA2)) Q:'PSA2  D
  1.  .Q:'$D(^PSD(58.811,PSA,1,PSA1,1,PSA2,0))
  1.  .S PSADATA=^PSD(58.811,PSA,1,PSA1,1,PSA2,0),PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5))
  1.  .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","P",0))
  1.  .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
  1.  .S:'+PSADJ PSAPRC=$P(PSADATA,"^",5)
  1.  .;
  1.  .S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSA,1,PSA1,1,PSA2,1,"B","Q",0))
  1.  .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))
  1.  .S:$G(PSADJQ)'="" PSAAECST=PSAAECST+(PSADJQ*PSAPRC)
  1.  .S:$G(PSADJQ)="" PSAAECST=PSAAECST+($P(PSADATA,"^",3)*PSAPRC)
  1.  Q
  1.  ;
  1. CREDITS ;Adds existing credits to adjusted extended cost.
  1.  S PSAC=0 F  S PSAC=$O(^PSD(58.811,PSA,1,PSA1,2,PSAC)) Q:'PSAC  D
  1.  .Q:'$D(^PSD(58.811,PSA,1,PSA1,2,PSAC,0))
  1.  .S PSACRED=PSACRED+$P(^PSD(58.811,PSA,1,PSA1,2,PSAC,0),"^",3)
  1.  I PSAAECST'=PSAIECST D
  1.  .S PSADF=PSAIECST-(PSAAECST+PSACRED)
  1.  .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)
  1.  Q
  1.  ;
  1. PRINT ;Displays the invoices with outstanding credits
  1.  D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET
  1.  S PSAORD="" F  S PSAORD=$O(PSA(PSAORD)) Q:PSAORD=""!(PSAOUT)  D
  1.  .S PSAODF=$P(PSA(PSAORD),"^",2)
  1.  .I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
  1.  .W:PSARPT="S" ! W:PSARPT="D" !,PSALSLN W !,"ORDER#: "_PSAORD_" ($"_$P(PSA(PSAORD),"^")_")"
  1.  .S PSAINV="" F  S PSAINV=$O(PSA(PSAORD,PSAINV)) Q:PSAINV=""  D
  1.  ..S PSAIECST=$P(PSA(PSAORD,PSAINV),"^"),PSAAECST=$P(PSA(PSAORD,PSAINV),"^",2),PSACRED=$P(PSA(PSAORD,PSAINV),"^",3),PSAIDF=$P(PSA(PSAORD,PSAINV),"^",4)
  1.  ..S PSAINVDT=$P(PSA(PSAORD,PSAINV),"^",5),PSAINVDT=$E(PSAINVDT,4,5)_"/"_$E(PSAINVDT,6,7)_"/"_$E(PSAINVDT,2,3)
  1.  ..S PSAPRT=0,PSALN="" F  S PSALN=$O(PSA(PSAORD,PSAINV,PSALN)) Q:PSALN=""  D
  1.  ...S PSAFLD="" F  S PSAFLD=$O(PSA(PSAORD,PSAINV,PSALN,PSAFLD)) Q:PSAFLD=""  D
  1.  ....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
  1.  ....I PSARPT="D",$Y+5>IOSL D HDRDET Q:PSAOUT
  1.  ....I PSARPT="D" D:PSAPRT=1 PRTDLINE D:PSAPRT>1 PRTDLIN1
  1.  ..I PSARPT="S",$Y+5>IOSL D HDRSUM Q:PSAOUT
  1.  ..D:PSARPT="S" PRTSLINE
  1.  .I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
  1.  .I PSAODF'=PSADF W !,"ORDER TOTAL" W:PSARPT="D" ?65 W:PSARPT="S" ?69 W $J(PSAODF,9,2)
  1.  I $Y+4>IOSL D:PSARPT="S" HDRSUM D:PSARPT="D" HDRDET Q:PSAOUT
  1.  W ! W:PSARPT="S" PSASLN W:PSARPT="D" PSALSLN
  1.  W !,"GRAND TOTAL" W:PSARPT="D" ?65 W:PSARPT="S" ?69 W $J(PSAGDF,9,2),!
  1.  I $E(IOST,1,2)="C-" D END^PSAPROC
  1.  E  W @IOF
  1.  Q
  1.  ;
  1. HDRDET ;Header for detail report
  1.  I $E(IOST,1,2)="C-" W:'PSAPG @IOF D:+PSAPG END^PSAPROC Q:PSAOUT
  1.  I $E(IOST)'="C",+PSAPG W @IOF
  1.  S PSAPG=PSAPG+1
  1.  W ! W:$E(IOST)'="C" "RUN DATE: "_PSARPDT
  1.  W ?46,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
  1.  W !?53,"OUTSTANDING CREDITS REPORT",!?124,"PAGE "_PSAPG
  1.  W !!?36,"INVOICE",?46,"ADJUSTED",?58,"RECEIVED",?68,"OUTST.",?84,"DRUG &"
  1.  W !,"INVOICE#",?28,"DATE",?39,"COST",?50,"COST",?59,"CREDITS",?68,"CREDIT",?77,"LINE#",?84,"ADJUSTMENT REASON",?117,"INVOICE",?129,"ADJ",!
  1.  W:PSAPG'=1 PSALSLN
  1.  Q
  1.  ;
  1. PRTDLINE ;Prints a line of data on the detailed report
  1.  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)
  1.  W !?84,$S(PSAFLD="P":"ORDER UNIT PRICE CHANGED ",PSAFLD="Q":"QTY: "_PSAREA,1:"")
  1.  Q
  1.  ;
  1. PRTDLIN1 ;Prints a line of data on the detailed report
  1.  W !?74,$J(PSALN,8,0),?84,PSADRG,?117,$J(PSAIVAL,7),?125,$J(PSAAVAL,7)
  1.  W !?84,$S(PSAFLD="P":"ORDER UNIT PRICE CHANGED ",PSAFLD="Q":"QTY: "_PSAREA,1:"")
  1.  Q
  1.  ;
  1. HDRSUM ;Header for summary report
  1.  I $E(IOST,1,2)="C-" W:'PSAPG @IOF D:+PSAPG END^PSAPROC Q:PSAOUT
  1.  I $E(IOST)'="C",+PSAPG W @IOF
  1.  S PSAPG=PSAPG+1
  1.  W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
  1.  W !?27,"OUTSTANDING CREDITS REPORT",!?72,"PAGE "_PSAPG
  1.  W ! W:$E(IOST)'="C" "RUN DATE: "_PSARPDT
  1.  W !?36,"INVOICE",?46,"ADJUSTED",?58,"RECEIVED",?72,"OUTST."
  1.  W !,"INVOICE#",?28,"DATE",?39,"COST",?50,"COST",?59,"CREDITS",?72,"CREDIT",!,PSASLN
  1.  Q
  1.  ;
  1. PRTSLINE ;Prints a line of data on the summary report
  1.  W !,PSAINV,?26,PSAINVDT,?30,$J(PSAIECST,9,2),?45,$J(PSAAECST,9,2),?57,$J(PSACRED,9,2),?71,$J(PSAIDF,7,2)
  1.  Q
  1.  ;
  1. RPT ;Extended help for "Print a detailed or summary report"
  1.  W !?5,"Select DETAILED to print the order number, invoice number, invoice date,",!?5,"total invoice cost, adjusted cost, received credits, and Derence."
  1.  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"
  1.  W !?5,"the line item number, drug name, quantity invoiced, quantity received,",!?5,"reason for credit."
  1.  Q