- PSGWEXR2 ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU for AOUs with Locations ; 23 Mar 93 / 12:52 PM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- PRINT ;ENTRY POINT WHEN QUEUED
- S PG=0,$P(LN,"-",80)="",(AOU,AOUNM,LOCNM,QFLG)=""
- I CNT<2 S AOU=$O(AOULP(AOU)),AOUNM=$P(^PSI(58.1,AOU,0),"^"),LOCNM=$P(^SC(AOULP(AOU),0),"^"),TAB=(80-($L(AOUNM)+$L(LOCNM)+18)*.5)
- PRT 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,LOC,LOCFLG,LOCNM,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 I SORT=2 S JJ="",JJ=$O(^TMP("PSGWEXR",$J,EXDT,P1,JJ)),AOU=^(JJ),LOC=$P(^PSI(58.1,AOU,0),"^",6) I LOC W "/(",$P(^SC(LOC,0),"^"),")"
- 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 I SORT=1 S AOU=^TMP("PSGWEXR",$J,EXDT,P1,P2),LOC=$P(^PSI(58.1,AOU,0),"^",6) I LOC W "/(",$E($P(^SC(LOC,0),"^"),1,22),")"
- Q
- HDR ;PRINT REPORT MAIN HEADER
- S PG=PG+1 S HDT=$$PSGWDT^PSGWUTL1 W:$Y @IOF W !?26,"DRUG EXPIRATION DATE REPORT",?70,"PAGE ",PG I CNT<2 W !?TAB,"FOR ",AOUNM," (LOCATION - ",LOCNM,")"
- W !?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/(LOCATION)",!,LN Q
- W "AOU/(LOCATION)",!?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[HPSGWEXR2 2090 printed Feb 18, 2025@23:05:44 Page 2
- PSGWEXR2 ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU for AOUs with Locations ; 23 Mar 93 / 12:52 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,LOCNM,QFLG)=""
- +2 IF CNT<2
- SET AOU=$ORDER(AOULP(AOU))
- SET AOUNM=$PIECE(^PSI(58.1,AOU,0),"^")
- SET LOCNM=$PIECE(^SC(AOULP(AOU),0),"^")
- SET TAB=(80-($LENGTH(AOUNM)+$LENGTH(LOCNM)+18)*.5)
- PRT 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,LOC,LOCFLG,LOCNM,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
- IF SORT=2
- SET JJ=""
- SET JJ=$ORDER(^TMP("PSGWEXR",$JOB,EXDT,P1,JJ))
- SET AOU=^(JJ)
- SET LOC=$PIECE(^PSI(58.1,AOU,0),"^",6)
- IF LOC
- WRITE "/(",$PIECE(^SC(LOC,0),"^"),")"
- +2 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
- IF SORT=1
- SET AOU=^TMP("PSGWEXR",$JOB,EXDT,P1,P2)
- SET LOC=$PIECE(^PSI(58.1,AOU,0),"^",6)
- IF LOC
- WRITE "/(",$EXTRACT($PIECE(^SC(LOC,0),"^"),1,22),")"
- +2 QUIT
- HDR ;PRINT REPORT MAIN HEADER
- +1 SET PG=PG+1
- SET HDT=$$PSGWDT^PSGWUTL1
- if $Y
- WRITE @IOF
- WRITE !?26,"DRUG EXPIRATION DATE REPORT",?70,"PAGE ",PG
- IF CNT<2
- WRITE !?TAB,"FOR ",AOUNM," (LOCATION - ",LOCNM,")"
- +2 WRITE !?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/(LOCATION)",!,LN
- QUIT
- +7 WRITE "AOU/(LOCATION)",!?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
