PSDRLOG3 ;BIR/JPW,LTL-Inspector's Log By Date (cont'd) ; 31 May 95
;;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,"B",NAOU)) Q:NAOU=""!(PSDOUT) D HDR Q:PSDOUT W !,?2,"=> NAOU: ",NAOU,! S LNUM=$Y D LOOP2 Q:PSDOUT D PRT
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 NAOU(1)=$O(^TMP("PSDRLOG",$J,"B",NAOU,0))
S TYPN="" F S TYPN=$O(^TMP("PSDRLOG",$J,NAOU(1),"B",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 TYPN(1)=$O(^TMP("PSDRLOG",$J,NAOU(1),"B",TYPN,0))
.I ASK="N" D Q
..S NUM=0
..F S NUM=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),NUM)) Q:NUM=""!(PSDOUT) D Q:PSDOUT
...I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
...S PSDR=0
...F S PSDR=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),NUM,PSDR)) Q:'PSDR!(PSDOUT) S PSDCNT=0 F S PSDCNT=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT)) Q:'PSDCNT!(PSDOUT) D Q:PSDOUT
....I $Y+8>IOSL D PRT,HDR Q:PSDOUT W !?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$S($E(TYPN,1,2)="ZZ":$E(TYPN,3,99),1:TYPN),! S LNUM=$Y
....S NODE=$G(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT))
....W !,$P(NODE,U,4),?2,NUM,?13,$P(NODE,U,6),?55,$P(NODE,U,2),?70,$J($P(NODE,U),6),?85,$P(NODE,U,3),?100,"____________",?118,"____________",!
....W:$P(NODE,U,5)]"" ?13,"(TRANSFERRED TO ",$P(NODE,U,5),")",! S LNUM=$Y
.S PSDRN="" F S PSDRN=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),"B",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 PSDRN(1)=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),"B",PSDRN,0))
..S NUM="" F S NUM=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),PSDRN(1),NUM)) Q:NUM=""!(PSDOUT) F PSDCNT=0:0 S PSDCNT=$O(^TMP("PSDRLOG",$J,NAOU(1),TYPN(1),PSDRN(1),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(1),TYPN(1),PSDRN(1),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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRLOG3 3843 printed Dec 13, 2024@01:48:50 Page 2
PSDRLOG3 ;BIR/JPW,LTL-Inspector's Log By Date (cont'd) ; 31 May 95
+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,"B",NAOU))
if NAOU=""!(PSDOUT)
QUIT
DO HDR
if PSDOUT
QUIT
WRITE !,?2,"=> NAOU: ",NAOU,!
SET LNUM=$Y
DO LOOP2
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 NAOU(1)=$ORDER(^TMP("PSDRLOG",$JOB,"B",NAOU,0))
+2 SET TYPN=""
FOR
SET TYPN=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),"B",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
+3 SET TYPN(1)=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),"B",TYPN,0))
+4 IF ASK="N"
Begin DoDot:2
+5 SET NUM=0
+6 FOR
SET NUM=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),NUM))
if NUM=""!(PSDOUT)
QUIT
Begin DoDot:3
+7 IF $Y+8>IOSL
DO PRT
DO HDR
if PSDOUT
QUIT
WRITE !?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$SELECT($EXTRACT(TYPN,1,2)="ZZ":$EXTRACT(TYPN,3,99),1:TYPN),!
SET LNUM=$Y
+8 SET PSDR=0
+9 FOR
SET PSDR=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),NUM,PSDR))
if 'PSDR!(PSDOUT)
QUIT
SET PSDCNT=0
FOR
SET PSDCNT=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT))
if 'PSDCNT!(PSDOUT)
QUIT
Begin DoDot:4
+10 IF $Y+8>IOSL
DO PRT
DO HDR
if PSDOUT
QUIT
WRITE !?2,"=> NAOU: ",NAOU,!!?4,"=> INVENTORY TYPE: ",$SELECT($EXTRACT(TYPN,1,2)="ZZ":$EXTRACT(TYPN,3,99),1:TYPN),!
SET LNUM=$Y
+11 SET NODE=$GET(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),NUM,PSDR,PSDCNT))
+12 WRITE !,$PIECE(NODE,U,4),?2,NUM,?13,$PIECE(NODE,U,6),?55,$PIECE(NODE,U,2),?70,$JUSTIFY($PIECE(NODE,U),6),?85,$PIECE(NODE,U,3),?100,"____________",?118,"____________",!
+13 if $PIECE(NODE,U,5)]""
WRITE ?13,"(TRANSFERRED TO ",$PIECE(NODE,U,5),")",!
SET LNUM=$Y
End DoDot:4
if PSDOUT
QUIT
End DoDot:3
if PSDOUT
QUIT
End DoDot:2
QUIT
+14 SET PSDRN=""
FOR
SET PSDRN=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),"B",PSDRN))
if PSDRN=""!(PSDOUT)
QUIT
Begin DoDot:2
+15 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
+16 SET PSDRN(1)=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),"B",PSDRN,0))
+17 SET NUM=""
FOR
SET NUM=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),PSDRN(1),NUM))
if NUM=""!(PSDOUT)
QUIT
FOR PSDCNT=0:0
SET PSDCNT=$ORDER(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),PSDRN(1),NUM,PSDCNT))
if 'PSDCNT!(PSDOUT)
QUIT
Begin DoDot:3
+18 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
+19 SET NODE=$GET(^TMP("PSDRLOG",$JOB,NAOU(1),TYPN(1),PSDRN(1),NUM,PSDCNT))
+20 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,"____________",!
+21 if $PIECE(NODE,"^",5)]""
WRITE ?13,"(TRANSFERRED TO "_$PIECE(NODE,"^",5)_")",!
+22 SET LNUM=$Y
End DoDot:3
if PSDOUT
QUIT
End DoDot:2
if PSDOUT
QUIT
End DoDot:1
+23 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
