PSDREPD ;BIR/BJW-Invoice Review by Date Range ; 12 Feb 98
;;3.0; CONTROLLED SUBSTANCES ;**6,8,69**;13 Feb 97;Build 13
;chgs made for drug acct 8 Oct 97
;**Y2K compliance**,"P" added to date input string
;References to ^PRC(442 are covered by DBIA#682
;References to ^PSD(58.8, covered by DBIA2711
;References to ^PSD(58.81 are covered by DBIA2808
;References to ^PSDRUG( are covered by DBIA221
;
I '$D(PSDSITE) W ! D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ)),'$D(^XUSEC("PSD TECH ADV",DUZ)) D Q
.W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to print",!,?12,"the Invoice Review Report. Either the PSJ RPHARM or PSD TECH ADV",!?12,"security key required.",!
S PSDS=0 F S PSDS=$O(^PSD(58.8,"ADISP","M",PSDS)) Q:'PSDS I $P($G(^PSD(58.8,+PSDS,0)),"^",3)=+PSDSITE&('$G(^PSD(58.8,+PSDS,"I"))!($G(^PSD(58.8,+PSDS,"I"))>DT)) S PSDC=$G(PSDC)+1,PSDONE=PSDS
I '$G(PSDC) W !!,"Sorry, no Master Vaults set up for this site.",!! G END
S:PSDC=1 PSDS=PSDONE
I PSDC>1 D G:Y<1 END S PSDS=+Y W !
.S DIC="^PSD(58.8,",DIC(0)="AEQ",DIC("A")="Select Dispensing Site: "
.S:$P($G(^PSD(58.8,+$P(PSDSITE,"^",3),0)),"^",2)["M" DIC("B")=$P(PSDSITE,"^",4)
.S DIC("S")="I $P($G(^(0)),U,3)=+PSDSITE,$P($G(^(0)),U,2)[""M"",$S('$G(^(""I"")):1,+^(""I"")>DT:1,1:0)"
.W ! D ^DIC K DIC S $P(PSDSITE,"^",3)=+Y,$P(PSDSITE,"^",4)=$P(Y,"^",2)
W !,"Select Invoice Date Range",!
DATE ;ask date range
K %DT S %DT="AEP",%DT("A")="Start with Date: " D ^%DT I Y<0 S PSDOUT=1 G END
S PSDSD=Y D D^DIQ S PSDATE=Y,%DT("A")="End with Date: " W ! D ^%DT I Y<0 S PSDOUT=1 G END
I Y<PSDSD W !!,"The ending date of the range must be later than the starting date." G DATE
S PSDED=Y D D^DIQ S PSDATE=PSDATE_"^"_Y,PSDSD=PSDSD-.0001,PSDED=PSDED+.9999
SUM ;if summary only
W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you want to print the invoice numbers only",DIR("B")="NO"
S DIR("?",1)="Answer 'YES' to print only the invoice numbers for this report,",DIR("?")="answer 'NO' to print the detailed report including drug totals."
D ^DIR K DIR G:$D(DIRUT) END S PSDSUM=Y
D NOW^%DTC S PSDT=X,Y=% X ^DD("DD") S PSDT(1)=Y
DEV ;asks device and queueing information
W !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!
S Y=$P($G(^PSD(58.8,+$P(PSDSITE,"^",3),2)),"^",9),C=$P(^DD(58.8,24,0),"^",2) D Y^DIQ S PSDEV=Y
K %ZIS,IOP,IO("Q") S %ZIS="QM",%ZIS("B")=PSDEV D ^%ZIS
I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" S PSDOUT=1 G END
I $D(IO("Q")) D G END
.K IO("Q") S ZTIO=ION,ZTRTN="START^PSDREPD",ZTDESC="CS Invoice Report data"
.S ZTSAVE("PSDSUM")="",ZTSAVE("PSDSITE")="",ZTSAVE("PSD*")=""
.D ^%ZTLOAD,HOME^%ZIS K ZTSK S PSDOUT=1
U IO
START S (PSDPG,PSDOUT)=0,PSDSD(1)=PSDSD,$P(PSDSLN,"-",81)="" D HDR G:PSDOUT END
F S PSDSD=$O(^PSD(58.81,"AF",PSDSD)) Q:PSDSD>PSDED!('PSDSD)!(PSDOUT) S PSDTR=0 F S PSDTR=$O(^PSD(58.81,"AF",PSDSD,PSDS,1,PSDTR)) Q:'PSDTR!(PSDOUT) D
.S PSD0=$G(^PSD(58.81,+PSDTR,0)),PSDINV=$P($G(^PSD(58.81,+PSDTR,8)),"^")
.S PSDORD=$S(+$P(PSD0,"^",9)&($P($G(^PRC(442,+$P(PSD0,"^",9),0)),"^")'=""):$P($G(^PRC(442,+$P(PSD0,"^",9),0)),"^"),$P($G(^PSD(58.81,+PSDTR,8)),"^",2)'="":$P($G(^PSD(58.81,+PSDTR,8)),"^",2),1:"UNKNOWN")
.Q:PSDINV="" S:'$D(^TMP("PSD",$J,PSDINV,PSDORD)) ^TMP("PSD",$J,PSDINV,PSDORD)=0
;
I PSDSUM S PSDINV="" D G END
.F S PSDINV=$O(^TMP("PSD",$J,PSDINV)) Q:PSDINV=""!(PSDOUT) S PSDFND=0,PSDORD="" D
..F S PSDORD=$O(^TMP("PSD",$J,PSDINV,PSDORD)) Q:PSDORD=""!(PSDOUT) D
...S PSDTR=0 F S PSDTR=+$O(^PSD(58.81,"PV",PSDINV,PSDTR)) Q:'PSDTR S PSD0=$G(^PSD(58.81,PSDTR,0)) D:$P(PSD0,"^",4)>PSDSD(1)&($P(PSD0,"^",4)'>PSDED) Q:PSDOUT!(PSDFND)
....Q:PSDORD'=$P($G(^PRC(442,+$P(PSD0,"^",9),0)),"^")&(PSDORD'=$P($G(^PSD(58.81,PSDTR,8)),"^",2))
....Q:'+$P($G(^PSD(58.81,PSDTR,"CS")),"^")
....D:$Y+5>IOSL HEADER Q:PSDOUT S PSDDT=$P(PSD0,"^",4)
....W !!,$$FMTE^XLFDT(PSDDT,"1P"),?26,PSDINV,?38,PSDORD,?54
....W $E($P($G(^VA(200,+$P(PSD0,"^",7),0)),"^"),1,26) S PSDFND=1
;
S PSDINV="" F S PSDINV=$O(^TMP("PSD",$J,PSDINV)) Q:PSDINV=""!(PSDOUT) S PSDORD="" D
.F S PSDORD=$O(^TMP("PSD",$J,PSDINV,PSDORD)) Q:PSDORD=""!(PSDOUT) D
..S PSDFIRST=2,PSDTR=0 F S PSDTR=+$O(^PSD(58.81,"PV",PSDINV,PSDTR)) Q:'PSDTR S PSD0=$G(^PSD(58.81,PSDTR,0)) D:$P(PSD0,"^",4)>PSDSD(1)&($P(PSD0,"^",4)'>PSDED) Q:PSDOUT
...Q:PSDORD'=$P($G(^PRC(442,+$P(PSD0,"^",9),0)),"^")&(PSDORD'=$P($G(^PSD(58.81,PSDTR,8)),"^",2))
...Q:'+$P($G(^PSD(58.81,PSDTR,"CS")),"^")
...I $Y+5>IOSL D HEADER Q:PSDOUT
...I PSDFIRST=2 W !!,"Invoice Number ==> ",PSDINV," Order Number ==> ",PSDORD S PSDFIRST=0
...I PSDFIRST=1 W !!,"Invoice Number ==> ",PSDINV," Order Number ==> ",PSDORD W " (Continued)" S PSDFIRST=0
...W !!,$E($P($G(^PSDRUG(+$P(PSD0,"^",5),0)),"^"),1,30),?32
...W $J($P(PSD0,"^",6),8),?41
...W $P($G(^PSDRUG(+$P(PSD0,"^",5),660)),"^",8),?50
...W $E($P($G(^VA(200,+$P(PSD0,"^",7),0)),"^"),1,18),?72
...W $$FMTE^XLFDT($P(PSD0,"^",4),"2D")
;
END W:$E(IOST)'="C" @IOF
I $E(IOST)="C",'$G(PSDOUT) D
.S PSDSS=21-$Y F PSDKK=1:1:PSDSS W !
.S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR K DIR S:$G(DIRUT) PSDOUT=1 W @IOF
K %,%DT,%H,%I,%ZIS,C,DA,DIR,DIRUT,DUOUT,DTOUT,IO("Q"),POP,PSD0,PSDATE,PSDC,PSDDT,PSDED,PSDEV,PSDFIRST,PSDFND
K PSDINV,PSDKK,PSDLOC,PSDONE,PSDORD,PSDOUT,PSDPG,PSDS,PSDSD,PSDSLN,PSDSS,PSDSUM,PSDT,PSDTR,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,^TMP("PSD",$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
I $E(IOST,1,2)'="P-",PSDPG S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),"^"),"." S PSDOUT=1
HDR W:$Y @IOF S PSDPG=PSDPG+1
W !?2,$E($S($P($G(^VA(200,+$G(DUZ),.1)),"^",4)]"":$P($G(^(.1)),"^",4),1:$P($P($G(^VA(200,+$G(DUZ),0)),"^"),",",2)),1,20),"'s Invoice Review From "
W $P(PSDATE,"^")," To ",$P(PSDATE,"^",2),?72,"Page ",PSDPG,!?2,$P($G(^PSD(58.8,PSDS,0)),"^"),!
W ?45,"Report Date: ",PSDT(1)
I PSDSUM W !!,"Date",?26,"Invoice#",?38,"Order#",?50,"Received By",!,PSDSLN Q
W !!?5,"Drug",?34,"Quantity Received By Date",!,PSDSLN
S:PSDPG PSDFIRST=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDREPD 6240 printed Apr 09, 2024@20:51:56 Page 2
PSDREPD ;BIR/BJW-Invoice Review by Date Range ; 12 Feb 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**6,8,69**;13 Feb 97;Build 13
+2 ;chgs made for drug acct 8 Oct 97
+3 ;**Y2K compliance**,"P" added to date input string
+4 ;References to ^PRC(442 are covered by DBIA#682
+5 ;References to ^PSD(58.8, covered by DBIA2711
+6 ;References to ^PSD(58.81 are covered by DBIA2808
+7 ;References to ^PSDRUG( are covered by DBIA221
+8 ;
+9 IF '$DATA(PSDSITE)
WRITE !
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+10 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
IF '$DATA(^XUSEC("PSD TECH ADV",DUZ))
Begin DoDot:1
+11 WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to print",!,?12,"the Invoice Review Report. Either the PSJ RPHARM or PSD TECH ADV",!?12,"security key required.",!
End DoDot:1
QUIT
+12 SET PSDS=0
FOR
SET PSDS=$ORDER(^PSD(58.8,"ADISP","M",PSDS))
if 'PSDS
QUIT
IF $PIECE($GET(^PSD(58.8,+PSDS,0)),"^",3)=+PSDSITE&('$GET(^PSD(58.8,+PSDS,"I"))!($GET(^PSD(58.8,+PSDS,"I"))>DT))
SET PSDC=$GET(PSDC)+1
SET PSDONE=PSDS
+13 IF '$GET(PSDC)
WRITE !!,"Sorry, no Master Vaults set up for this site.",!!
GOTO END
+14 if PSDC=1
SET PSDS=PSDONE
+15 IF PSDC>1
Begin DoDot:1
+16 SET DIC="^PSD(58.8,"
SET DIC(0)="AEQ"
SET DIC("A")="Select Dispensing Site: "
+17 if $PIECE($GET(^PSD(58.8,+$PIECE(PSDSITE,"^",3),0)),"^",2)["M"
SET DIC("B")=$PIECE(PSDSITE,"^",4)
+18 SET DIC("S")="I $P($G(^(0)),U,3)=+PSDSITE,$P($G(^(0)),U,2)[""M"",$S('$G(^(""I"")):1,+^(""I"")>DT:1,1:0)"
+19 WRITE !
DO ^DIC
KILL DIC
SET $PIECE(PSDSITE,"^",3)=+Y
SET $PIECE(PSDSITE,"^",4)=$PIECE(Y,"^",2)
End DoDot:1
if Y<1
GOTO END
SET PSDS=+Y
WRITE !
+20 WRITE !,"Select Invoice Date Range",!
DATE ;ask date range
+1 KILL %DT
SET %DT="AEP"
SET %DT("A")="Start with Date: "
DO ^%DT
IF Y<0
SET PSDOUT=1
GOTO END
+2 SET PSDSD=Y
DO D^DIQ
SET PSDATE=Y
SET %DT("A")="End with Date: "
WRITE !
DO ^%DT
IF Y<0
SET PSDOUT=1
GOTO END
+3 IF Y<PSDSD
WRITE !!,"The ending date of the range must be later than the starting date."
GOTO DATE
+4 SET PSDED=Y
DO D^DIQ
SET PSDATE=PSDATE_"^"_Y
SET PSDSD=PSDSD-.0001
SET PSDED=PSDED+.9999
SUM ;if summary only
+1 WRITE !
KILL DA,DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Do you want to print the invoice numbers only"
SET DIR("B")="NO"
+2 SET DIR("?",1)="Answer 'YES' to print only the invoice numbers for this report,"
SET DIR("?")="answer 'NO' to print the detailed report including drug totals."
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET PSDSUM=Y
+4 DO NOW^%DTC
SET PSDT=X
SET Y=%
XECUTE ^DD("DD")
SET PSDT(1)=Y
DEV ;asks device and queueing information
+1 WRITE !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!
+2 SET Y=$PIECE($GET(^PSD(58.8,+$PIECE(PSDSITE,"^",3),2)),"^",9)
SET C=$PIECE(^DD(58.8,24,0),"^",2)
DO Y^DIQ
SET PSDEV=Y
+3 KILL %ZIS,IOP,IO("Q")
SET %ZIS="QM"
SET %ZIS("B")=PSDEV
DO ^%ZIS
+4 IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
SET PSDOUT=1
GOTO END
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 KILL IO("Q")
SET ZTIO=ION
SET ZTRTN="START^PSDREPD"
SET ZTDESC="CS Invoice Report data"
+7 SET ZTSAVE("PSDSUM")=""
SET ZTSAVE("PSDSITE")=""
SET ZTSAVE("PSD*")=""
+8 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
SET PSDOUT=1
End DoDot:1
GOTO END
+9 USE IO
START SET (PSDPG,PSDOUT)=0
SET PSDSD(1)=PSDSD
SET $PIECE(PSDSLN,"-",81)=""
DO HDR
if PSDOUT
GOTO END
+1 FOR
SET PSDSD=$ORDER(^PSD(58.81,"AF",PSDSD))
if PSDSD>PSDED!('PSDSD)!(PSDOUT)
QUIT
SET PSDTR=0
FOR
SET PSDTR=$ORDER(^PSD(58.81,"AF",PSDSD,PSDS,1,PSDTR))
if 'PSDTR!(PSDOUT)
QUIT
Begin DoDot:1
+2 SET PSD0=$GET(^PSD(58.81,+PSDTR,0))
SET PSDINV=$PIECE($GET(^PSD(58.81,+PSDTR,8)),"^")
+3 SET PSDORD=$SELECT(+$PIECE(PSD0,"^",9)&($PIECE($GET(^PRC(442,+$PIECE(PSD0,"^",9),0)),"^")'=""):$PIECE($GET(^PRC(442,+$PIECE(PSD0,"^",9),0)),"^"),$PIECE($GET(^PSD(58.81,+PSDTR,8)),"^",2)'="":$PIECE($GET(^PSD(58.81,+PSDTR,8)),"^",2),1
:"UNKNOWN")
+4 if PSDINV=""
QUIT
if '$DATA(^TMP("PSD",$JOB,PSDINV,PSDORD))
SET ^TMP("PSD",$JOB,PSDINV,PSDORD)=0
End DoDot:1
+5 ;
+6 IF PSDSUM
SET PSDINV=""
Begin DoDot:1
+7 FOR
SET PSDINV=$ORDER(^TMP("PSD",$JOB,PSDINV))
if PSDINV=""!(PSDOUT)
QUIT
SET PSDFND=0
SET PSDORD=""
Begin DoDot:2
+8 FOR
SET PSDORD=$ORDER(^TMP("PSD",$JOB,PSDINV,PSDORD))
if PSDORD=""!(PSDOUT)
QUIT
Begin DoDot:3
+9 SET PSDTR=0
FOR
SET PSDTR=+$ORDER(^PSD(58.81,"PV",PSDINV,PSDTR))
if 'PSDTR
QUIT
SET PSD0=$GET(^PSD(58.81,PSDTR,0))
if $PIECE(PSD0,"^",4)>PSDSD(1)&($PIECE(PSD0,"^",4)'>PSDED)
Begin DoDot:4
+10 if PSDORD'=$PIECE($GET(^PRC(442,+$PIECE(PSD0,"^",9),0)),"^")&(PSDORD'=$PIECE($GET(^PSD(58.81,PSDTR,8)),"^",2))
QUIT
+11 if '+$PIECE($GET(^PSD(58.81,PSDTR,"CS")),"^")
QUIT
+12 if $Y+5>IOSL
DO HEADER
if PSDOUT
QUIT
SET PSDDT=$PIECE(PSD0,"^",4)
+13 WRITE !!,$$FMTE^XLFDT(PSDDT,"1P"),?26,PSDINV,?38,PSDORD,?54
+14 WRITE $EXTRACT($PIECE($GET(^VA(200,+$PIECE(PSD0,"^",7),0)),"^"),1,26)
SET PSDFND=1
End DoDot:4
if PSDOUT!(PSDFND)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
GOTO END
+15 ;
+16 SET PSDINV=""
FOR
SET PSDINV=$ORDER(^TMP("PSD",$JOB,PSDINV))
if PSDINV=""!(PSDOUT)
QUIT
SET PSDORD=""
Begin DoDot:1
+17 FOR
SET PSDORD=$ORDER(^TMP("PSD",$JOB,PSDINV,PSDORD))
if PSDORD=""!(PSDOUT)
QUIT
Begin DoDot:2
+18 SET PSDFIRST=2
SET PSDTR=0
FOR
SET PSDTR=+$ORDER(^PSD(58.81,"PV",PSDINV,PSDTR))
if 'PSDTR
QUIT
SET PSD0=$GET(^PSD(58.81,PSDTR,0))
if $PIECE(PSD0,"^",4)>PSDSD(1)&($PIECE(PSD0,"^",4)'>PSDED)
Begin DoDot:3
+19 if PSDORD'=$PIECE($GET(^PRC(442,+$PIECE(PSD0,"^",9),0)),"^")&(PSDORD'=$PIECE($GET(^PSD(58.81,PSDTR,8)),"^",2))
QUIT
+20 if '+$PIECE($GET(^PSD(58.81,PSDTR,"CS")),"^")
QUIT
+21 IF $Y+5>IOSL
DO HEADER
if PSDOUT
QUIT
+22 IF PSDFIRST=2
WRITE !!,"Invoice Number ==> ",PSDINV," Order Number ==> ",PSDORD
SET PSDFIRST=0
+23 IF PSDFIRST=1
WRITE !!,"Invoice Number ==> ",PSDINV," Order Number ==> ",PSDORD
WRITE " (Continued)"
SET PSDFIRST=0
+24 WRITE !!,$EXTRACT($PIECE($GET(^PSDRUG(+$PIECE(PSD0,"^",5),0)),"^"),1,30),?32
+25 WRITE $JUSTIFY($PIECE(PSD0,"^",6),8),?41
+26 WRITE $PIECE($GET(^PSDRUG(+$PIECE(PSD0,"^",5),660)),"^",8),?50
+27 WRITE $EXTRACT($PIECE($GET(^VA(200,+$PIECE(PSD0,"^",7),0)),"^"),1,18),?72
+28 WRITE $$FMTE^XLFDT($PIECE(PSD0,"^",4),"2D")
End DoDot:3
if PSDOUT
QUIT
End DoDot:2
End DoDot:1
+29 ;
END if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
IF '$GET(PSDOUT)
Begin DoDot:1
+2 SET PSDSS=21-$Y
FOR PSDKK=1:1:PSDSS
WRITE !
+3 SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
KILL DIR
if $GET(DIRUT)
SET PSDOUT=1
WRITE @IOF
End DoDot:1
+4 KILL %,%DT,%H,%I,%ZIS,C,DA,DIR,DIRUT,DUOUT,DTOUT,IO("Q"),POP,PSD0,PSDATE,PSDC,PSDDT,PSDED,PSDEV,PSDFIRST,PSDFND
+5 KILL PSDINV,PSDKK,PSDLOC,PSDONE,PSDORD,PSDOUT,PSDPG,PSDS,PSDSD,PSDSLN,PSDSS,PSDSUM,PSDT,PSDTR,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,^TMP("PSD",$JOB)
+6 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+1 IF $EXTRACT(IOST,1,2)'="P-"
IF PSDPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 IF $$S^%ZTLOAD
WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),"^"),"."
SET PSDOUT=1
HDR if $Y
WRITE @IOF
SET PSDPG=PSDPG+1
+1 WRITE !?2,$EXTRACT($SELECT($PIECE($GET(^VA(200,+$GET(DUZ),.1)),"^",4)]"":$PIECE($GET(^(.1)),"^",4),1:$PIECE($PIECE($GET(^VA(200,+$GET(DUZ),0)),"^"),",",2)),1,20),"'s Invoice Review From "
+2 WRITE $PIECE(PSDATE,"^")," To ",$PIECE(PSDATE,"^",2),?72,"Page ",PSDPG,!?2,$PIECE($GET(^PSD(58.8,PSDS,0)),"^"),!
+3 WRITE ?45,"Report Date: ",PSDT(1)
+4 IF PSDSUM
WRITE !!,"Date",?26,"Invoice#",?38,"Order#",?50,"Received By",!,PSDSLN
QUIT
+5 WRITE !!?5,"Drug",?34,"Quantity Received By Date",!,PSDSLN
+6 if PSDPG
SET PSDFIRST=1
+7 QUIT
