- 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 Feb 18, 2025@23:11:46 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,!!
