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