PSDEXP1 ;BIR/JPW-CS Drug Expiration Date Report (cont'd) ; 2 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
U IO
PRINT ;print cs exp date report
S (PG,PSDOUT)=0
K LN S $P(LN,"-",80)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
D HDR
I '$D(^TMP("PSDEXP",$J)) W !!,?15,"**** NO DRUG EXPIRATION DATA FOR THIS REPORT ****" G END
F PSD=0:0 S PSD=$O(^TMP("PSDEXP",$J,PSD)) Q:'PSD!(PSDOUT) D:$Y+5>IOSL HDR Q:PSDOUT S Y=PSD X ^DD("DD") W !!,"=> ",Y D
.S PSD1="" F S PSD1=$O(^TMP("PSDEXP",$J,PSD,PSD1)) Q:PSD1=""!(PSDOUT) D:$Y+5>IOSL HDR Q:PSDOUT W !,?12,PSD1 D
..S PSD2="" F S PSD2=$O(^TMP("PSDEXP",$J,PSD,PSD1,PSD2)) Q:PSD2=""!(PSDOUT) S PSD3="" F S PSD3=$O(^TMP("PSDEXP",$J,PSD,PSD1,PSD2,PSD3)) Q:PSD3=""!(PSDOUT) D:$Y+5>IOSL HDR Q:PSDOUT W !,?14,$S(PSD3'="N/A":PSD3,1:""),?25,PSD2
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,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD
K PG,POP,PSD,PSDT,PSD1,PSD2,PSD3,PSDATE,PSDED,PSDIO,PSDOUT,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDEXP",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR ;header for log
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 !,?27,"CS DRUG EXPIRATION DATE REPORT",?70,"Page: ",PG
W !,?22,"FOR PERIOD ",$P(PSDATE,"^")," TO ",$P(PSDATE,"^",2)
W !,?27,"PRINTED ",RPDT,!!,"=> DATE",!,?12
I ANS="D" W "DRUG",!,?14,"DISP #",?25,"NAOU",!,LN Q
W "NAOU",!,?14,"DISP #",?25,"ITEM",!,LN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEXP1 1652 printed Dec 13, 2024@01:46 Page 2
PSDEXP1 ;BIR/JPW-CS Drug Expiration Date Report (cont'd) ; 2 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
+2 USE IO
PRINT ;print cs exp date report
+1 SET (PG,PSDOUT)=0
+2 KILL LN
SET $PIECE(LN,"-",80)=""
DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET RPDT=Y
+3 DO HDR
+4 IF '$DATA(^TMP("PSDEXP",$JOB))
WRITE !!,?15,"**** NO DRUG EXPIRATION DATA FOR THIS REPORT ****"
GOTO END
+5 FOR PSD=0:0
SET PSD=$ORDER(^TMP("PSDEXP",$JOB,PSD))
if 'PSD!(PSDOUT)
QUIT
if $Y+5>IOSL
DO HDR
if PSDOUT
QUIT
SET Y=PSD
XECUTE ^DD("DD")
WRITE !!,"=> ",Y
Begin DoDot:1
+6 SET PSD1=""
FOR
SET PSD1=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1))
if PSD1=""!(PSDOUT)
QUIT
if $Y+5>IOSL
DO HDR
if PSDOUT
QUIT
WRITE !,?12,PSD1
Begin DoDot:2
+7 SET PSD2=""
FOR
SET PSD2=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1,PSD2))
if PSD2=""!(PSDOUT)
QUIT
SET PSD3=""
FOR
SET PSD3=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1,PSD2,PSD3))
if PSD3=""!(PSDOUT)
QUIT
if $Y+5>IOSL
DO HDR
if PSDOUT
QUIT
WRITE !,?14,$SELECT(PSD3'="N/A":PSD3,1:""),?25,PSD2
End DoDot:2
End DoDot:1
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,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD
+2 KILL PG,POP,PSD,PSDT,PSD1,PSD2,PSD3,PSDATE,PSDED,PSDIO,PSDOUT,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
+3 KILL ^TMP("PSDEXP",$JOB)
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
HDR ;header for log
+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 !,?27,"CS DRUG EXPIRATION DATE REPORT",?70,"Page: ",PG
+3 WRITE !,?22,"FOR PERIOD ",$PIECE(PSDATE,"^")," TO ",$PIECE(PSDATE,"^",2)
+4 WRITE !,?27,"PRINTED ",RPDT,!!,"=> DATE",!,?12
+5 IF ANS="D"
WRITE "DRUG",!,?14,"DISP #",?25,"NAOU",!,LN
QUIT
+6 WRITE "NAOU",!,?14,"DISP #",?25,"ITEM",!,LN
+7 QUIT
