PSDCOSN ;BIR/LTL-Cost Report by NAOUs, PSDCOST (cont'd) ; 2 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;**63**;13 Feb 97;Build 1
N PSDN,LN,PG,X2 S PSDSD(1)=PSDSD S:$D(ZTQUEUED) ZTREQ="@"
F S PSDSD=$O(^PSD(58.81,"ACT",PSDSD)) W:$E(IOST)="C" "." Q:'PSDSD!(PSDSD>PSDED) S PSDN=$O(^PSD(58.81,"ACT",PSDSD,0)) D:$P($G(^PSD(58.8,+PSDN,0)),U,3)=+PSDSITE
.S PSDN(1)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,0))
.S PSDN(2)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),0))
.Q:PSDN(2)<2!(PSDN(2)>5)&(PSDN(2)'=9)
.S PSDN(3)=$P($G(^PSDRUG(+PSDN(1),0)),U)
.S PSDN(4)=$O(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),PSDN(2),0))
.S PSDN(8)=$G(^PSD(58.81,+PSDN(4),0))
.Q:'$D(LOC(+$P(PSDN(8),U,18)))&(PSDN(2)'=9)!('$D(LOC(+PSDN))&(PSDN(2)=9))
.;get NAOU for everything including adjustments
.S PSDN(9)=$S(PSDN(2)=9:PSDN,1:$P(PSDN(8),U,18))
.;qty rec'd by NAOU w/green sheet
.S PSDN(5)=$P($G(^PSD(58.81,+PSDN(4),1)),U,8)
.S PSDN(11)=$P($G(^PSDRUG(PSDN(1),660)),U,6)
.I $D(PSDN) I 'PSDN(11) D GETDTA
.;qty dispensed by Master Vault w/o green sheet
.S:$P(PSDN(8),U,17)']"" PSDN(5)=$P(PSDN(8),U,6)
.;Returned to Stock
.S:PSDN(2)=3 PSDN(5)=-$P($G(^PSD(58.81,+PSDN(4),3)),U,2)
.;Destroyed
.S:PSDN(2)=4 PSDN(5)=-$P($G(^PSD(58.81,+PSDN(4),3)),U,5)
.;include transfer ins with dispensed
.S:PSDN(2)=5 PSDN(2)=2
.;Check for transfers
.S PSDN(6)=$G(^PSD(58.81,+PSDN(4),7))
.D:$P(PSDN(6),U)>PSDSD(1)&($P(PSDN(6),U)<PSDED)
..S PSDN(5)=PSDN(5)-$P(PSDN(6),U,7),PSDN(2)=5
.S PSDN(7)=$G(^TMP("PSD",$J,PSDN(9),PSDN(3)))
.;total dispensed
.S $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U)=$P(PSDN(7),U)+PSDN(5)
.;DA for drug
.S:'$P(PSDN(7),U,2) $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U,2)=PSDN(1)
.;total returned to stock
.S:PSDN(2)=3 $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U,3)=PSDN(5)+$P(PSDN(7),U,3)
.;total destroyed
.S:PSDN(2)=4 $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U,4)=PSDN(5)+$P(PSDN(7),U,4)
.;total transferred
.S:PSDN(2)=5 $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U,5)=-$P(PSDN(6),U,7)+$P(PSDN(7),U,5)
.;total adjusted by NAOU
.S:PSDN(2)=9 $P(^TMP("PSD",$J,PSDN(9),PSDN(3)),U,6)=PSDN(5)+$P(PSDN(7),U,6)
.K PSDN
;
PRTQUE ;queues print after data is compiled
I $D(ZTQUEUED) K ZTSAVE,ZTSK S ZTIO=PSDIO,ZTDESC="CS Cost Report by NAOU",ZTRTN="START^PSDCOSN",ZTSAVE("PSD*")="",ZTSAVE("^TMP(""PSD"",$J,")="",ZTSAVE("SUM")="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS G QUIT
START S (PG,PSDN)=0 D HEADER
F S PSDN=$O(^TMP("PSD",$J,PSDN)) Q:'PSDN D:$Y+6>IOSL HEADER G:$G(PSDOUT) END S PSDN(8)=$G(PSDN(8))+1 K PG(PSDN) D G:$G(PSDOUT) END
.W ?8,"NAOU ==> ",$P($G(^PSD(58.8,+PSDN,0)),U),!! S PSDN(1)=0
.F S PSDN(1)=$O(^TMP("PSD",$J,PSDN,PSDN(1))) Q:PSDN(1)']"" D:$Y+6>IOSL HEADER Q:$G(PSDOUT) S PSDN(9)=$G(PSDN(9))+1 D
..I $D(PG(PSDN)) W ?8,"NAOU ==> ",$P($G(^PSD(58.8,+PSDN,0)),U)," (continued)",!! K PG(PSDN)
..W:'$G(SUM) $E(PSDN(1),1,34),?36
..S PSDN(2)=$G(^TMP("PSD",$J,PSDN,PSDN(1))),PSDN(3)=$G(PSDN(3))+PSDN(2)
..W:'$G(SUM) $J($P(PSDN(2),U),10),?62
..S PSDN(11)=$P($G(^PSDRUG(+$P(PSDN(2),U,2),660)),U,6)
..S (X,PSDN(4))=$P(PSDN(2),U)*PSDN(11),X2="2$",PSDN(5)=$G(PSDN(5))+PSDN(4) D COMMA^%DTC W:'$G(SUM) X,!!
..S PSDN(10)=" (Subtracted from total)"
..W:'$G(SUM)&($P(PSDN(2),U,3)) "Doses Returned to Stock: ",$P(PSDN(2),U,3),PSDN(10),!!
..W:'$G(SUM)&($P(PSDN(2),U,4)) "Doses Destroyed: ",$P(PSDN(2),U,4),PSDN(10),!!
..W:'$G(SUM)&($P(PSDN(2),U,5)) "Doses Transferred: ",$P(PSDN(2),U,5),PSDN(10),!!
..W:'$G(SUM)&($P(PSDN(2),U,6)) "Doses Adjusted by NAOU: ",$P(PSDN(2),U,6)," (Not affecting total)",!!
..;S:'PSDN(11) ^TMP("PSDM",$J,PSDN(1))=""
.Q:$G(PSDOUT) W LN,!?28,"Total: ",$J($G(PSDN(3)),10),?62
.S X=$G(PSDN(5)) D COMMA^%DTC W X,!! S PSDN(6)=$G(PSDN(6))+PSDN(3)
.S PSDN(7)=$G(PSDN(7))+PSDN(5) K PSDN(3),PSDN(5),PSDN(9)
I $G(PSDN(8))>1 W LN,!?14,"Total for all NAOUs: ",$J($G(PSDN(6)),10) S X=$G(PSDN(7)) D COMMA^%DTC W ?62,X,!!
;I DUZ=33238 I $D(^TMP("PSDM")) D ^PSDCOSM
I $D(^TMP("PSDM",$J)) S ZTRTN="^PSDCOSM",ZTIO="",ZTDTH=$H,ZTDESC="Mailman notification of 0 DRUG file cost",ZTSAVE("PSD*")="",ZTSAVE("^TMP(""PSDM"",$J,")="" D ^%ZTLOAD
W:'$O(^TMP("PSD",$J,0)) !!,"Sorry, nothing to report for selected NAOU(s).",!!
END W:$E(IOST)'="C" @IOF
I $E(IOST)="C",'$G(PSDOUT) W !! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
QUIT K ^TMP("PSD",$J),^TMP("PSDM",$J),IO("Q") Q
I $E(IOST,1,2)'="P-",PG 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)),U),"." S PSDOUT=1
W:$Y @IOF S $P(LN,"-",80)="",PG=PG+1,PG(PSDN)="" W !?2,PSDCHO(1)," From "
W $P(PSDATE,U)," To ",$P(PSDATE,U,2),?72,"Page ",PG,!!
W ?45,"Report Date: ",PSDT(1),!!?40,"Quantity",!,"Drug",?40,"Dispensed"
W ?70,"Cost",!,LN,!!
Q
GETDTA ;
N DTE
Q:'$D(PSDN)
S DTE=$P(PSDN(8),U,4)
S ^TMP("PSDM",$J,PSDN(1),DTE)=PSDN(4)_"^"_PSDN(11)_"^"_PSDN(5)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDCOSN 4965 printed Dec 13, 2024@01:45:23 Page 2
PSDCOSN ;BIR/LTL-Cost Report by NAOUs, PSDCOST (cont'd) ; 2 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**63**;13 Feb 97;Build 1
+2 NEW PSDN,LN,PG,X2
SET PSDSD(1)=PSDSD
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 FOR
SET PSDSD=$ORDER(^PSD(58.81,"ACT",PSDSD))
if $EXTRACT(IOST)="C"
WRITE "."
if 'PSDSD!(PSDSD>PSDED)
QUIT
SET PSDN=$ORDER(^PSD(58.81,"ACT",PSDSD,0))
if $PIECE($GET(^PSD(58.8,+PSDN,0)),U,3)=+PSDSITE
Begin DoDot:1
+4 SET PSDN(1)=$ORDER(^PSD(58.81,"ACT",PSDSD,PSDN,0))
+5 SET PSDN(2)=$ORDER(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),0))
+6 if PSDN(2)<2!(PSDN(2)>5)&(PSDN(2)'=9)
QUIT
+7 SET PSDN(3)=$PIECE($GET(^PSDRUG(+PSDN(1),0)),U)
+8 SET PSDN(4)=$ORDER(^PSD(58.81,"ACT",PSDSD,PSDN,PSDN(1),PSDN(2),0))
+9 SET PSDN(8)=$GET(^PSD(58.81,+PSDN(4),0))
+10 if '$DATA(LOC(+$PIECE(PSDN(8),U,18)))&(PSDN(2)'=9)!('$DATA(LOC(+PSDN))&(PSDN(2)=9))
QUIT
+11 ;get NAOU for everything including adjustments
+12 SET PSDN(9)=$SELECT(PSDN(2)=9:PSDN,1:$PIECE(PSDN(8),U,18))
+13 ;qty rec'd by NAOU w/green sheet
+14 SET PSDN(5)=$PIECE($GET(^PSD(58.81,+PSDN(4),1)),U,8)
+15 SET PSDN(11)=$PIECE($GET(^PSDRUG(PSDN(1),660)),U,6)
+16 IF $DATA(PSDN)
IF 'PSDN(11)
DO GETDTA
+17 ;qty dispensed by Master Vault w/o green sheet
+18 if $PIECE(PSDN(8),U,17)']""
SET PSDN(5)=$PIECE(PSDN(8),U,6)
+19 ;Returned to Stock
+20 if PSDN(2)=3
SET PSDN(5)=-$PIECE($GET(^PSD(58.81,+PSDN(4),3)),U,2)
+21 ;Destroyed
+22 if PSDN(2)=4
SET PSDN(5)=-$PIECE($GET(^PSD(58.81,+PSDN(4),3)),U,5)
+23 ;include transfer ins with dispensed
+24 if PSDN(2)=5
SET PSDN(2)=2
+25 ;Check for transfers
+26 SET PSDN(6)=$GET(^PSD(58.81,+PSDN(4),7))
+27 if $PIECE(PSDN(6),U)>PSDSD(1)&($PIECE(PSDN(6),U)<PSDED)
Begin DoDot:2
+28 SET PSDN(5)=PSDN(5)-$PIECE(PSDN(6),U,7)
SET PSDN(2)=5
End DoDot:2
+29 SET PSDN(7)=$GET(^TMP("PSD",$JOB,PSDN(9),PSDN(3)))
+30 ;total dispensed
+31 SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U)=$PIECE(PSDN(7),U)+PSDN(5)
+32 ;DA for drug
+33 if '$PIECE(PSDN(7),U,2)
SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U,2)=PSDN(1)
+34 ;total returned to stock
+35 if PSDN(2)=3
SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U,3)=PSDN(5)+$PIECE(PSDN(7),U,3)
+36 ;total destroyed
+37 if PSDN(2)=4
SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U,4)=PSDN(5)+$PIECE(PSDN(7),U,4)
+38 ;total transferred
+39 if PSDN(2)=5
SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U,5)=-$PIECE(PSDN(6),U,7)+$PIECE(PSDN(7),U,5)
+40 ;total adjusted by NAOU
+41 if PSDN(2)=9
SET $PIECE(^TMP("PSD",$JOB,PSDN(9),PSDN(3)),U,6)=PSDN(5)+$PIECE(PSDN(7),U,6)
+42 KILL PSDN
End DoDot:1
+43 ;
PRTQUE ;queues print after data is compiled
+1 IF $DATA(ZTQUEUED)
KILL ZTSAVE,ZTSK
SET ZTIO=PSDIO
SET ZTDESC="CS Cost Report by NAOU"
SET ZTRTN="START^PSDCOSN"
SET ZTSAVE("PSD*")=""
SET ZTSAVE("^TMP(""PSD"",$J,")=""
SET ZTSAVE("SUM")=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
GOTO QUIT
START SET (PG,PSDN)=0
DO HEADER
+1 FOR
SET PSDN=$ORDER(^TMP("PSD",$JOB,PSDN))
if 'PSDN
QUIT
if $Y+6>IOSL
DO HEADER
if $GET(PSDOUT)
GOTO END
SET PSDN(8)=$GET(PSDN(8))+1
KILL PG(PSDN)
Begin DoDot:1
+2 WRITE ?8,"NAOU ==> ",$PIECE($GET(^PSD(58.8,+PSDN,0)),U),!!
SET PSDN(1)=0
+3 FOR
SET PSDN(1)=$ORDER(^TMP("PSD",$JOB,PSDN,PSDN(1)))
if PSDN(1)']""
QUIT
if $Y+6>IOSL
DO HEADER
if $GET(PSDOUT)
QUIT
SET PSDN(9)=$GET(PSDN(9))+1
Begin DoDot:2
+4 IF $DATA(PG(PSDN))
WRITE ?8,"NAOU ==> ",$PIECE($GET(^PSD(58.8,+PSDN,0)),U)," (continued)",!!
KILL PG(PSDN)
+5 if '$GET(SUM)
WRITE $EXTRACT(PSDN(1),1,34),?36
+6 SET PSDN(2)=$GET(^TMP("PSD",$JOB,PSDN,PSDN(1)))
SET PSDN(3)=$GET(PSDN(3))+PSDN(2)
+7 if '$GET(SUM)
WRITE $JUSTIFY($PIECE(PSDN(2),U),10),?62
+8 SET PSDN(11)=$PIECE($GET(^PSDRUG(+$PIECE(PSDN(2),U,2),660)),U,6)
+9 SET (X,PSDN(4))=$PIECE(PSDN(2),U)*PSDN(11)
SET X2="2$"
SET PSDN(5)=$GET(PSDN(5))+PSDN(4)
DO COMMA^%DTC
if '$GET(SUM)
WRITE X,!!
+10 SET PSDN(10)=" (Subtracted from total)"
+11 if '$GET(SUM)&($PIECE(PSDN(2),U,3))
WRITE "Doses Returned to Stock: ",$PIECE(PSDN(2),U,3),PSDN(10),!!
+12 if '$GET(SUM)&($PIECE(PSDN(2),U,4))
WRITE "Doses Destroyed: ",$PIECE(PSDN(2),U,4),PSDN(10),!!
+13 if '$GET(SUM)&($PIECE(PSDN(2),U,5))
WRITE "Doses Transferred: ",$PIECE(PSDN(2),U,5),PSDN(10),!!
+14 if '$GET(SUM)&($PIECE(PSDN(2),U,6))
WRITE "Doses Adjusted by NAOU: ",$PIECE(PSDN(2),U,6)," (Not affecting total)",!!
+15 ;S:'PSDN(11) ^TMP("PSDM",$J,PSDN(1))=""
End DoDot:2
+16 if $GET(PSDOUT)
QUIT
WRITE LN,!?28,"Total: ",$JUSTIFY($GET(PSDN(3)),10),?62
+17 SET X=$GET(PSDN(5))
DO COMMA^%DTC
WRITE X,!!
SET PSDN(6)=$GET(PSDN(6))+PSDN(3)
+18 SET PSDN(7)=$GET(PSDN(7))+PSDN(5)
KILL PSDN(3),PSDN(5),PSDN(9)
End DoDot:1
if $GET(PSDOUT)
GOTO END
+19 IF $GET(PSDN(8))>1
WRITE LN,!?14,"Total for all NAOUs: ",$JUSTIFY($GET(PSDN(6)),10)
SET X=$GET(PSDN(7))
DO COMMA^%DTC
WRITE ?62,X,!!
+20 ;I DUZ=33238 I $D(^TMP("PSDM")) D ^PSDCOSM
+21 IF $DATA(^TMP("PSDM",$JOB))
SET ZTRTN="^PSDCOSM"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="Mailman notification of 0 DRUG file cost"
SET ZTSAVE("PSD*")=""
SET ZTSAVE("^TMP(""PSDM"",$J,")=""
DO ^%ZTLOAD
+22 if '$ORDER(^TMP("PSD",$JOB,0))
WRITE !!,"Sorry, nothing to report for selected NAOU(s).",!!
END if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
IF '$GET(PSDOUT)
WRITE !!
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT KILL ^TMP("PSD",$JOB),^TMP("PSDM",$JOB),IO("Q")
QUIT
+1 IF $EXTRACT(IOST,1,2)'="P-"
IF PG
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)),U),"."
SET PSDOUT=1
+3 if $Y
WRITE @IOF
SET $PIECE(LN,"-",80)=""
SET PG=PG+1
SET PG(PSDN)=""
WRITE !?2,PSDCHO(1)," From "
+4 WRITE $PIECE(PSDATE,U)," To ",$PIECE(PSDATE,U,2),?72,"Page ",PG,!!
+5 WRITE ?45,"Report Date: ",PSDT(1),!!?40,"Quantity",!,"Drug",?40,"Dispensed"
+6 WRITE ?70,"Cost",!,LN,!!
+7 QUIT
GETDTA ;
+1 NEW DTE
+2 if '$DATA(PSDN)
QUIT
+3 SET DTE=$PIECE(PSDN(8),U,4)
+4 SET ^TMP("PSDM",$JOB,PSDN(1),DTE)=PSDN(4)_"^"_PSDN(11)_"^"_PSDN(5)
+5 QUIT
+6 ;
