PSDPDR2 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 09 FEB 95
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
PRINT ;entry to print
S COPY=$S(PSDCPY="V":2,1:1) D COPY
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,C,CNT,COPY,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG,LN,LOOP,LOT,MFG,NAOU,NODE,NUM
K OK,ORD,ORDN,PG,POP,PSD,PSDA,PSDCPY,PSDDT,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDOUT,PSDPT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN,PSDST,QTY,REQD,REQDT,RPDT,SEL,STAT,STATN,TEXT,X,Y
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDRPT",$J) D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR ;header for log
;;The next line inserted for E3R# 3311 2-9-95.
I PG,$G(PSDCPY)="V"!($G(COPY)=2) W !,"* VERIFIED ORDER WAS EDITED."
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 I PSDCPY="V"!(COPY=2) W !,?45,"*** RECEIPT VERIFICATION COPY ***",!,?42,"Technician Delivering Orders: ________________________",!
W !,?2,"VA FORM 10-2321",?42,"Narcotic Dispensing/Receiving Report" I NAOU]"",NAOU'=0 W " for ",NAOU W:$P($G(^PSD(58.8,+$O(^PSD(58.8,"B",NAOU,0)),2)),U,5) " (Perpetual Inventory)"
W ?125,"Page: ",PG,!,?52,RPDT,!
W !,?14,"DATE",?78,"DATE"
W !,"DISP #",?12,"DISPENSED",?24,"QTY",?33,"DRUG",?78,"ORD",?90,"ORDERED BY"
W !,LN,!!
Q
COPY ;copy 1 and 2
S (COMM,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("PSDRPT",$J)) D HDR W !!,?45,"**** NO PENDING NARCOTIC ORDERS TO BE DELIVERED ****" S FLAG=1 Q
S NAOU="" F S NAOU=$O(^TMP("PSDRPT",$J,NAOU)) Q:NAOU=""!(PSDOUT) D HDR Q:PSDOUT D Q:PSDOUT I PSDCPY="B",COPY=1 S COPY=2 D HDR D S COPY=1
.;;$Y changed to 12 to force fnote to print at bottom of page E3R# 3311.
.S NUM="" F S NUM=$O(^TMP("PSDRPT",$J,NAOU,NUM)) Q:NUM=""!(PSDOUT) D:$Y+12>IOSL HDR Q:PSDOUT S NODE=^TMP("PSDRPT",$J,NAOU,NUM) D
COP ..I $P(NODE,"^",9),$Y+12>IOSL D HDR Q:PSDOUT
..;;The next line inserted for E3r# 3311 2-9-95.
..NEW X S X=$P(NODE,"^",2) S X=$S(PSDCPY="V":X,COPY=2:X,1:+X)
..W !,NUM,?12,$P(NODE,"^",3),?21,$J(X,6),?33,$P(NODE,"^"),?78,$P(NODE,"^",4),?90,$P(NODE,"^",5)
..;;Balance inserted for E3R# 3311 2-9-95.
..I PSDCPY="V"!(COPY=2) W !,?33,"BALANCE: "_$S($P(NODE,"^",11)]"":+$P(NODE,"^",11),1:"UNKNOWN")_" "_$P(NODE,"^",12)
..I $P(NODE,"^",6)]"" W !,?33,"Mfg/Lot #/Exp Date: ",$P(NODE,"^",6)_" "_$P(NODE,"^",7)_" "_$P(NODE,"^",8)
..W !!,?7,"Disp by RPh:___________________________________",?61,"Rec'd by Nurse:___________________________________",!,?19,"(Full Name)",?76,"(Full Name)",!
..I $P(NODE,"^",9) W ?24,"COMMENTS:" S COMM=1,PSDA=$P(NODE,"^",10) K ^UTILITY($J,"W") F TEXT=0:0 S TEXT=$O(^PSD(58.81,PSDA,2,TEXT)) Q:'TEXT D:$Y+4>IOSL HDR Q:PSDOUT S X=$G(^PSD(58.81,PSDA,2,TEXT,0)),DIWL=34,DIWR=115,DIWF="W" D ^DIWP
..I COMM D ^DIWW S COMM=0 W !
..K DA,DIE,DR S (DA,PSDA)=+$P(NODE,"^",10),DR="102////"_PSDPT,DIE=58.81 D ^DIE K DA,DIE,DR
;;The next line inserted for E3R# 3311 2-9-95.
I PG,$G(PSDCPY)="V"!($G(COPY)=2) W !,"* VERIFIED ORDER WAS EDITED."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPDR2 3242 printed Oct 16, 2024@17:48:49 Page 2
PSDPDR2 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 09 FEB 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
PRINT ;entry to print
+1 SET COPY=$SELECT(PSDCPY="V":2,1:1)
DO COPY
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,C,CNT,COPY,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG,LN,LOOP,LOT,MFG,NAOU,NODE,NUM
+1 KILL OK,ORD,ORDN,PG,POP,PSD,PSDA,PSDCPY,PSDDT,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDOUT,PSDPT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN,PSDST,QTY,REQD,REQDT,RPDT,SEL,STAT,STATN,TEXT,X,Y
+2 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 KILL ^TMP("PSDRPT",$JOB)
DO ^%ZISC
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
HDR ;header for log
+1 ;;The next line inserted for E3R# 3311 2-9-95.
+2 IF PG
IF $GET(PSDCPY)="V"!($GET(COPY)=2)
WRITE !,"* VERIFIED ORDER WAS EDITED."
+3 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
+4 SET PG=PG+1
if $Y
WRITE @IOF
IF PSDCPY="V"!(COPY=2)
WRITE !,?45,"*** RECEIPT VERIFICATION COPY ***",!,?42,"Technician Delivering Orders: ________________________",!
+5 WRITE !,?2,"VA FORM 10-2321",?42,"Narcotic Dispensing/Receiving Report"
IF NAOU]""
IF NAOU'=0
WRITE " for ",NAOU
if $PIECE($GET(^PSD(58.8,+$ORDER(^PSD(58.8,"B",NAOU,0)),2)),U,5)
WRITE " (Perpetual Inventory)"
+6 WRITE ?125,"Page: ",PG,!,?52,RPDT,!
+7 WRITE !,?14,"DATE",?78,"DATE"
+8 WRITE !,"DISP #",?12,"DISPENSED",?24,"QTY",?33,"DRUG",?78,"ORD",?90,"ORDERED BY"
+9 WRITE !,LN,!!
+10 QUIT
COPY ;copy 1 and 2
+1 SET (COMM,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("PSDRPT",$JOB))
DO HDR
WRITE !!,?45,"**** NO PENDING NARCOTIC ORDERS TO BE DELIVERED ****"
SET FLAG=1
QUIT
+3 SET NAOU=""
FOR
SET NAOU=$ORDER(^TMP("PSDRPT",$JOB,NAOU))
if NAOU=""!(PSDOUT)
QUIT
DO HDR
if PSDOUT
QUIT
Begin DoDot:1
+4 ;;$Y changed to 12 to force fnote to print at bottom of page E3R# 3311.
+5 SET NUM=""
FOR
SET NUM=$ORDER(^TMP("PSDRPT",$JOB,NAOU,NUM))
if NUM=""!(PSDOUT)
QUIT
if $Y+12>IOSL
DO HDR
if PSDOUT
QUIT
SET NODE=^TMP("PSDRPT",$JOB,NAOU,NUM)
Begin DoDot:2
COP IF $PIECE(NODE,"^",9)
IF $Y+12>IOSL
DO HDR
if PSDOUT
QUIT
+1 ;;The next line inserted for E3r# 3311 2-9-95.
+2 NEW X
SET X=$PIECE(NODE,"^",2)
SET X=$SELECT(PSDCPY="V":X,COPY=2:X,1:+X)
+3 WRITE !,NUM,?12,$PIECE(NODE,"^",3),?21,$JUSTIFY(X,6),?33,$PIECE(NODE,"^"),?78,$PIECE(NODE,"^",4),?90,$PIECE(NODE,"^",5)
+4 ;;Balance inserted for E3R# 3311 2-9-95.
+5 IF PSDCPY="V"!(COPY=2)
WRITE !,?33,"BALANCE: "_$SELECT($PIECE(NODE,"^",11)]"":+$PIECE(NODE,"^",11),1:"UNKNOWN")_" "_$PIECE(NODE,"^",12)
+6 IF $PIECE(NODE,"^",6)]""
WRITE !,?33,"Mfg/Lot #/Exp Date: ",$PIECE(NODE,"^",6)_" "_$PIECE(NODE,"^",7)_" "_$PIECE(NODE,"^",8)
+7 WRITE !!,?7,"Disp by RPh:___________________________________",?61,"Rec'd by Nurse:___________________________________",!,?19,"(Full Name)",?76,"(Full Name)",!
+8 IF $PIECE(NODE,"^",9)
WRITE ?24,"COMMENTS:"
SET COMM=1
SET PSDA=$PIECE(NODE,"^",10)
KILL ^UTILITY($JOB,"W")
FOR TEXT=0:0
SET TEXT=$ORDER(^PSD(58.81,PSDA,2,TEXT))
if 'TEXT
QUIT
if $Y+4>IOSL
DO HDR
if PSDOUT
QUIT
SET X=$GET(^PSD(58.81,PSDA,2,TEXT,0))
SET DIWL=34
SET DIWR=115
SET DIWF="W"
DO ^DIWP
+9 IF COMM
DO ^DIWW
SET COMM=0
WRITE !
+10 KILL DA,DIE,DR
SET (DA,PSDA)=+$PIECE(NODE,"^",10)
SET DR="102////"_PSDPT
SET DIE=58.81
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
End DoDot:1
if PSDOUT
QUIT
IF PSDCPY="B"
IF COPY=1
SET COPY=2
DO HDR
Begin DoDot:1
End DoDot:1
SET COPY=1
+11 ;;The next line inserted for E3R# 3311 2-9-95.
+12 IF PG
IF $GET(PSDCPY)="V"!($GET(COPY)=2)
WRITE !,"* VERIFIED ORDER WAS EDITED."
+13 QUIT
