PSDRDR1 ;BIR/BJW-Narc Disp/Rec (reprint VA FORM 10-2321) (cont'd) ; 3 Mar 98
;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
;**Y2K compliance** display 4 digit year on va forms
;;This routine modified on 2-9-95 for E3R# 3311.
START ;compile data
K ^TMP("PSDRDR",$J)
I $D(PSDA),$D(^PSD(58.81,PSDA,0)) D SET,^PSDRDR2 G END
F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"AC",PSD)) Q:'PSD!(PSD>PSDED) F PSDA=0:0 S PSDA=$O(^PSD(58.81,"AC",PSD,PSDA)) Q:'PSDA I $D(^PSD(58.81,PSDA,0)),$D(NAOU(+$P(^PSD(58.81,PSDA,0),"^",18))),$P(^PSD(58.81,PSDA,0),"^",3)=+PSDS D SET
D ^PSDRDR2
END K %,%I,%H,%ZIS,C,COMM,COPY,D,DA,DIC,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DRUG,DRUGN,DTOUT,DUOUT,EXP,EXPD,EXP1,FLAG,LN,LOOP,LOT,MFG,NAOU,NAOUN,NEWBAL,NODE,NUM,OK,ORD,ORDN
K FNOTE,PG,PHARM,PHARMN,PSD,PSDA,PSDATE,PSDCPY,PSDDT,PSDED,PSDEV,PSDN,PSDNA,PSDOUT,PSDS,PSDSD,PSDSN,PSDST,PSDYR,QTY,REC,RECN,REQD,REQDT,RPDT,SEL,SUM,TEXT,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDRDR",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
SET ;sets data for printing
Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^PSD(58.81,PSDA,0),PSDN=+$P(NODE,"^",18)
S PSDNA=$S($P($G(^PSD(58.8,PSDN,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDN)
S DRUG=+$P(NODE,"^",5),DRUGN=$S($P($G(^PSDRUG(DRUG,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_DRUG)
S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
S COMM=$S($D(^PSD(58.81,PSDA,2,0)):1,1:0),MFG=$P(NODE,"^",13),LOT=$P(NODE,"^",14),EXP=$P(NODE,"^",15),EXPD=""
;;The next 2 lines were inserted for E3R# 3311,to print a drug balance.
S:$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(^(4),"^",7)+$P(^(4),"^",4),FNOTE="*"
S:'$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(NODE,"^",10)-QTY,FNOTE=""
I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD
S NUM=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN")
S ORD=+$P($G(^PSD(58.81,PSDA,1)),"^",7),ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S REQD=$P($G(^PSD(58.81,PSDA,1)),"^",6),REQDT="" I REQD S Y=REQD
X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4)
S REQDT=$E(REQD,4,5)_"/"_$E(REQD,6,7)_"/"_PSDYR
S PSDST=$P(NODE,"^",4),PSDDT="" I PSDST S Y=PSDST X ^DD("DD")
S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) S PSDDT=$E(PSDST,4,5)_"/"_$E(PSDST,6,7)_"/"_PSDYR
S (REC,PHARM,RECN,PHARMN)="" I $D(^PSD(58.81,PSDA,1)),+$P(^PSD(58.81,PSDA,1),"^",4) S PHARM=$P(^(1),"^"),REC=$P(^(1),"^",3)
I PHARM S PHARMN=$P($G(^VA(200,PHARM,0)),"^")
I REC S RECN=$P($G(^VA(200,REC,0)),"^")
;;The next line modified for E3R# 3311,newbal and fnote added.
S ^TMP("PSDRDR",$J,PSDNA,NUM)=DRUGN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_PHARMN_"^"_RECN_"^"_NEWBAL_"^"_FNOTE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRDR1 2735 printed Dec 13, 2024@01:48:21 Page 2
PSDRDR1 ;BIR/BJW-Narc Disp/Rec (reprint VA FORM 10-2321) (cont'd) ; 3 Mar 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
+2 ;**Y2K compliance** display 4 digit year on va forms
+3 ;;This routine modified on 2-9-95 for E3R# 3311.
START ;compile data
+1 KILL ^TMP("PSDRDR",$JOB)
+2 IF $DATA(PSDA)
IF $DATA(^PSD(58.81,PSDA,0))
DO SET
DO ^PSDRDR2
GOTO END
+3 FOR PSD=PSDSD:0
SET PSD=$ORDER(^PSD(58.81,"AC",PSD))
if 'PSD!(PSD>PSDED)
QUIT
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"AC",PSD,PSDA))
if 'PSDA
QUIT
IF $DATA(^PSD(58.81,PSDA,0))
IF $DATA(NAOU(+$PIECE(^PSD(58.81,PSDA,0),"^",18)))
IF $PIECE(^PSD(58.81,PSDA,0),"^",3)=+PSDS
DO SET
+4 DO ^PSDRDR2
END KILL %,%I,%H,%ZIS,C,COMM,COPY,D,DA,DIC,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DRUG,DRUGN,DTOUT,DUOUT,EXP,EXPD,EXP1,FLAG,LN,LOOP,LOT,MFG,NAOU,NAOUN,NEWBAL,NODE,NUM,OK,ORD,ORDN
+1 KILL FNOTE,PG,PHARM,PHARMN,PSD,PSDA,PSDATE,PSDCPY,PSDDT,PSDED,PSDEV,PSDN,PSDNA,PSDOUT,PSDS,PSDSD,PSDSN,PSDST,PSDYR,QTY,REC,RECN,REQD,REQDT,RPDT,SEL,SUM,TEXT,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 KILL ^TMP("PSDRDR",$JOB)
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
SET ;sets data for printing
+1 if '$DATA(^PSD(58.81,PSDA,0))
QUIT
SET NODE=^PSD(58.81,PSDA,0)
SET PSDN=+$PIECE(NODE,"^",18)
+2 SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,PSDN,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDN)
+3 SET DRUG=+$PIECE(NODE,"^",5)
SET DRUGN=$SELECT($PIECE($GET(^PSDRUG(DRUG,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_DRUG)
+4 SET QTY=$PIECE(NODE,"^",6)
IF $DATA(^PSD(58.81,PSDA,4))
IF +$PIECE(^(4),"^",3)
SET QTY=$PIECE(^(4),"^",3)
+5 SET COMM=$SELECT($DATA(^PSD(58.81,PSDA,2,0)):1,1:0)
SET MFG=$PIECE(NODE,"^",13)
SET LOT=$PIECE(NODE,"^",14)
SET EXP=$PIECE(NODE,"^",15)
SET EXPD=""
+6 ;;The next 2 lines were inserted for E3R# 3311,to print a drug balance.
+7 if $DATA(^PSD(58.81,PSDA,4))
SET NEWBAL=$PIECE(^(4),"^",7)+$PIECE(^(4),"^",4)
SET FNOTE="*"
+8 if '$DATA(^PSD(58.81,PSDA,4))
SET NEWBAL=$PIECE(NODE,"^",10)-QTY
SET FNOTE=""
+9 IF EXP
SET (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D")
if '$PIECE(EXP1,"/",2)
SET EXPD=$PIECE(EXP1,"/")_"/"_$PIECE(EXP1,"/",3)
SET EXP=EXPD
+10 SET NUM=$SELECT($PIECE(NODE,"^",17)]"":$PIECE(NODE,"^",17),1:"UNKNOWN")
+11 SET ORD=+$PIECE($GET(^PSD(58.81,PSDA,1)),"^",7)
SET ORDN=$SELECT($PIECE($GET(^VA(200,ORD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+12 SET REQD=$PIECE($GET(^PSD(58.81,PSDA,1)),"^",6)
SET REQDT=""
IF REQD
SET Y=REQD
+13 XECUTE ^DD("DD")
SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
+14 SET REQDT=$EXTRACT(REQD,4,5)_"/"_$EXTRACT(REQD,6,7)_"/"_PSDYR
+15 SET PSDST=$PIECE(NODE,"^",4)
SET PSDDT=""
IF PSDST
SET Y=PSDST
XECUTE ^DD("DD")
+16 SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
SET PSDDT=$EXTRACT(PSDST,4,5)_"/"_$EXTRACT(PSDST,6,7)_"/"_PSDYR
+17 SET (REC,PHARM,RECN,PHARMN)=""
IF $DATA(^PSD(58.81,PSDA,1))
IF +$PIECE(^PSD(58.81,PSDA,1),"^",4)
SET PHARM=$PIECE(^(1),"^")
SET REC=$PIECE(^(1),"^",3)
+18 IF PHARM
SET PHARMN=$PIECE($GET(^VA(200,PHARM,0)),"^")
+19 IF REC
SET RECN=$PIECE($GET(^VA(200,REC,0)),"^")
+20 ;;The next line modified for E3R# 3311,newbal and fnote added.
+21 SET ^TMP("PSDRDR",$JOB,PSDNA,NUM)=DRUGN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_PHARMN_"^"_RECN_"^"_NEWBAL_"^"_FNOTE
+22 QUIT
