PSGWEXR1 ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU ; 23 Mar 93 / 12:51 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
PRINT ;ENTRY POINT WHEN QUEUED
S PG=0,$P(LN,"-",80)="",(AOU,AOUNM,QFLG)=""
I CNT<2 S AOU=$O(AOULP(AOU)),AOUNM=$P(^PSI(58.1,AOU,0),"^")
PRT S TAB=$S(CNT<2:(80-(32+$L(AOUNM)))*.5,1:26) D HDR
I '$D(^TMP("PSGWEXR",$J)) W !!,"NO DATA FOUND FOR THIS REPORT" G DONE
F EXDT=0:0 S EXDT=$O(^TMP("PSGWEXR",$J,EXDT)) Q:'EXDT!(QFLG) D W1 Q:QFLG S P1="" F JJ=0:0 S P1=$O(^TMP("PSGWEXR",$J,EXDT,P1)) Q:P1="" D W2 Q:QFLG I CNT>1 S P2="" D W3 Q:QFLG
DONE I $E(IOST)'="C" W @IOF
I $E(IOST)="C" D:'QFLG SS^PSGWUTL1
QUIT K %,%H,%I,%Z,AOU,ANS,QFLG,AOULP,AOUNM,BDT,DRG,DRGNM,EDT,EXDT,HDT,HH,JJ,LN,PG,X,Y,SEL,IGDA,CNT,SORT,P1,P2,G,TAB,ZTSK,IO("Q"),^TMP("PSGWEXR",$J) D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@" Q
W1 ;
D:$Y+5>IOSL PRTCHK Q:QFLG S Y=EXDT X ^DD("DD") W !!,"=> ",Y Q
W2 ;
D:$Y+5>IOSL PRTCHK Q:QFLG W:CNT>1 ! W !?12,P1 Q
W3 ;
F HH=0:0 S P2=$O(^TMP("PSGWEXR",$J,EXDT,P1,P2)) Q:P2="" D:$Y+5>IOSL PRTCHK Q:QFLG W !,?25,P2
Q
HDR ;PRINT REPORT MAIN HEADER
S PG=PG+1 S HDT=$$PSGWDT^PSGWUTL1 W:$Y @IOF W !?TAB,"DRUG EXPIRATION DATE REPORT" I CNT<2 W " for ",AOUNM
W ?70,"PAGE ",PG,!?22,"FOR PERIOD " S Y=BDT X ^DD("DD") W Y," TO " S Y=EDT X ^DD("DD") W Y,!?27,"PRINTED ",HDT,!!
I $D(SEL),SEL="I",$D(IGDA) W "FOR INVENTORY GROUP - ",$P(^PSI(58.2,IGDA,0),"^"),!
W "=> DATE",!?12
I CNT<2 W "ITEM",!,LN Q
I SORT=1 W "ITEM",!?25,"AOU",!,LN Q
W "AOU",!?25,"ITEM",!,LN Q
PRTCHK ;
I $E(IOST)="C" W !!,"Press <RETURN> to Continue or ""^"" to Exit: " R ANS:DTIME S:'$T ANS="^" D:ANS?1."?" HELP^PSGWUTL1 I ANS="^" S QFLG=1 Q
D HDR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWEXR1 1712 printed Oct 16, 2024@17:40:11 Page 2
PSGWEXR1 ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU ; 23 Mar 93 / 12:51 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
PRINT ;ENTRY POINT WHEN QUEUED
+1 SET PG=0
SET $PIECE(LN,"-",80)=""
SET (AOU,AOUNM,QFLG)=""
+2 IF CNT<2
SET AOU=$ORDER(AOULP(AOU))
SET AOUNM=$PIECE(^PSI(58.1,AOU,0),"^")
PRT SET TAB=$SELECT(CNT<2:(80-(32+$LENGTH(AOUNM)))*.5,1:26)
DO HDR
+1 IF '$DATA(^TMP("PSGWEXR",$JOB))
WRITE !!,"NO DATA FOUND FOR THIS REPORT"
GOTO DONE
+2 FOR EXDT=0:0
SET EXDT=$ORDER(^TMP("PSGWEXR",$JOB,EXDT))
if 'EXDT!(QFLG)
QUIT
DO W1
if QFLG
QUIT
SET P1=""
FOR JJ=0:0
SET P1=$ORDER(^TMP("PSGWEXR",$JOB,EXDT,P1))
if P1=""
QUIT
DO W2
if QFLG
QUIT
IF CNT>1
SET P2=""
DO W3
if QFLG
QUIT
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
if 'QFLG
DO SS^PSGWUTL1
QUIT KILL %,%H,%I,%Z,AOU,ANS,QFLG,AOULP,AOUNM,BDT,DRG,DRGNM,EDT,EXDT,HDT,HH,JJ,LN,PG,X,Y,SEL,IGDA,CNT,SORT,P1,P2,G,TAB,ZTSK,IO("Q"),^TMP("PSGWEXR",$JOB)
DO ^%ZISC
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
W1 ;
+1 if $Y+5>IOSL
DO PRTCHK
if QFLG
QUIT
SET Y=EXDT
XECUTE ^DD("DD")
WRITE !!,"=> ",Y
QUIT
W2 ;
+1 if $Y+5>IOSL
DO PRTCHK
if QFLG
QUIT
if CNT>1
WRITE !
WRITE !?12,P1
QUIT
W3 ;
+1 FOR HH=0:0
SET P2=$ORDER(^TMP("PSGWEXR",$JOB,EXDT,P1,P2))
if P2=""
QUIT
if $Y+5>IOSL
DO PRTCHK
if QFLG
QUIT
WRITE !,?25,P2
+2 QUIT
HDR ;PRINT REPORT MAIN HEADER
+1 SET PG=PG+1
SET HDT=$$PSGWDT^PSGWUTL1
if $Y
WRITE @IOF
WRITE !?TAB,"DRUG EXPIRATION DATE REPORT"
IF CNT<2
WRITE " for ",AOUNM
+2 WRITE ?70,"PAGE ",PG,!?22,"FOR PERIOD "
SET Y=BDT
XECUTE ^DD("DD")
WRITE Y," TO "
SET Y=EDT
XECUTE ^DD("DD")
WRITE Y,!?27,"PRINTED ",HDT,!!
+3 IF $DATA(SEL)
IF SEL="I"
IF $DATA(IGDA)
WRITE "FOR INVENTORY GROUP - ",$PIECE(^PSI(58.2,IGDA,0),"^"),!
+4 WRITE "=> DATE",!?12
+5 IF CNT<2
WRITE "ITEM",!,LN
QUIT
+6 IF SORT=1
WRITE "ITEM",!?25,"AOU",!,LN
QUIT
+7 WRITE "AOU",!?25,"ITEM",!,LN
QUIT
PRTCHK ;
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Press <RETURN> to Continue or ""^"" to Exit: "
READ ANS:DTIME
if '$TEST
SET ANS="^"
if ANS?1."?"
DO HELP^PSGWUTL1
IF ANS="^"
SET QFLG=1
QUIT
+2 DO HDR
QUIT
