- PSDEXP ;BIR/BJW-CS Drug Expiration Date Report ; 10 Feb 98
- ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- ;**Y2K compliance**,"P" added to date input string
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- S OK=$S($D(^XUSEC("PSJ RPHARM",DUZ)):1,$D(^XUSEC("PSJ PHARM TECH",DUZ)):1,1:0)
- I 'OK W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to print",!,?12,"CS reports. PSJ RPHARM or PSJ PHARM TECH security key required.",! K OK Q
- W !!,"Controlled Substances Expiration Date Report",!!
- DATE ;ask date range
- W ! K %DT S %DT="AEP",%DT("A")="Start with Date: " D ^%DT I Y<0 S PSDOUT=1 G END
- S PSDSD=Y D D^DIQ S PSDATE=Y,%DT("A")="End with Date: " D ^%DT I Y<0 S PSDOUT=1 G END
- I Y<PSDSD W !!,"The ending date of the range must be later than the starting date." G DATE
- S PSDED=Y D D^DIQ S PSDATE=PSDATE_"^"_Y,PSDSD=$E(PSDSD,1,5)_"00"-.1,PSDED=$E(PSDED,1,5)_"31"+.9999
- ASKN ;ask NAOU(s)
- W !!,?5,"You may select a single NAOU, several NAOUs,",!,?5,"or enter ^ALL to select all NAOUs.",!
- D NOW^%DTC S PSDT=X K DA,DIC
- F S DIC=58.8,DIC("A")="Select NAOU: ",DIC(0)="QEA",DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>PSDT:1,1:0),$P(^(0),""^"",2)'=""P"",$P(^(0),""^"",3)=+PSDSITE" D ^DIC K DIC Q:Y<0 S NAOU(+Y)=""
- I '$D(NAOU)&(X'="^ALL") G END
- 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)'="P",$P($G(^(0)),"^",3)=+PSDSITE S NAOU(PSD)=""
- F JJ="" F CNT=0:1 S JJ=$O(NAOU(JJ)) Q:'JJ
- I CNT=1 S ANS="D" G DEV
- SORT ;asks sort
- K DA,DIR,DIRUT S DIR(0)="SO^D:DATE/DRUG/NAOU;N:DATE/NAOU/DRUG",DIR("A",1)="You may print by either of these sorting methods."
- S DIR("?",1)="Enter 'D' if you wish to print the Expiration date list sorted by DATE",DIR("?",2)=" and within DATE by DRUG then NAOU."
- S DIR("?")="Enter 'N' to print by DATE and within DATE by NAOU then DRUG."
- S DIR("A")="Select SORT ORDER for Report" D ^DIR K DIR G:$D(DIRUT) END S ANS=Y
- DEV ;dev & queue info
- W !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!!
- K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G END
- I $D(IO("Q")) K IO("Q"),ZTSAVE,ZTDTH,ZTSK S PSDIO=ION,ZTIO="",ZTRTN="START^PSDEXP",ZTDESC="CS Drug Expiration Date Report" D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
- U IO
- START ;compile data
- K ^TMP("PSDEXP",$J) S PSDOUT=0
- F PSD=PSDSD:0 S PSD=$O(^PSD(58.8,"AEXP",PSD)) Q:'PSD!(PSD>PSDED) F DRUG=0:0 S DRUG=$O(^PSD(58.8,"AEXP",PSD,DRUG)) Q:'DRUG F NAOU=0:0 S NAOU=$O(^PSD(58.8,"AEXP",PSD,DRUG,NAOU)) Q:'NAOU I $D(NAOU(NAOU)) D SET
- F PSD=PSDSD:0 S PSD=$O(^PSD(58.8,"AEXPO",PSD)) Q:'PSD!(PSD>PSDED) F DRUG=0:0 S DRUG=$O(^PSD(58.8,"AEXPO",PSD,DRUG)) Q:'DRUG F NAOU=0:0 S NAOU=$O(^PSD(58.8,"AEXPO",PSD,DRUG,NAOU)) Q:'NAOU I $D(NAOU(NAOU)) D
- .F ORD=0:0 S ORD=$O(^PSD(58.8,"AEXPO",PSD,DRUG,NAOU,ORD)) Q:'ORD D SET
- G:'$D(ZTQUEUED) PRINT^PSDEXP1
- PRTQUE ;que print after compile
- K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="Print CS Drug Expiration Date Report",ZTRTN="PRINT^PSDEXP1",ZTDTH=$H
- S ZTSAVE("^TMP(""PSDEXP"",$J,")="",ZTSAVE("PSDATE")="",ZTSAVE("CNT")="",ZTSAVE("ANS")=""
- D ^%ZTLOAD K ^TMP("PSDEXP",$J)
- END ;
- K %,%DT,%H,%I,%ZIS,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD
- K PG,POP,PSD,PSDT,PSDATE,PSDED,PSDIO,PSDOUT,PSDPN,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- K ^TMP("PSDEXP",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- SAVE S (ZTSAVE("PSDSITE"),ZTSAVE("PSDSD"),ZTSAVE("PSDED"),ZTSAVE("PSDATE"),ZTSAVE("PSDIO"),ZTSAVE("ANS"),ZTSAVE("CNT"))=""
- S:$D(NAOU) ZTSAVE("NAOU(")=""
- Q
- SET ;set data for printing
- S PSDPN="N/A"
- S DRUGN=$S($D(^PSDRUG(DRUG,0)):$P(^(0),"^"),1:"DRUG NAME MISSING")
- S NAOUN=$S($D(^PSD(58.8,NAOU,0)):$P(^(0),"^"),1:"NAOU NAME MISSING")
- S TYPE=$P($G(^PSD(58.8,NAOU,0)),"^",2) I TYPE'="N"!(TYPE="N"&'$D(ORD)) D TMP Q
- Q:'$D(^PSD(58.8,NAOU,1,DRUG,3,ORD,0)) S NODE=^(0)
- Q:+$P(NODE,"^",11)'=4&(+$P(NODE,U,11)'=13) S PSDPN=$S($P(NODE,"^",16)]"":$P(NODE,"^",16),1:"N/A") D TMP
- Q
- TMP ;set ^TMP
- I ANS="D"!(CNT<2) S ^TMP("PSDEXP",$J,PSD,DRUGN,NAOUN,PSDPN)="" Q
- S:ANS="N" ^TMP("PSDEXP",$J,PSD,NAOUN,DRUGN,PSDPN)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEXP 4259 printed Mar 13, 2025@20:50:40 Page 2
- PSDEXP ;BIR/BJW-CS Drug Expiration Date Report ; 10 Feb 98
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- +2 ;**Y2K compliance**,"P" added to date input string
- +3 IF '$DATA(PSDSITE)
- DO ^PSDSET
- if '$DATA(PSDSITE)
- QUIT
- +4 SET OK=$SELECT($DATA(^XUSEC("PSJ RPHARM",DUZ)):1,$DATA(^XUSEC("PSJ PHARM TECH",DUZ)):1,1:0)
- +5 IF 'OK
- WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to print",!,?12,"CS reports. PSJ RPHARM or PSJ PHARM TECH security key required.",!
- KILL OK
- QUIT
- +6 WRITE !!,"Controlled Substances Expiration Date Report",!!
- DATE ;ask date range
- +1 WRITE !
- KILL %DT
- SET %DT="AEP"
- SET %DT("A")="Start with Date: "
- DO ^%DT
- IF Y<0
- SET PSDOUT=1
- GOTO END
- +2 SET PSDSD=Y
- DO D^DIQ
- SET PSDATE=Y
- SET %DT("A")="End with Date: "
- DO ^%DT
- IF Y<0
- SET PSDOUT=1
- GOTO END
- +3 IF Y<PSDSD
- WRITE !!,"The ending date of the range must be later than the starting date."
- GOTO DATE
- +4 SET PSDED=Y
- DO D^DIQ
- SET PSDATE=PSDATE_"^"_Y
- SET PSDSD=$EXTRACT(PSDSD,1,5)_"00"-.1
- SET PSDED=$EXTRACT(PSDED,1,5)_"31"+.9999
- ASKN ;ask NAOU(s)
- +1 WRITE !!,?5,"You may select a single NAOU, several NAOUs,",!,?5,"or enter ^ALL to select all NAOUs.",!
- +2 DO NOW^%DTC
- SET PSDT=X
- KILL DA,DIC
- +3 FOR
- SET DIC=58.8
- SET DIC("A")="Select NAOU: "
- SET DIC(0)="QEA"
- SET DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>PSDT:1,1:0),$P(^(0),""^"",2)'=""P"",$P(^(0),""^"",3)=+PSDSITE"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET NAOU(+Y)=""
- +4 IF '$DATA(NAOU)&(X'="^ALL")
- GOTO END
- +5 IF X="^ALL"
- FOR PSD=0:0
- SET PSD=$ORDER(^PSD(58.8,PSD))
- if 'PSD
- QUIT
- IF $SELECT('$DATA(^PSD(58.8,PSD,"I")):1,'^("I"):1,+^("I")>PSDT:1,1:0)
- IF $PIECE($GET(^(0)),"^",2)'="P"
- IF $PIECE($GET(^(0)),"^",3)=+PSDSITE
- SET NAOU(PSD)=""
- +6 FOR JJ=""
- FOR CNT=0:1
- SET JJ=$ORDER(NAOU(JJ))
- if 'JJ
- QUIT
- +7 IF CNT=1
- SET ANS="D"
- GOTO DEV
- SORT ;asks sort
- +1 KILL DA,DIR,DIRUT
- SET DIR(0)="SO^D:DATE/DRUG/NAOU;N:DATE/NAOU/DRUG"
- SET DIR("A",1)="You may print by either of these sorting methods."
- +2 SET DIR("?",1)="Enter 'D' if you wish to print the Expiration date list sorted by DATE"
- SET DIR("?",2)=" and within DATE by DRUG then NAOU."
- +3 SET DIR("?")="Enter 'N' to print by DATE and within DATE by NAOU then DRUG."
- +4 SET DIR("A")="Select SORT ORDER for Report"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET ANS=Y
- DEV ;dev & queue info
- +1 WRITE !!,"This report is designed for a 80 column format.",!,"You may queue this report to print at a later time.",!!
- +2 KILL %ZIS,IOP,IO("Q"),POP
- SET %ZIS="QM"
- SET %ZIS("B")=""
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
- GOTO END
- +3 IF $DATA(IO("Q"))
- KILL IO("Q"),ZTSAVE,ZTDTH,ZTSK
- SET PSDIO=ION
- SET ZTIO=""
- SET ZTRTN="START^PSDEXP"
- SET ZTDESC="CS Drug Expiration Date Report"
- DO SAVE
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO END
- +4 USE IO
- START ;compile data
- +1 KILL ^TMP("PSDEXP",$JOB)
- SET PSDOUT=0
- +2 FOR PSD=PSDSD:0
- SET PSD=$ORDER(^PSD(58.8,"AEXP",PSD))
- if 'PSD!(PSD>PSDED)
- QUIT
- FOR DRUG=0:0
- SET DRUG=$ORDER(^PSD(58.8,"AEXP",PSD,DRUG))
- if 'DRUG
- QUIT
- FOR NAOU=0:0
- SET NAOU=$ORDER(^PSD(58.8,"AEXP",PSD,DRUG,NAOU))
- if 'NAOU
- QUIT
- IF $DATA(NAOU(NAOU))
- DO SET
- +3 FOR PSD=PSDSD:0
- SET PSD=$ORDER(^PSD(58.8,"AEXPO",PSD))
- if 'PSD!(PSD>PSDED)
- QUIT
- FOR DRUG=0:0
- SET DRUG=$ORDER(^PSD(58.8,"AEXPO",PSD,DRUG))
- if 'DRUG
- QUIT
- FOR NAOU=0:0
- SET NAOU=$ORDER(^PSD(58.8,"AEXPO",PSD,DRUG,NAOU))
- if 'NAOU
- QUIT
- IF $DATA(NAOU(NAOU))
- Begin DoDot:1
- +4 FOR ORD=0:0
- SET ORD=$ORDER(^PSD(58.8,"AEXPO",PSD,DRUG,NAOU,ORD))
- if 'ORD
- QUIT
- DO SET
- End DoDot:1
- +5 if '$DATA(ZTQUEUED)
- GOTO PRINT^PSDEXP1
- PRTQUE ;que print after compile
- +1 KILL ZTSAVE,ZTIO
- SET ZTIO=PSDIO
- SET ZTRTN="Print CS Drug Expiration Date Report"
- SET ZTRTN="PRINT^PSDEXP1"
- SET ZTDTH=$HOROLOG
- +2 SET ZTSAVE("^TMP(""PSDEXP"",$J,")=""
- SET ZTSAVE("PSDATE")=""
- SET ZTSAVE("CNT")=""
- SET ZTSAVE("ANS")=""
- +3 DO ^%ZTLOAD
- KILL ^TMP("PSDEXP",$JOB)
- END ;
- +1 KILL %,%DT,%H,%I,%ZIS,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD
- +2 KILL PG,POP,PSD,PSDT,PSDATE,PSDED,PSDIO,PSDOUT,PSDPN,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- +3 KILL ^TMP("PSDEXP",$JOB)
- DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- SAVE SET (ZTSAVE("PSDSITE"),ZTSAVE("PSDSD"),ZTSAVE("PSDED"),ZTSAVE("PSDATE"),ZTSAVE("PSDIO"),ZTSAVE("ANS"),ZTSAVE("CNT"))=""
- +1 if $DATA(NAOU)
- SET ZTSAVE("NAOU(")=""
- +2 QUIT
- SET ;set data for printing
- +1 SET PSDPN="N/A"
- +2 SET DRUGN=$SELECT($DATA(^PSDRUG(DRUG,0)):$PIECE(^(0),"^"),1:"DRUG NAME MISSING")
- +3 SET NAOUN=$SELECT($DATA(^PSD(58.8,NAOU,0)):$PIECE(^(0),"^"),1:"NAOU NAME MISSING")
- +4 SET TYPE=$PIECE($GET(^PSD(58.8,NAOU,0)),"^",2)
- IF TYPE'="N"!(TYPE="N"&'$DATA(ORD))
- DO TMP
- QUIT
- +5 if '$DATA(^PSD(58.8,NAOU,1,DRUG,3,ORD,0))
- QUIT
- SET NODE=^(0)
- +6 if +$PIECE(NODE,"^",11)'=4&(+$PIECE(NODE,U,11)'=13)
- QUIT
- SET PSDPN=$SELECT($PIECE(NODE,"^",16)]"":$PIECE(NODE,"^",16),1:"N/A")
- DO TMP
- +7 QUIT
- TMP ;set ^TMP
- +1 IF ANS="D"!(CNT<2)
- SET ^TMP("PSDEXP",$JOB,PSD,DRUGN,NAOUN,PSDPN)=""
- QUIT
- +2 if ANS="N"
- SET ^TMP("PSDEXP",$JOB,PSD,NAOUN,DRUGN,PSDPN)=""
- +3 QUIT
