PSDEA41 ;BIR/BJW/DJE-Destroyed CS Drugs DEA 41 Report ; 15 JAN 96
;;3.0; CONTROLLED SUBSTANCES ;**12,71**;13 Feb 97;Build 29
;
; Reference to PSDRUG( DBIA # 221
;
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ))&('$D(^XUSEC("PSD TECH ADV",DUZ))) D G END
.W !!,"Please contact your Pharmacy Coordinator for access to",!,"the pending Controlled Substances destruction data.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
ASKD ;ask disp location
S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
ASKV ;ask vault(s),added 8/9/95
W !!,?5,"You may select a single VAULT, several VAULT(s),",!,?5,"or enter ^ALL to select all VAULT(s).",!
K DA,DIC D NOW^%DTC S (PSDT,Y)=X X ^DD("DD") S RPDT=Y
F S DIC=58.8,DIC("A")="Select VAULT: ",DIC(0)="QEA",DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>PSDT:1,1:0),$P(^(0),""^"",2)'=""N"",$P(^(0),""^"",3)=+PSDSITE" D ^DIC K DIC S PSDVAU(+Y)="" Q:Y<0
I '$D(PSDVAU)&(X'="^ALL") G END
; Patch PSD*3*12
; Removal of the following code that checks for the presence of a vault
; after a certain date ie. inactivated vaults. Removed code:
; $S('$D(^PSD(58.8,PSD,"I")):1,'^("I"):1,+^("I")>PSDT:1,1:0),1:0)
; Old code:
;I X="^ALL" F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $S('$D(^PSD(58.8,PSD,"I")):1,'^("I"):1,+^("I")>PSDT:1,1:0),$P($G(^(0)),"^",2)'="N",$P($G(^(0)),"^",3)=+PSDSITE S PSDVAU(PSD)=""
I X="^ALL" F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $P($G(^PSD(58.8,PSD,0)),"^",2)'="N",$P($G(^(0)),"^",3)=+PSDSITE S PSDVAU(PSD)=""
S JJ=$O(PSDVAU(0)),JJ=$S($O(PSDVAU(JJ)):1,1:2)
S DIC="^DIC(4,",DR=.01,DA=+$P($G(^XMB(1,1,"XUS")),U,17),DIQ="PSD"
D EN^DIQ1 S PSD=PSD(4,DA,.01) K DIC,DR,DA,DIQ
S PSDSN=$S(JJ=1:PSD,1:$P($G(^PSD(58.8,+$O(PSDVAU(0)),0)),U)) K PSD
DEV ;select device
W !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!!
S Y=$P($G(^PSD(58.8,+PSDS,2)),"^",9),C=$P(^DD(58.8,24,0),"^",2) D Y^DIQ S PSDEV=Y
K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")=PSDEV D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G END
I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSDEA41",ZTDESC="Destroyed CS Drug Report for DEA Form 41" D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
U IO
START ;start looping
K ^TMP("PSDEA41",$J)
D NOW^%DTC S Y=X X ^DD("DD") S RPDT=Y
K LN S (CNT,PG,PSDOUT)=0,$P(LN,"-",80)="" D HDR
F PSDA=0:0 S PSDA=$O(^PSD(58.86,PSDA)) Q:'PSDA I $D(^PSD(58.86,PSDA,0)),$D(PSDVAU(+$P(^(0),"^",7))),'$P(^(0),"^",11),'$D(^PSD(58.86,PSDA,3)) D SET
I CNT=0 W !!,?10,"*** NO CONTROLLED SUBSTANCE DESTRUCTIONS ***",!! G DONE
PRINT ;prints data
D SIG G:PSDOUT DONE
F PSDA=0:0 S PSDA=$O(^TMP("PSDEA41",$J,PSDA)) Q:'PSDA D Q:PSDOUT
.D:$Y+4>IOSL HDR Q:PSDOUT
.S NODE=^TMP("PSDEA41",$J,PSDA) W !,PSDA,?10,$P(NODE,"^"),?55,$J($P(NODE,"^",2),3),?60,$J($P(NODE,"^",3),6),?69,$P(NODE,"^",4)
I 'PSDOUT D:$Y+4>IOSL HDR W !!,?25,"END OF REPORT!!",!
DONE I $E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
END ;
K %,%DT,%H,%I,%ZIS,ALL,C,CNT,CONT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,JJ,KK,LN,NODE
K PG,POP,PSD,PSDA,PSDT,PSDATE,PSDED,PSDEV,PSDN,PSDOUT,PSDR,PSDRN,PSDS,PSDSD,PSDSN,PSDVAU,QTY,RPDT,UNIT,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDEA41",$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR ;prints header information
I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
S PG=PG+1 W:$Y @IOF W !,?15,"DESTROYED CS DRUGS REPORT for DEA FORM 41",?70,"PAGE: ",PG
W !,?15,"Dispensing Site: ",PSDSN,!,?15,"Printed: ",RPDT
W !,?55,"# OF",!,"HOLD #",?10,"DRUG",?55,"CONT",?63,"QTY",?69,"UNIT",!,LN,!
Q
SAVE ;saves variables for queueing
S (ZTSAVE("PSDS"),ZTSAVE("PSDSN"),ZTSAVE("JJ"))=""
S:$D(ALL) ZTSAVE("ALL")="" S:$D(PSDVAU) ZTSAVE("PSDVAU(")=""
Q
SIG ;print signature lines
W !!!,?23,"Date: _____________________________________",!!!,?15,"Destroyed By: _____________________________________",!
F KK=1:1:2 W !!,?15,"Witnessed By: _____________________________________",!
W !
Q
SET ;sets data
S CNT=CNT+1
S NODE=^PSD(58.86,PSDA,0),PSDR=+$P(NODE,"^",2)
S PSDRN=$S($G(^PSD(58.86,PSDA,1))]"":$G(^PSD(58.86,PSDA,1))_"*",$P($G(^PSDRUG(+PSDR,0)),"^")]"":$P($G(^PSDRUG(+PSDR,0)),"^"),1:"#"_PSDA_" DRUG NAME MISSING")
S QTY=$P(NODE,"^",3),CONT=$P(NODE,"^",8),UNIT=$P(NODE,"^",12)
S ^TMP("PSDEA41",$J,PSDA)=PSDRN_"^"_CONT_"^"_QTY_"^"_UNIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEA41 4539 printed Dec 13, 2024@01:45:41 Page 2
PSDEA41 ;BIR/BJW/DJE-Destroyed CS Drugs DEA 41 Report ; 15 JAN 96
+1 ;;3.0; CONTROLLED SUBSTANCES ;**12,71**;13 Feb 97;Build 29
+2 ;
+3 ; Reference to PSDRUG( DBIA # 221
+4 ;
+5 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+6 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))&('$DATA(^XUSEC("PSD TECH ADV",DUZ)))
Begin DoDot:1
+7 WRITE !!,"Please contact your Pharmacy Coordinator for access to",!,"the pending Controlled Substances destruction data.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
End DoDot:1
GOTO END
ASKD ;ask disp location
+1 SET PSDS=$PIECE(PSDSITE,U,3)
SET PSDSN=$PIECE(PSDSITE,U,4)
ASKV ;ask vault(s),added 8/9/95
+1 WRITE !!,?5,"You may select a single VAULT, several VAULT(s),",!,?5,"or enter ^ALL to select all VAULT(s).",!
+2 KILL DA,DIC
DO NOW^%DTC
SET (PSDT,Y)=X
XECUTE ^DD("DD")
SET RPDT=Y
+3 FOR
SET DIC=58.8
SET DIC("A")="Select VAULT: "
SET DIC(0)="QEA"
SET DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>PSDT:1,1:0),$P(^(0),""^"",2)'=""N"",$P(^(0),""^"",3)=+PSDSITE"
DO ^DIC
KILL DIC
SET PSDVAU(+Y)=""
if Y<0
QUIT
+4 IF '$DATA(PSDVAU)&(X'="^ALL")
GOTO END
+5 ; Patch PSD*3*12
+6 ; Removal of the following code that checks for the presence of a vault
+7 ; after a certain date ie. inactivated vaults. Removed code:
+8 ; $S('$D(^PSD(58.8,PSD,"I")):1,'^("I"):1,+^("I")>PSDT:1,1:0),1:0)
+9 ; Old code:
+10 ;I X="^ALL" F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $S('$D(^PSD(58.8,PSD,"I")):1,'^("I"):1,+^("I")>PSDT:1,1:0),$P($G(^(0)),"^",2)'="N",$P($G(^(0)),"^",3)=+PSDSITE S PSDVAU(PSD)=""
+11 IF X="^ALL"
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
if 'PSD
QUIT
IF $PIECE($GET(^PSD(58.8,PSD,0)),"^",2)'="N"
IF $PIECE($GET(^(0)),"^",3)=+PSDSITE
SET PSDVAU(PSD)=""
+12 SET JJ=$ORDER(PSDVAU(0))
SET JJ=$SELECT($ORDER(PSDVAU(JJ)):1,1:2)
+13 SET DIC="^DIC(4,"
SET DR=.01
SET DA=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
SET DIQ="PSD"
+14 DO EN^DIQ1
SET PSD=PSD(4,DA,.01)
KILL DIC,DR,DA,DIQ
+15 SET PSDSN=$SELECT(JJ=1:PSD,1:$PIECE($GET(^PSD(58.8,+$ORDER(PSDVAU(0)),0)),U))
KILL PSD
DEV ;select device
+1 WRITE !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!!
+2 SET Y=$PIECE($GET(^PSD(58.8,+PSDS,2)),"^",9)
SET C=$PIECE(^DD(58.8,24,0),"^",2)
DO Y^DIQ
SET PSDEV=Y
+3 KILL %ZIS,IOP,IO("Q"),POP
SET %ZIS="QM"
SET %ZIS("B")=PSDEV
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
GOTO END
+4 IF $DATA(IO("Q"))
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="START^PSDEA41"
SET ZTDESC="Destroyed CS Drug Report for DEA Form 41"
DO SAVE
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
GOTO END
+5 USE IO
START ;start looping
+1 KILL ^TMP("PSDEA41",$JOB)
+2 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET RPDT=Y
+3 KILL LN
SET (CNT,PG,PSDOUT)=0
SET $PIECE(LN,"-",80)=""
DO HDR
+4 FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.86,PSDA))
if 'PSDA
QUIT
IF $DATA(^PSD(58.86,PSDA,0))
IF $DATA(PSDVAU(+$PIECE(^(0),"^",7)))
IF '$PIECE(^(0),"^",11)
IF '$DATA(^PSD(58.86,PSDA,3))
DO SET
+5 IF CNT=0
WRITE !!,?10,"*** NO CONTROLLED SUBSTANCE DESTRUCTIONS ***",!!
GOTO DONE
PRINT ;prints data
+1 DO SIG
if PSDOUT
GOTO DONE
+2 FOR PSDA=0:0
SET PSDA=$ORDER(^TMP("PSDEA41",$JOB,PSDA))
if 'PSDA
QUIT
Begin DoDot:1
+3 if $Y+4>IOSL
DO HDR
if PSDOUT
QUIT
+4 SET NODE=^TMP("PSDEA41",$JOB,PSDA)
WRITE !,PSDA,?10,$PIECE(NODE,"^"),?55,$JUSTIFY($PIECE(NODE,"^",2),3),?60,$JUSTIFY($PIECE(NODE,"^",3),6),?69,$PIECE(NODE,"^",4)
End DoDot:1
if PSDOUT
QUIT
+5 IF 'PSDOUT
if $Y+4>IOSL
DO HDR
WRITE !!,?25,"END OF REPORT!!",!
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSDOUT
WRITE !
KILL DIR,DIRUT
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
DO ^DIR
KILL DIR
END ;
+1 KILL %,%DT,%H,%I,%ZIS,ALL,C,CNT,CONT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,JJ,KK,LN,NODE
+2 KILL PG,POP,PSD,PSDA,PSDT,PSDATE,PSDED,PSDEV,PSDN,PSDOUT,PSDR,PSDRN,PSDS,PSDSD,PSDSN,PSDVAU,QTY,RPDT,UNIT,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 KILL ^TMP("PSDEA41",$JOB)
+4 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
HDR ;prints header information
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PG
WRITE !
KILL DA,DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 SET PG=PG+1
if $Y
WRITE @IOF
WRITE !,?15,"DESTROYED CS DRUGS REPORT for DEA FORM 41",?70,"PAGE: ",PG
+3 WRITE !,?15,"Dispensing Site: ",PSDSN,!,?15,"Printed: ",RPDT
+4 WRITE !,?55,"# OF",!,"HOLD #",?10,"DRUG",?55,"CONT",?63,"QTY",?69,"UNIT",!,LN,!
+5 QUIT
SAVE ;saves variables for queueing
+1 SET (ZTSAVE("PSDS"),ZTSAVE("PSDSN"),ZTSAVE("JJ"))=""
+2 if $DATA(ALL)
SET ZTSAVE("ALL")=""
if $DATA(PSDVAU)
SET ZTSAVE("PSDVAU(")=""
+3 QUIT
SIG ;print signature lines
+1 WRITE !!!,?23,"Date: _____________________________________",!!!,?15,"Destroyed By: _____________________________________",!
+2 FOR KK=1:1:2
WRITE !!,?15,"Witnessed By: _____________________________________",!
+3 WRITE !
+4 QUIT
SET ;sets data
+1 SET CNT=CNT+1
+2 SET NODE=^PSD(58.86,PSDA,0)
SET PSDR=+$PIECE(NODE,"^",2)
+3 SET PSDRN=$SELECT($GET(^PSD(58.86,PSDA,1))]"":$GET(^PSD(58.86,PSDA,1))_"*",$PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE($GET(^PSDRUG(+PSDR,0)),"^"),1:"#"_PSDA_" DRUG NAME MISSING")
+4 SET QTY=$PIECE(NODE,"^",3)
SET CONT=$PIECE(NODE,"^",8)
SET UNIT=$PIECE(NODE,"^",12)
+5 SET ^TMP("PSDEA41",$JOB,PSDA)=PSDRN_"^"_CONT_"^"_QTY_"^"_UNIT
+6 QUIT
