- PSDRLOG2 ;BIR/JPW-Inspector's Log By Date (cont'd) ; 30 Aug 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- PRINT ;print inspector's log by naou, drug and green sheet #
- S (PG,PSDOUT,NAOU)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
- K LN S $P(LN,"-",132)="" I '$D(^TMP("PSDRLOG",$J)) D HDR W !!,?45,"**** NO PENDING NARCOTIC ORDERS FOR INSPECTION ****",! G DONE
- S NAOU="" F S NAOU=$O(^TMP("PSDRLOG",$J,NAOU)) Q:NAOU=""!(PSDOUT) D HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y D Q:PSDOUT D PRT
- .I ASKN D LOOP2 Q
- .S PSDRN="" F S PSDRN=$O(^TMP("PSDRLOG",$J,NAOU,PSDRN)) Q:PSDRN=""!(PSDOUT) D Q:PSDOUT
- ..I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y
- ..S NUM="" F S NUM=$O(^TMP("PSDRLOG",$J,NAOU,PSDRN,NUM)) Q:NUM=""!(PSDOUT) F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDRLOG",$J,NAOU,PSDRN,NUM,PSDCNT)) Q:'PSDCNT!(PSDOUT) D
- ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y
- ...S NODE=$G(^TMP("PSDRLOG",$J,NAOU,PSDRN,NUM,PSDCNT))
- ...W ! W:$P(NODE,"^",4)["*" $P(NODE,U,4)
- ...W ?2,$S(ASK="N":PSDRN,1:NUM),?13,$S(ASK="D":PSDRN,1:NUM),?55
- ...W:$P(NODE,U,4)'="#" $P(NODE,"^",2)
- ...W ?70,$J($P(NODE,"^"),6),?85,$P(NODE,"^",3)
- ...W:$P(NODE,U,4)="#" ?100,$P(NODE,U,2) W ?118,"____________",!
- ...W:$P(NODE,"^",5)]"" ?13,"(TRANSFERRED TO "_$P(NODE,"^",5)_")",!
- ...S LNUM=$Y
- 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 %,%H,%I,%ZIS,ALL,ANS,ASK,ASKN,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG,JJ,KK,LN,LOOP,LNUM,LOT,MFG,NAOU,NODE,NODE1,NODE3,NODE7,NUM
- K OK,ORD,ORDN,PG,PSD,PSDA,PSDATE,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDN,PSDNA,PSDOUT,PSDR,PSDRD,PSDRET,PSDRN,PSDSD,PSDST,PSDTR,PSDTYP,QTY,REQD,REQDT,RPDT,RQTY
- K SEL,STAT,STATN,TEXT,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- K ^TMP("PSDRLOG",$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 !,?42,"Inspector's Log for Controlled Substances",?120,"Page: ",PG,!,?52,RPDT,!
- W !,?57,"DATE",?71,"QTY"
- W !,"DISP #",?13,"DRUG",?55,"RECEIVED",?68,"RECEIVED",?85,"EXP DATE"
- W:$G(PSDRET) ?100,"DATE RETURNED" W ?118,"NAME/DATE"
- W !,LN,!
- Q
- LOOP2 ;print inv typ loop
- S TYPN="" F S TYPN=$O(^TMP("PSDRLOG",$J,NAOU,TYPN)) Q:TYPN=""!(PSDOUT) W !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y D
- .S PSDRN="" F S PSDRN=$O(^TMP("PSDRLOG",$J,NAOU,TYPN,PSDRN)) Q:PSDRN=""!(PSDOUT) D Q:PSDOUT
- ..I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
- ..S NUM="" F S NUM=$O(^TMP("PSDRLOG",$J,NAOU,TYPN,PSDRN,NUM)) Q:NUM=""!(PSDOUT) F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDRLOG",$J,NAOU,TYPN,PSDRN,NUM,PSDCNT)) Q:'PSDCNT!(PSDOUT) D Q:PSDOUT
- ...I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! W:ASKN !,?4,"=> INVENTORY TYPE: ",TYPN,! S LNUM=$Y
- ...S NODE=$G(^TMP("PSDRLOG",$J,NAOU,TYPN,PSDRN,NUM,PSDCNT))
- ...W !,$P(NODE,"^",4),?2,$S(ASK="N":PSDRN,1:NUM),?13,$S(ASK="D":PSDRN,1:NUM),?55,$P(NODE,"^",2),?70,$J($P(NODE,"^"),6),?85,$P(NODE,"^",3),?100,"____________",?118,"____________",!
- ...W:$P(NODE,"^",5)]"" ?13,"(TRANSFERRED TO "_$P(NODE,"^",5)_")",!
- ...S LNUM=$Y
- Q
- PRT ;
- I LNUM<IOSL-7 F JJ=LNUM:1:IOSL-7 W !
- W !,LN,!,"* - Transferred to another NAOU",!,"** - Received from another NAOU",!
- Q
- PSDRLOG2 ;BIR/JPW-Inspector's Log By Date (cont'd) ; 30 Aug 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- PRINT ;print inspector's log by naou, drug and green sheet #
- +1 SET (PG,PSDOUT,NAOU)=0
- DO NOW^%DTC
- SET Y=+$EXTRACT(%,1,12)
- XECUTE ^DD("DD")
- SET RPDT=Y
- +2 KILL LN
- SET $PIECE(LN,"-",132)=""
- IF '$DATA(^TMP("PSDRLOG",$JOB))
- DO HDR
- WRITE !!,?45,"**** NO PENDING NARCOTIC ORDERS FOR INSPECTION ****",!
- GOTO DONE
- +3 SET NAOU=""
- FOR
- SET NAOU=$ORDER(^TMP("PSDRLOG",$JOB,NAOU))
- IF NAOU=""!(PSDOUT)
- QUIT
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> NAOU: ",NAOU,!
- SET LNUM=$Y
- Begin DoDot:1
- +4 IF ASKN
- DO LOOP2
- QUIT
- +5 SET PSDRN=""
- FOR
- SET PSDRN=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,PSDRN))
- IF PSDRN=""!(PSDOUT)
- QUIT
- Begin DoDot:2
- +6 IF $Y+8>IOSL
- DO PRT
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> NAOU: ",NAOU,!
- SET LNUM=$Y
- +7 SET NUM=""
- FOR
- SET NUM=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,PSDRN,NUM))
- IF NUM=""!(PSDOUT)
- QUIT
- FOR PSDCNT=0:0
- SET PSDCNT=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,PSDRN,NUM,PSDCNT))
- IF 'PSDCNT!(PSDOUT)
- QUIT
- Begin DoDot:3
- +8 IF $Y+8>IOSL
- DO PRT
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> NAOU: ",NAOU,!
- SET LNUM=$Y
- +9 SET NODE=$GET(^TMP("PSDRLOG",$JOB,NAOU,PSDRN,NUM,PSDCNT))
- +10 WRITE !
- IF $PIECE(NODE,"^",4)["*"
- WRITE $PIECE(NODE,U,4)
- +11 WRITE ?2,$SELECT(ASK="N":PSDRN,1:NUM),?13,$SELECT(ASK="D":PSDRN,1:NUM),?55
- +12 IF $PIECE(NODE,U,4)'="#"
- WRITE $PIECE(NODE,"^",2)
- +13 WRITE ?70,$JUSTIFY($PIECE(NODE,"^"),6),?85,$PIECE(NODE,"^",3)
- +14 IF $PIECE(NODE,U,4)="#"
- WRITE ?100,$PIECE(NODE,U,2)
- WRITE ?118,"____________",!
- +15 IF $PIECE(NODE,"^",5)]""
- WRITE ?13,"(TRANSFERRED TO "_$PIECE(NODE,"^",5)_")",!
- +16 SET LNUM=$Y
- End DoDot:3
- End DoDot:2
- IF PSDOUT
- QUIT
- End DoDot:1
- IF PSDOUT
- QUIT
- DO PRT
- 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 KILL %,%H,%I,%ZIS,ALL,ANS,ASK,ASKN,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG,JJ,KK,LN,LOOP,LNUM,LOT,MFG,NAOU,NODE,NODE1,NODE3,NODE7,NUM
- +1 KILL OK,ORD,ORDN,PG,PSD,PSDA,PSDATE,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDN,PSDNA,PSDOUT,PSDR,PSDRD,PSDRET,PSDRN,PSDSD,PSDST,PSDTR,PSDTYP,QTY,REQD,REQDT,RPDT,RQTY
- +2 KILL SEL,STAT,STATN,TEXT,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
- +3 KILL ^TMP("PSDRLOG",$JOB)
- DO ^%ZISC
- +4 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +5 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 !,?42,"Inspector's Log for Controlled Substances",?120,"Page: ",PG,!,?52,RPDT,!
- +3 WRITE !,?57,"DATE",?71,"QTY"
- +4 WRITE !,"DISP #",?13,"DRUG",?55,"RECEIVED",?68,"RECEIVED",?85,"EXP DATE"
- +5 IF $GET(PSDRET)
- WRITE ?100,"DATE RETURNED"
- WRITE ?118,"NAME/DATE"
- +6 WRITE !,LN,!
- +7 QUIT
- LOOP2 ;print inv typ loop
- +1 SET TYPN=""
- FOR
- SET TYPN=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,TYPN))
- IF TYPN=""!(PSDOUT)
- QUIT
- WRITE !,?4,"=> INVENTORY TYPE: ",$SELECT($EXTRACT(TYPN,1,2)="ZZ":$EXTRACT(TYPN,3,99),1:TYPN),!
- SET LNUM=$Y
- Begin DoDot:1
- +2 SET PSDRN=""
- FOR
- SET PSDRN=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,TYPN,PSDRN))
- IF PSDRN=""!(PSDOUT)
- QUIT
- Begin DoDot:2
- +3 IF $Y+8>IOSL
- DO PRT
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> NAOU: ",NAOU,!
- IF ASKN
- WRITE !,?4,"=> INVENTORY TYPE: ",$SELECT($EXTRACT(TYPN,1,2)="ZZ":$EXTRACT(TYPN,3,99),1:TYPN),!
- SET LNUM=$Y
- +4 SET NUM=""
- FOR
- SET NUM=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,TYPN,PSDRN,NUM))
- IF NUM=""!(PSDOUT)
- QUIT
- FOR PSDCNT=0:0
- SET PSDCNT=$ORDER(^TMP("PSDRLOG",$JOB,NAOU,TYPN,PSDRN,NUM,PSDCNT))
- IF 'PSDCNT!(PSDOUT)
- QUIT
- Begin DoDot:3
- +5 IF $Y+8>IOSL
- DO PRT
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> NAOU: ",NAOU,!
- IF ASKN
- WRITE !,?4,"=> INVENTORY TYPE: ",TYPN,!
- SET LNUM=$Y
- +6 SET NODE=$GET(^TMP("PSDRLOG",$JOB,NAOU,TYPN,PSDRN,NUM,PSDCNT))
- +7 WRITE !,$PIECE(NODE,"^",4),?2,$SELECT(ASK="N":PSDRN,1:NUM),?13,$SELECT(ASK="D":PSDRN,1:NUM),?55,$PIECE(NODE,"^",2),?70,$JUSTIFY($PIECE(NODE,"^"),6),?85,$PIECE(NODE,"^",3),?100,"____________",?118,"____________",!
- +8 IF $PIECE(NODE,"^",5)]""
- WRITE ?13,"(TRANSFERRED TO "_$PIECE(NODE,"^",5)_")",!
- +9 SET LNUM=$Y
- End DoDot:3
- IF PSDOUT
- QUIT
- End DoDot:2
- IF PSDOUT
- QUIT
- End DoDot:1
- +10 QUIT
- PRT ;
- +1 IF LNUM<IOSL-7
- FOR JJ=LNUM:1:IOSL-7
- WRITE !
- +2 WRITE !,LN,!,"* - Transferred to another NAOU",!,"** - Received from another NAOU",!
- +3 QUIT
