PSDCOSH ;BIR/LTL-Cost Report by High Cost, PSDCOST (cont'd) ; 2 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
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)
.;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(3)))
.;total dispensed
.S $P(^TMP("PSD",$J,PSDN(3)),U)=$P(PSDN(7),U)+PSDN(5)
.;total cost
.S $P(^TMP("PSD",$J,PSDN(3)),U,2)=$P(^TMP("PSD",$J,PSDN(3)),U,2)+($P($G(^PSDRUG(+PSDN(1),660)),U,6)*PSDN(5))
.K PSDN
PRTQUE ;queues print after data is compiled
I $D(ZTQUEUED) K ZTSAVE,ZTSK S ZTIO=PSDIO,ZTDESC="CS High Cost Report",ZTRTN="START^PSDCOSH",ZTDTH=$H,ZTSAVE("PSD*")="",ZTSAVE("^TMP(""PSD"",$J,")="",ZTSAVE("ALL")="",ZTSAVE("LOC(")="" D ^%ZTLOAD,HOME^%ZIS G QUIT
START S (PG,PSDN)=0 D HEADER
D:PSD(1)=1
.F S PSDN=$O(^TMP("PSD",$J,PSDN)) Q:PSDN!(PSDN']"") S PSDN(1)=$G(^TMP("PSD",$J,PSDN)) D:$P(PSDN(1),U,2)>PSD
..S ^TMP("PSD",$J,999999999-$P(PSDN(1),U,2))=$P(PSDN(1),U)_U_$P(PSDN(1),U,2)_U_PSDN
F S PSDN=$O(^TMP("PSD",$J,PSDN)) Q:(PSD(1)=1&('PSDN))!(PSDN']"") D:$Y+6>IOSL HEADER G:$G(PSDOUT) END D G:$G(PSDOUT) END
.S PSDN(1)=$G(^TMP("PSD",$J,PSDN))
.Q:PSD(1)=2&($P(PSDN(1),U,2)'>PSD)
.W $E($S(PSDN:$P(PSDN(1),U,3),1:PSDN),1,34),?36
.W $J($P(PSDN(1),U),10),?62
.S X=$P(PSDN(1),U,2),X2="2$" D COMMA^%DTC W X,!!
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),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 W !?2,PSDCHO(1)," From "
W $P(PSDATE,U)," To ",$P(PSDATE,U,2),?72,"Page ",PG,!!
S PSD(2)=$O(LOC(0)) W "For " W:$G(ALL) "ALL NAOU(s)"
W:'$O(LOC(PSD(2)))&('$G(ALL)) $P($G(^PSD(58.8,+$O(LOC(0)),0)),U)
I $O(LOC(PSD(2))),'$G(ALL) W "The Following NAOU(s): " D
.S PSD(2)=0 F S PSD(2)=$O(LOC(PSD(2))) Q:'PSD(2) W $P($G(^PSD(58.8,+PSD(2),0)),U),!?28
W ?45,"Report Date: ",PSDT(1),!!?40,"Quantity",!,"Drug",?40,"Dispensed"
W ?70,"Cost",!,LN,!!
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDCOSH 3456 printed Dec 13, 2024@01:45:21 Page 2
PSDCOSH ;BIR/LTL-Cost Report by High Cost, PSDCOST (cont'd) ; 2 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
+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 ;qty dispensed by Master Vault w/o green sheet
+16 if $PIECE(PSDN(8),U,17)']""
SET PSDN(5)=$PIECE(PSDN(8),U,6)
+17 ;Returned to Stock
+18 if PSDN(2)=3
SET PSDN(5)=-$PIECE($GET(^PSD(58.81,+PSDN(4),3)),U,2)
+19 ;Destroyed
+20 if PSDN(2)=4
SET PSDN(5)=-$PIECE($GET(^PSD(58.81,+PSDN(4),3)),U,5)
+21 ;include transfer ins with dispensed
+22 if PSDN(2)=5
SET PSDN(2)=2
+23 ;Check for transfers
+24 SET PSDN(6)=$GET(^PSD(58.81,+PSDN(4),7))
+25 if $PIECE(PSDN(6),U)>PSDSD(1)&($PIECE(PSDN(6),U)<PSDED)
Begin DoDot:2
+26 SET PSDN(5)=PSDN(5)-$PIECE(PSDN(6),U,7)
SET PSDN(2)=5
End DoDot:2
+27 SET PSDN(7)=$GET(^TMP("PSD",$JOB,PSDN(3)))
+28 ;total dispensed
+29 SET $PIECE(^TMP("PSD",$JOB,PSDN(3)),U)=$PIECE(PSDN(7),U)+PSDN(5)
+30 ;total cost
+31 SET $PIECE(^TMP("PSD",$JOB,PSDN(3)),U,2)=$PIECE(^TMP("PSD",$JOB,PSDN(3)),U,2)+($PIECE($GET(^PSDRUG(+PSDN(1),660)),U,6)*PSDN(5))
+32 KILL PSDN
End DoDot:1
PRTQUE ;queues print after data is compiled
+1 IF $DATA(ZTQUEUED)
KILL ZTSAVE,ZTSK
SET ZTIO=PSDIO
SET ZTDESC="CS High Cost Report"
SET ZTRTN="START^PSDCOSH"
SET ZTDTH=$HOROLOG
SET ZTSAVE("PSD*")=""
SET ZTSAVE("^TMP(""PSD"",$J,")=""
SET ZTSAVE("ALL")=""
SET ZTSAVE("LOC(")=""
DO ^%ZTLOAD
DO HOME^%ZIS
GOTO QUIT
START SET (PG,PSDN)=0
DO HEADER
+1 if PSD(1)=1
Begin DoDot:1
+2 FOR
SET PSDN=$ORDER(^TMP("PSD",$JOB,PSDN))
if PSDN!(PSDN']"")
QUIT
SET PSDN(1)=$GET(^TMP("PSD",$JOB,PSDN))
if $PIECE(PSDN(1),U,2)>PSD
Begin DoDot:2
+3 SET ^TMP("PSD",$JOB,999999999-$PIECE(PSDN(1),U,2))=$PIECE(PSDN(1),U)_U_$PIECE(PSDN(1),U,2)_U_PSDN
End DoDot:2
End DoDot:1
+4 FOR
SET PSDN=$ORDER(^TMP("PSD",$JOB,PSDN))
if (PSD(1)=1&('PSDN))!(PSDN']"")
QUIT
if $Y+6>IOSL
DO HEADER
if $GET(PSDOUT)
GOTO END
Begin DoDot:1
+5 SET PSDN(1)=$GET(^TMP("PSD",$JOB,PSDN))
+6 if PSD(1)=2&($PIECE(PSDN(1),U,2)'>PSD)
QUIT
+7 WRITE $EXTRACT($SELECT(PSDN:$PIECE(PSDN(1),U,3),1:PSDN),1,34),?36
+8 WRITE $JUSTIFY($PIECE(PSDN(1),U),10),?62
+9 SET X=$PIECE(PSDN(1),U,2)
SET X2="2$"
DO COMMA^%DTC
WRITE X,!!
End DoDot:1
if $GET(PSDOUT)
GOTO END
+10 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),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
WRITE !?2,PSDCHO(1)," From "
+4 WRITE $PIECE(PSDATE,U)," To ",$PIECE(PSDATE,U,2),?72,"Page ",PG,!!
+5 SET PSD(2)=$ORDER(LOC(0))
WRITE "For "
if $GET(ALL)
WRITE "ALL NAOU(s)"
+6 if '$ORDER(LOC(PSD(2)))&('$GET(ALL))
WRITE $PIECE($GET(^PSD(58.8,+$ORDER(LOC(0)),0)),U)
+7 IF $ORDER(LOC(PSD(2)))
IF '$GET(ALL)
WRITE "The Following NAOU(s): "
Begin DoDot:1
+8 SET PSD(2)=0
FOR
SET PSD(2)=$ORDER(LOC(PSD(2)))
if 'PSD(2)
QUIT
WRITE $PIECE($GET(^PSD(58.8,+PSD(2),0)),U),!?28
End DoDot:1
+9 WRITE ?45,"Report Date: ",PSDT(1),!!?40,"Quantity",!,"Drug",?40,"Dispensed"
+10 WRITE ?70,"Cost",!,LN,!!
