- 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 Feb 18, 2025@23:12:05 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
