PSGDCT ;BIR/CML3-DRUG COST TOTALS ; 24 Mar 98 / 10:10 AM
;;5.0; INPATIENT MEDICATIONS ;**9,50,91**;16 DEC 97
; Reference to ^PS(50.606 supported by DBIA# 2174.
; Reference to ^PS(50.7 supported by DBIA# 2180.
; Reference to ^PS(50.605 is supported by DBIA# 2138.
; Reference to ^PSDRUG is supported by DBIA# 2192.
;
D ENCV^PSGSETU Q:$D(XQUIT)
S HLP="DRUG COST" D ENDTS^PSGAMS G:'SD!'FD DONE K PSGERR D QUES I $D(PSGERR) W " not selected, DRUG report terminated...",$C(7) G DONE
S RTN="DCT" D EN3^PSGTI I 'POP,'$D(IO("Q")) D ENQ D:IO'=IO(0)!($E(IOST)'="C") ^%ZISC
;
DONE ;
D DONE1^PSGDCTP
Q
;
ENQ ;
D ^PSGDCT1,^PSGDCTP
Q
;
QUES ;
K DIR,PSGDCLW S DIR(0)="Y",DIR("A")="Select by Ward? (Y/N):",DIR("B")="NO",DIR("??")="^D WDHLP^PSGDCT1" D ^DIR K DIR I $D(DIRUT) S PSGERR=1 W !!,"...Ward" Q
I Y D G:'$D(PSGDCLW) QUES
.K DIR S DIR(0)="FAO",DIR("A")="Select WARD: ",DIR("B")="ALL",DIR("?")="^D DIC^PSGDCT(""^DIC(42,"",""PSGDCLW"",""WARD"")" W !! D ^DIR K DIR I Y="ALL" S PSGDCLW="ALL" Q
.D DIC("^DIC(42,","PSGDCLW","WARD") K:'$O(PSGDCLW(0)) PSGDCLW
;
; ask 'sort by', 'cost limit', and 'dispensing amount limit' questions
K DIR S DIR(0)="SAO^1:DISPENSE DRUG;2:ORDERABLE ITEM;3:VA CLASS",DIR("A")="Select drugs by DISPENSE DRUG, ORDERABLE ITEM, or VA CLASS: ",DIR("?")="^D ENQH^PSGDCT1" W ! D ^DIR K DIR I 'Y S PSGERR=1 W !!,"...Select category" Q
S PSGDCT=Y,PSGDCT(1)=$S(PSGDCT=1:"DISPENSED DRUG",PSGDCT=2:"ORDERABLE ITEM",1:"VA CLASS"),X=PSGDCT(1) D LC S PSGDCT(2)=X K X,Y
;
SH ;Select entries to be included..
K DIR S DIR(0)="FAO",DIR("A")="Select "_PSGDCT(2)_": ",DIR("B")="ALL",PSG=$S(PSGDCT=1:"^PSDRUG(",PSGDCT=2:"^PS(50.7,",1:"^PS(50.605,"),DIR("?")="^D DIC^PSGDCT("""_PSG_""",""PSGDCLW"","""_PSGDCT(1)_""")"
W !! D ^DIR K DIR I $D(DIRUT) W !!,"...",PSGDCT(1)," not selected" S PSGERR=1 Q
I Y="ALL" S PSGDCTD=Y
E D DIC(PSG,"PSGDCTD",PSGDCT(1)) G:$O(PSGDCTD(0))="" SH
I PSGDCT>1 D DISP Q:$D(PSGERR)
;
SB ;
I $G(PSGDCTD)'="ALL" D I X<2 S PSGDCTS="N",(PSGDCTA,PSGDCTL)="" Q
.S Y="" F X=0:1 S Y=$O(PSGDCTD(Y)) Q:Y=""
K DIR S DIR(0)="SOA^1:"_PSGDCT(1)_";2:COST;3:AMOUNT DISPENSED",DIR("A")="Sort drugs by "_PSGDCT(1)_", COST, or AMOUNT DISPENSED: ",DIR("??")="^D SBCHK^PSGDCT1" D ^DIR K DIR I $D(DIRUT) W !!,"...Sort order" S PSGERR=1 Q
S PSGDCTS=$S(Y=3:"A",Y=2:"C",1:"N")
;
CL F R !!,"Print all drugs costing at least? ",PSGDCTL:DTIME W:'$T $C(7) S:'$T PSGDCTL="^" Q:"^"[PSGDCTL!(PSGDCTL?.1"-".N.1".".2N) D:PSGDCTL?1."?" CLM^PSGDCT1 W:PSGDCTL'?1."?" $C(7),$C(7)," ??"
W:PSGDCTL="" " (ALL)" I PSGDCTL="^" S PSGERR=1 W !!,"...Cost limit" S PSGERR=1 Q
;
AL F R !!,"Print all drugs with a dispensing amount of at least? ",PSGDCTA:DTIME W:'$T $C(7) S:'$T PSGDCTA="^" Q:"^"[PSGDCTA!(PSGDCTA?.1"-"1.N) D:PSGDCTA?1."?" ALM^PSGDCT1 W:PSGDCTA'?1."?" $C(7),$C(7)," ??"
W:PSGDCTA="" " (ALL)" I PSGDCTA="^" W !!,"...Dispensing amount" S PSGERR=1 Q
Q
;
DISP ;view dispensed drugs
F W !!,"Display the dispense drugs" S %=1 D YN^DICN Q:% W !!,"Answer 'YES' and I will display the dispensed drugs associated with the ",!,PSGDCT(1)," or answer 'NO' and only the totals will be displayed.",!
I %<0 S PSGERR=1 W !!,"...Dispense drug display" Q
K PSGDISP S:%=1 PSGDISP=1
Q
;
DIC(PSG,PSGDC,PSGT) ;LooK up a ward or report types.
K DIC,@PSGDC S @PSGDC=1,DIC=PSG,DIC(0)="QEMZ"
;if Orderable Item, display the IV identifier
I DIC="^PS(50.7," D
.;/IV flag and Identifier is no longer used after POE changes
.;/S PSJIDD=$P($G(^PS(59.7,1,31)),"^",2)
.;/S DIC("W")="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_$S($P(^PS(50.7,+Y,0),""^"",3):"" ""_$G(PSJIDD),1:"""")_"
.S DIC("W")="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_"
.S DIC("W")=DIC("W")_""" ""_$S($P(^PS(50.7,+Y,0),""^"",4):$E($P(^(0),""^"",4),4,5)_""-""_$E($P(^(0),""^"",4),6,7)_""-""_$E($P(^(0),""^"",4),2,3),1:"""")"
;/F D ^DIC K PSJIDD Q:Y<0 S DIC(0)=DIC(0)_"A",DIC("A")="Select another "_PSGT_": " S X=PSGDC_"("""_$S($G(PSGDCT)=3:$P(Y(0),U),1:+Y)_""")",@X=Y(0,0)
F D ^DIC Q:Y<0 S DIC(0)=DIC(0)_"A",DIC("A")="Select another "_PSGT_": " S X=PSGDC_"("""_$S($G(PSGDCT)=3:$P(Y(0),U),1:+Y)_""")",@X=Y(0,0)
Q
;
LC ;Convert data to lower case wording
F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A,$E(X,%-1)'="V" S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGDCT 4358 printed Sep 23, 2025@19:37:08 Page 2
PSGDCT ;BIR/CML3-DRUG COST TOTALS ; 24 Mar 98 / 10:10 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**9,50,91**;16 DEC 97
+2 ; Reference to ^PS(50.606 supported by DBIA# 2174.
+3 ; Reference to ^PS(50.7 supported by DBIA# 2180.
+4 ; Reference to ^PS(50.605 is supported by DBIA# 2138.
+5 ; Reference to ^PSDRUG is supported by DBIA# 2192.
+6 ;
+7 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
+8 SET HLP="DRUG COST"
DO ENDTS^PSGAMS
if 'SD!'FD
GOTO DONE
KILL PSGERR
DO QUES
IF $DATA(PSGERR)
WRITE " not selected, DRUG report terminated...",$CHAR(7)
GOTO DONE
+9 SET RTN="DCT"
DO EN3^PSGTI
IF 'POP
IF '$DATA(IO("Q"))
DO ENQ
if IO'=IO(0)!($EXTRACT(IOST)'="C")
DO ^%ZISC
+10 ;
DONE ;
+1 DO DONE1^PSGDCTP
+2 QUIT
+3 ;
ENQ ;
+1 DO ^PSGDCT1
DO ^PSGDCTP
+2 QUIT
+3 ;
QUES ;
+1 KILL DIR,PSGDCLW
SET DIR(0)="Y"
SET DIR("A")="Select by Ward? (Y/N):"
SET DIR("B")="NO"
SET DIR("??")="^D WDHLP^PSGDCT1"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSGERR=1
WRITE !!,"...Ward"
QUIT
+2 IF Y
Begin DoDot:1
+3 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select WARD: "
SET DIR("B")="ALL"
SET DIR("?")="^D DIC^PSGDCT(""^DIC(42,"",""PSGDCLW"",""WARD"")"
WRITE !!
DO ^DIR
KILL DIR
IF Y="ALL"
SET PSGDCLW="ALL"
QUIT
+4 DO DIC("^DIC(42,","PSGDCLW","WARD")
if '$ORDER(PSGDCLW(0))
KILL PSGDCLW
End DoDot:1
if '$DATA(PSGDCLW)
GOTO QUES
+5 ;
+6 ; ask 'sort by', 'cost limit', and 'dispensing amount limit' questions
+7 KILL DIR
SET DIR(0)="SAO^1:DISPENSE DRUG;2:ORDERABLE ITEM;3:VA CLASS"
SET DIR("A")="Select drugs by DISPENSE DRUG, ORDERABLE ITEM, or VA CLASS: "
SET DIR("?")="^D ENQH^PSGDCT1"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET PSGERR=1
WRITE !!,"...Select category"
QUIT
+8 SET PSGDCT=Y
SET PSGDCT(1)=$SELECT(PSGDCT=1:"DISPENSED DRUG",PSGDCT=2:"ORDERABLE ITEM",1:"VA CLASS")
SET X=PSGDCT(1)
DO LC
SET PSGDCT(2)=X
KILL X,Y
+9 ;
SH ;Select entries to be included..
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select "_PSGDCT(2)_": "
SET DIR("B")="ALL"
SET PSG=$SELECT(PSGDCT=1:"^PSDRUG(",PSGDCT=2:"^PS(50.7,",1:"^PS(50.605,")
SET DIR("?")="^D DIC^PSGDCT("""_PSG_""",""PSGDCLW"","""_PSGDCT(1)_""")"
+2 WRITE !!
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE !!,"...",PSGDCT(1)," not selected"
SET PSGERR=1
QUIT
+3 IF Y="ALL"
SET PSGDCTD=Y
+4 IF '$TEST
DO DIC(PSG,"PSGDCTD",PSGDCT(1))
if $ORDER(PSGDCTD(0))=""
GOTO SH
+5 IF PSGDCT>1
DO DISP
if $DATA(PSGERR)
QUIT
+6 ;
SB ;
+1 IF $GET(PSGDCTD)'="ALL"
Begin DoDot:1
+2 SET Y=""
FOR X=0:1
SET Y=$ORDER(PSGDCTD(Y))
if Y=""
QUIT
End DoDot:1
IF X<2
SET PSGDCTS="N"
SET (PSGDCTA,PSGDCTL)=""
QUIT
+3 KILL DIR
SET DIR(0)="SOA^1:"_PSGDCT(1)_";2:COST;3:AMOUNT DISPENSED"
SET DIR("A")="Sort drugs by "_PSGDCT(1)_", COST, or AMOUNT DISPENSED: "
SET DIR("??")="^D SBCHK^PSGDCT1"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE !!,"...Sort order"
SET PSGERR=1
QUIT
+4 SET PSGDCTS=$SELECT(Y=3:"A",Y=2:"C",1:"N")
+5 ;
CL FOR
READ !!,"Print all drugs costing at least? ",PSGDCTL:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET PSGDCTL="^"
if "^"[PSGDCTL!(PSGDCTL?.1"-".N.1".".2N)
QUIT
if PSGDCTL?1."?"
DO CLM^PSGDCT1
if PSGDCTL'?1."?"
WRITE $CHAR(7),$CHAR(7)," ??"
+1 if PSGDCTL=""
WRITE " (ALL)"
IF PSGDCTL="^"
SET PSGERR=1
WRITE !!,"...Cost limit"
SET PSGERR=1
QUIT
+2 ;
AL FOR
READ !!,"Print all drugs with a dispensing amount of at least? ",PSGDCTA:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET PSGDCTA="^"
if "^"[PSGDCTA!(PSGDCTA?.1"-"1.N)
QUIT
if PSGDCTA?1."?"
DO ALM^PSGDCT1
if PSGDCTA'?1."?"
WRITE $CHAR(7),$CHAR(7)," ??"
+1 if PSGDCTA=""
WRITE " (ALL)"
IF PSGDCTA="^"
WRITE !!,"...Dispensing amount"
SET PSGERR=1
QUIT
+2 QUIT
+3 ;
DISP ;view dispensed drugs
+1 FOR
WRITE !!,"Display the dispense drugs"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !!,"Answer 'YES' and I will display the dispensed drugs associated with the ",!,PSGDCT(1)," or answer 'NO' and only the totals will be displayed.",!
+2 IF %<0
SET PSGERR=1
WRITE !!,"...Dispense drug display"
QUIT
+3 KILL PSGDISP
if %=1
SET PSGDISP=1
+4 QUIT
+5 ;
DIC(PSG,PSGDC,PSGT) ;LooK up a ward or report types.
+1 KILL DIC,@PSGDC
SET @PSGDC=1
SET DIC=PSG
SET DIC(0)="QEMZ"
+2 ;if Orderable Item, display the IV identifier
+3 IF DIC="^PS(50.7,"
Begin DoDot:1
+4 ;/IV flag and Identifier is no longer used after POE changes
+5 ;/S PSJIDD=$P($G(^PS(59.7,1,31)),"^",2)
+6 ;/S DIC("W")="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_$S($P(^PS(50.7,+Y,0),""^"",3):"" ""_$G(PSJIDD),1:"""")_"
+7 SET DIC("W")="W "" ""_$P(^PS(50.606,$P(^PS(50.7,+Y,0),""^"",2),0),""^"")_"
+8 SET DIC("W")=DIC("W")_""" ""_$S($P(^PS(50.7,+Y,0),""^"",4):$E($P(^(0),""^"",4),4,5)_""-""_$E($P(^(0),""^"",4),6,7)_""-""_$E($P(^(0),""^"",4),2,3),1:"""")"
End DoDot:1
+9 ;/F D ^DIC K PSJIDD Q:Y<0 S DIC(0)=DIC(0)_"A",DIC("A")="Select another "_PSGT_": " S X=PSGDC_"("""_$S($G(PSGDCT)=3:$P(Y(0),U),1:+Y)_""")",@X=Y(0,0)
+10 FOR
DO ^DIC
if Y<0
QUIT
SET DIC(0)=DIC(0)_"A"
SET DIC("A")="Select another "_PSGT_": "
SET X=PSGDC_"("""_$SELECT($GET(PSGDCT)=3:$PIECE(Y(0),U),1:+Y)_""")"
SET @X=Y(0,0)
+11 QUIT
+12 ;
LC ;Convert data to lower case wording
+1 FOR %=2:1:$LENGTH(X)
IF $EXTRACT(X,%)?1U
IF $EXTRACT(X,%-1)?1A
IF $EXTRACT(X,%-1)'="V"
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)+32)_$EXTRACT(X,%+1,999)
+2 QUIT
