PSGDCTP ;BIR/DAV,MLM-SORT AND PRINT DRUG PROFILE DATA ;1 NOV 95 / 8:55 AM
;;5.0; INPATIENT MEDICATIONS ;**132**;16 DEC 97
;
; Resort data by if by amt or cost.
K ^TMP($J,"S2") S PSGP2=$S(PSGDCT=1:0,1:$D(PSGDISP)),PSGWO=$S('$D(PSGDCLW):0,1:'PSGP2),S1=""
F S S1=$O(^TMP($J,"S1",S1)) Q:S1=""!(S1="RST") S ND=$G(^(S1,0)) I '$$EXCLUDE(ND) D
.S RST1=$$SETRST(PSGDCTS,ND),$P(ND,U,4)=$P(S1,U),PSG1=$E($P(S1,U),1,20)_U_$P(S1,U,2),^TMP($J,"S2",RST1,PSG1)=ND
.S S2=0 F S S2=$O(^TMP($J,"S1",S1,S2)) Q:S2="" S ND=$G(^(S2,0)) I ND>0 D
..S RST3=$$SETRST(PSGDCTS,ND) I $D(PSGDISP)!PSGWO S PSG2=$E($P(S2,U),1,20)_U_$P(S2,U,2),$P(ND,U,4)=$P(S2,U),^TMP($J,"S2",RST1,PSG1,RST3,PSG2)=ND
..S S3=0 F S S3=$O(^TMP($J,"S1",S1,S2,S3)) Q:S3="" S ND=$G(^(S3,0)) I ND>0 D
...S RST5=$$SETRST(PSGDCTS,ND),$P(ND,U,4)=$P(S3,U),^TMP($J,"S2",RST1,PSG1,RST3,PSG2,RST5,$E($P(S3,U,2),1,20))=ND
D START
Q
;
DONE ;Kill and EXIT.
W:CML&($Y) @IOF
DONE1 D ENCV^PSGSETU K ^TMP($J),CML,DRG,FD,HLP,LN1,ND,ND50,NP,OI,PD,PR,PSG,PSG1,PSG2,PSG3,PSG4,PSG5,PSG6,PSGASUM,PSGCLW,PSGCSUM,PSGCTL,PSGCTS,PSGDCLW,PSGDCSUM
K PSGDCT,PSGDCTA,PSGDCTD,PSGDCTL,PSGDCTS,PSGDISP,PSGERR,PSGP2,PSGSASUM,PSGSCSUM,PSGWO,RST1,RST3,RST5,RTN,S1,S2,S3,SD,ST,STOP,STRT,TYP,W,WD,X,Y
K OIND,PSGDASUM,PSGDT,PSGID,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSU
Q
EXCLUDE(X) ; Check if drug data should be included.
S C=$P(ND,U,2)
I (ND!C),(PSGDCTL=""!(C'<PSGDCTL)),(PSGDCTA=""!(ND'<PSGDCTA)) Q 0
Q 1
;
SETRST(X,ND) ; Set RSTx subscripts
Q $S("CA"'[X:"ZZ",X="C":-(+$P(ND,U,2)),1:-(+ND))
;
START ;
N DIRUT
D NOW^%DTC S PSGDT=%,CML=IO'=IO(0)!(IOST'["C-"),(NP,LN1)="",$P(LN1,"-",81)=""
U IO D HDR I '$D(^TMP($J,"S2")) W !!?25,"*** NO DRUG COST DATA FOUND ***" D DONE Q
;
PRINT ;Print Data
S (PSGCSUM,PSGASUM)=0,PSG1="" F S PSG1=$O(^TMP($J,"S2",PSG1)) Q:PSG1=""!$D(DIRUT) D
.S PSG2="" F S PSG2=$O(^TMP($J,"S2",PSG1,PSG2)) Q:PSG2=""!$D(DIRUT) D D:PSGP2!$D(PSGDCLW) SUM(PSGSASUM,PSGSCSUM,$S(PSGDCT=1:"D",1:"S"))
..S ND=$G(^TMP($J,"S2",PSG1,PSG2)),PSGSASUM=+ND,PSGSCSUM=$P(ND,U,2),PSGASUM=PSGASUM+PSGSASUM,PSGCSUM=PSGCSUM+PSGSCSUM
..W ! W:PSGDCT=1&$P(ND,U,3) "**" W ?2,$P(ND,U,4) D:'PSGP2&'$D(PSGDCLW) WRTAC
..S PSG3="" F S PSG3=$O(^TMP($J,"S2",PSG1,PSG2,PSG3)) Q:PSG3=""!$D(DIRUT) D
...S PSG4="" F S PSG4=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4)) Q:PSG4=""!$D(DIRUT) S ND=$G(^(PSG4)) D D:$D(PSGDCLW)&'PSGWO SUM(PSGDASUM,PSGDCSUM,"D")
....S PSGDASUM=+ND,PSGDCSUM=$P(ND,U,2) I PSGP2!PSGWO W !?3,$S($P(ND,U,3)="":" ",1:"**"),$P(ND,U,4) D:'$D(PSGDCLW)!PSGWO WRTAC
....S PSG5="" F S PSG5=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5)) Q:PSG5=""!$D(DIRUT) D
.....S PSG6="" F S PSG6=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5,PSG6)) Q:PSG6=""!$D(DIRUT) S ND=$G(^(PSG6)) D
......W !,?10,$P(ND,U,4) D WRTAC
D:'$D(DIRUT) SUM(PSGASUM,PSGCSUM,"L")
Q
;
WRTAC ; Print amt, cost line.
W ?50,$J(+ND,8,3),?70,$J($P(ND,U,2),8,4) D:$Y+7>IOSL EOP
Q
;
HDR ;Report Header.
W:$Y @IOF W !!?28,"UNIT DOSE DRUG COST REPORT",?63,$$ENDTC^PSGMI(PSGDT),!?25,"FROM ",STRT," THROUGH ",STOP,!!
D:'PSGP2&'$D(PSGDCLW) HDR1
W PSGDCT(1) D:$D(PSGDCLW)&'PSGP2 HDR1
I PSGP2 W !?5,"DISPENSED DRUG"
D:$D(PSGDCLW)&$D(PSGDISP) HDR1
W:$D(PSGDCLW) ?(5+(PSGP2*5)),"WARD" W ?50,"DISPENSED",?74,"COST",!,LN1,!
Q
HDR1 W ?48,"TOTAL UNITS",?73,"TOTAL",!
Q
;
SUM(AMT,CST,TYP) ;Print totals and subtotals
Q:$D(DIRUT)
W !?51,"---------------------------",!,?22 W $J($S(TYP="S":PSGDCT(1),TYP="D":"DISPENSE DRUG",1:""),13)," " W:TYP'="L" "Sub-" W ?39,"Total:",?50,$J(AMT,8,3),?70,$J(CST,8,4),!
I TYP="L",NP'["^",CML W !!?54,"(** = NON-FORMULARY ITEM)"
I $Y+7>IOSL,(TYP'="L") D EOP
Q
;
EOP ;Check for end of page.
I 'CML K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
I CML W !!?54,"(** = NON-FORMULARY ITEM) "
D HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGDCTP 3800 printed Sep 23, 2025@19:37:09 Page 2
PSGDCTP ;BIR/DAV,MLM-SORT AND PRINT DRUG PROFILE DATA ;1 NOV 95 / 8:55 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**132**;16 DEC 97
+2 ;
+3 ; Resort data by if by amt or cost.
+4 KILL ^TMP($JOB,"S2")
SET PSGP2=$SELECT(PSGDCT=1:0,1:$DATA(PSGDISP))
SET PSGWO=$SELECT('$DATA(PSGDCLW):0,1:'PSGP2)
SET S1=""
+5 FOR
SET S1=$ORDER(^TMP($JOB,"S1",S1))
if S1=""!(S1="RST")
QUIT
SET ND=$GET(^(S1,0))
IF '$$EXCLUDE(ND)
Begin DoDot:1
+6 SET RST1=$$SETRST(PSGDCTS,ND)
SET $PIECE(ND,U,4)=$PIECE(S1,U)
SET PSG1=$EXTRACT($PIECE(S1,U),1,20)_U_$PIECE(S1,U,2)
SET ^TMP($JOB,"S2",RST1,PSG1)=ND
+7 SET S2=0
FOR
SET S2=$ORDER(^TMP($JOB,"S1",S1,S2))
if S2=""
QUIT
SET ND=$GET(^(S2,0))
IF ND>0
Begin DoDot:2
+8 SET RST3=$$SETRST(PSGDCTS,ND)
IF $DATA(PSGDISP)!PSGWO
SET PSG2=$EXTRACT($PIECE(S2,U),1,20)_U_$PIECE(S2,U,2)
SET $PIECE(ND,U,4)=$PIECE(S2,U)
SET ^TMP($JOB,"S2",RST1,PSG1,RST3,PSG2)=ND
+9 SET S3=0
FOR
SET S3=$ORDER(^TMP($JOB,"S1",S1,S2,S3))
if S3=""
QUIT
SET ND=$GET(^(S3,0))
IF ND>0
Begin DoDot:3
+10 SET RST5=$$SETRST(PSGDCTS,ND)
SET $PIECE(ND,U,4)=$PIECE(S3,U)
SET ^TMP($JOB,"S2",RST1,PSG1,RST3,PSG2,RST5,$EXTRACT($PIECE(S3,U,2),1,20))=ND
End DoDot:3
End DoDot:2
End DoDot:1
+11 DO START
+12 QUIT
+13 ;
DONE ;Kill and EXIT.
+1 if CML&($Y)
WRITE @IOF
DONE1 DO ENCV^PSGSETU
KILL ^TMP($JOB),CML,DRG,FD,HLP,LN1,ND,ND50,NP,OI,PD,PR,PSG,PSG1,PSG2,PSG3,PSG4,PSG5,PSG6,PSGASUM,PSGCLW,PSGCSUM,PSGCTL,PSGCTS,PSGDCLW,PSGDCSUM
+1 KILL PSGDCT,PSGDCTA,PSGDCTD,PSGDCTL,PSGDCTS,PSGDISP,PSGERR,PSGP2,PSGSASUM,PSGSCSUM,PSGWO,RST1,RST3,RST5,RTN,S1,S2,S3,SD,ST,STOP,STRT,TYP,W,WD,X,Y
+2 KILL OIND,PSGDASUM,PSGDT,PSGID,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSU
+3 QUIT
EXCLUDE(X) ; Check if drug data should be included.
+1 SET C=$PIECE(ND,U,2)
+2 IF (ND!C)
IF (PSGDCTL=""!(C'<PSGDCTL))
IF (PSGDCTA=""!(ND'<PSGDCTA))
QUIT 0
+3 QUIT 1
+4 ;
SETRST(X,ND) ; Set RSTx subscripts
+1 QUIT $SELECT("CA"'[X:"ZZ",X="C":-(+$PIECE(ND,U,2)),1:-(+ND))
+2 ;
START ;
+1 NEW DIRUT
+2 DO NOW^%DTC
SET PSGDT=%
SET CML=IO'=IO(0)!(IOST'["C-")
SET (NP,LN1)=""
SET $PIECE(LN1,"-",81)=""
+3 USE IO
DO HDR
IF '$DATA(^TMP($JOB,"S2"))
WRITE !!?25,"*** NO DRUG COST DATA FOUND ***"
DO DONE
QUIT
+4 ;
PRINT ;Print Data
+1 SET (PSGCSUM,PSGASUM)=0
SET PSG1=""
FOR
SET PSG1=$ORDER(^TMP($JOB,"S2",PSG1))
if PSG1=""!$DATA(DIRUT)
QUIT
Begin DoDot:1
+2 SET PSG2=""
FOR
SET PSG2=$ORDER(^TMP($JOB,"S2",PSG1,PSG2))
if PSG2=""!$DATA(DIRUT)
QUIT
Begin DoDot:2
+3 SET ND=$GET(^TMP($JOB,"S2",PSG1,PSG2))
SET PSGSASUM=+ND
SET PSGSCSUM=$PIECE(ND,U,2)
SET PSGASUM=PSGASUM+PSGSASUM
SET PSGCSUM=PSGCSUM+PSGSCSUM
+4 WRITE !
if PSGDCT=1&$PIECE(ND,U,3)
WRITE "**"
WRITE ?2,$PIECE(ND,U,4)
if 'PSGP2&'$DATA(PSGDCLW)
DO WRTAC
+5 SET PSG3=""
FOR
SET PSG3=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3))
if PSG3=""!$DATA(DIRUT)
QUIT
Begin DoDot:3
+6 SET PSG4=""
FOR
SET PSG4=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4))
if PSG4=""!$DATA(DIRUT)
QUIT
SET ND=$GET(^(PSG4))
Begin DoDot:4
+7 SET PSGDASUM=+ND
SET PSGDCSUM=$PIECE(ND,U,2)
IF PSGP2!PSGWO
WRITE !?3,$SELECT($PIECE(ND,U,3)="":" ",1:"**"),$PIECE(ND,U,4)
if '$DATA(PSGDCLW)!PSGWO
DO WRTAC
+8 SET PSG5=""
FOR
SET PSG5=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4,PSG5))
if PSG5=""!$DATA(DIRUT)
QUIT
Begin DoDot:5
+9 SET PSG6=""
FOR
SET PSG6=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4,PSG5,PSG6))
if PSG6=""!$DATA(DIRUT)
QUIT
SET ND=$GET(^(PSG6))
Begin DoDot:6
+10 WRITE !,?10,$PIECE(ND,U,4)
DO WRTAC
End DoDot:6
End DoDot:5
End DoDot:4
if $DATA(PSGDCLW)&'PSGWO
DO SUM(PSGDASUM,PSGDCSUM,"D")
End DoDot:3
End DoDot:2
if PSGP2!$DATA(PSGDCLW)
DO SUM(PSGSASUM,PSGSCSUM,$SELECT(PSGDCT=1:"D",1:"S"))
End DoDot:1
+11 if '$DATA(DIRUT)
DO SUM(PSGASUM,PSGCSUM,"L")
+12 QUIT
+13 ;
WRTAC ; Print amt, cost line.
+1 WRITE ?50,$JUSTIFY(+ND,8,3),?70,$JUSTIFY($PIECE(ND,U,2),8,4)
if $Y+7>IOSL
DO EOP
+2 QUIT
+3 ;
HDR ;Report Header.
+1 if $Y
WRITE @IOF
WRITE !!?28,"UNIT DOSE DRUG COST REPORT",?63,$$ENDTC^PSGMI(PSGDT),!?25,"FROM ",STRT," THROUGH ",STOP,!!
+2 if 'PSGP2&'$DATA(PSGDCLW)
DO HDR1
+3 WRITE PSGDCT(1)
if $DATA(PSGDCLW)&'PSGP2
DO HDR1
+4 IF PSGP2
WRITE !?5,"DISPENSED DRUG"
+5 if $DATA(PSGDCLW)&$DATA(PSGDISP)
DO HDR1
+6 if $DATA(PSGDCLW)
WRITE ?(5+(PSGP2*5)),"WARD"
WRITE ?50,"DISPENSED",?74,"COST",!,LN1,!
+7 QUIT
HDR1 WRITE ?48,"TOTAL UNITS",?73,"TOTAL",!
+1 QUIT
+2 ;
SUM(AMT,CST,TYP) ;Print totals and subtotals
+1 if $DATA(DIRUT)
QUIT
+2 WRITE !?51,"---------------------------",!,?22
WRITE $JUSTIFY($SELECT(TYP="S":PSGDCT(1),TYP="D":"DISPENSE DRUG",1:""),13)," "
if TYP'="L"
WRITE "Sub-"
WRITE ?39,"Total:",?50,$JUSTIFY(AMT,8,3),?70,$JUSTIFY(CST,8,4),!
+3 IF TYP="L"
IF NP'["^"
IF CML
WRITE !!?54,"(** = NON-FORMULARY ITEM)"
+4 IF $Y+7>IOSL
IF (TYP'="L")
DO EOP
+5 QUIT
+6 ;
EOP ;Check for end of page.
+1 IF 'CML
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+2 IF CML
WRITE !!?54,"(** = NON-FORMULARY ITEM) "
+3 DO HDR
+4 QUIT
