PSDPDR1 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 03 Mar 98
;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
;**Y2K compliance** display 4 digit year on va forms
START ;compile data
K ^TMP("PSDRPT",$J)
I $D(PSDG) F PSD=0:0 S PSD=$O(PSDG(PSD)) Q:'PSD F PSDN=0:0 S PSDN=$O(^PSI(58.2,PSD,3,PSDN)) Q:'PSDN I $D(^PSD(58.8,PSDN,0)),$P(^(0),"^",2)="N",+$P(^(0),"^",4)=+PSDS S NAOU(PSDN)="",CNT=CNT+1
I $D(ALL) F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$P(^(0),"^",2)="N",$P(^(0),"^",4)=+PSDS S NAOU(+PSD)=""
F PSD=0:0 S PSD=$O(^PSD(58.81,"AD",3,PSD)) G:('PSD)&($D(ZTQUEUED)) PRTQUE G:'PSD PRINT^PSDPDR2 F PSDA=0:0 S PSDA=$O(^PSD(58.81,"AD",3,PSD,PSDA)) Q:'PSDA I $D(^PSD(58.81,PSDA,0)) D
.S NODE=^PSD(58.81,PSDA,0),PSDN=+$P(NODE,"^",18)
.I $D(NAOU(PSDN)) S PSDNA=$S($P($G(^PSD(58.8,PSDN,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDN) D
..S PSDR=+$P(NODE,"^",5),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR),STAT=+$P(NODE,"^",11) Q:+$P($G(^PSD(58.81,PSDA,"CS")),"^",3)!(STAT'=3)
..S STATN=$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
..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 two lines inserted for E3R# 3311 2-9-95.
..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
..;;Fnote and Newbal added for E3R# 3311 2-9-95.
..S ^TMP("PSDRPT",$J,PSDNA,NUM)=PSDRN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_NEWBAL_"^"_FNOTE
Q
PRTQUE ;queues print after compile
K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDPDR2",ZTDESC="Print Narcotic Disp Report",ZTDTH=$H
S (ZTSAVE("^TMP(""PSDRPT"",$J,"),ZTSAVE("PSDS"),ZTSAVE("PSDPT"),ZTSAVE("CNT"),ZTSAVE("PSDCPY"))=""
D ^%ZTLOAD K ^TMP("PSDRPT",$J),ZTSK
END K %,%H,%I,%ZIS,ALL,C,CNT,COPY,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,EXP1,FLAG,LOT,MFG,NAOU,NEWBAL,NODE,NUM
K FNOTE,OK,ORD,ORDN,POP,PSD,PSDA,PSDCPY,PSDDT,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN,PSDST,PSDYR,QTY,REQD,REQDT,SEL,STAT,STATN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDRPT",$J) D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPDR1 2993 printed Apr 09, 2024@20:53:21 Page 2
PSDPDR1 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 03 Mar 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
+2 ;**Y2K compliance** display 4 digit year on va forms
START ;compile data
+1 KILL ^TMP("PSDRPT",$JOB)
+2 IF $DATA(PSDG)
FOR PSD=0:0
SET PSD=$ORDER(PSDG(PSD))
if 'PSD
QUIT
FOR PSDN=0:0
SET PSDN=$ORDER(^PSI(58.2,PSD,3,PSDN))
if 'PSDN
QUIT
IF $DATA(^PSD(58.8,PSDN,0))
IF $PIECE(^(0),"^",2)="N"
IF +$PIECE(^(0),"^",4)=+PSDS
SET NAOU(PSDN)=""
SET CNT=CNT+1
+3 IF $DATA(ALL)
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,PSD,0))
IF $PIECE(^(0),"^",2)="N"
IF $PIECE(^(0),"^",4)=+PSDS
SET NAOU(+PSD)=""
+4 FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.81,"AD",3,PSD))
if ('PSD)&($DATA(ZTQUEUED))
GOTO PRTQUE
if 'PSD
GOTO PRINT^PSDPDR2
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"AD",3,PSD,PSDA))
if 'PSDA
QUIT
IF $DATA(^PSD(58.81,PSDA,0))
Begin DoDot:1
+5 SET NODE=^PSD(58.81,PSDA,0)
SET PSDN=+$PIECE(NODE,"^",18)
+6 IF $DATA(NAOU(PSDN))
SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,PSDN,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDN)
Begin DoDot:2
+7 SET PSDR=+$PIECE(NODE,"^",5)
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR)
SET STAT=+$PIECE(NODE,"^",11)
if +$PIECE($GET(^PSD(58.81,PSDA,"CS")),"^",3)!(STAT'=3)
QUIT
+8 SET STATN=$SELECT($PIECE($GET(^PSD(58.82,STAT,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+9 SET QTY=$PIECE(NODE,"^",6)
IF $DATA(^PSD(58.81,PSDA,4))
IF +$PIECE(^(4),"^",3)
SET QTY=$PIECE(^(4),"^",3)
+10 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=""
+11 ;;The next two lines inserted for E3R# 3311 2-9-95.
+12 if $DATA(^PSD(58.81,PSDA,4))
SET NEWBAL=$PIECE(^(4),"^",7)+$PIECE(^(4),"^",4)
SET FNOTE="*"
+13 if '$DATA(^PSD(58.81,PSDA,4))
SET NEWBAL=$PIECE(NODE,"^",10)-QTY
SET FNOTE=""
+14 IF EXP
SET (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D")
if '$PIECE(EXP1,"/",2)
SET EXPD=$PIECE(EXP1,"/")_"/"_$PIECE(EXP1,"/",3)
SET EXP=EXPD
+15 SET NUM=$SELECT($PIECE(NODE,"^",17)]"":$PIECE(NODE,"^",17),1:"UNKNOWN")
+16 SET ORD=+$PIECE($GET(^PSD(58.81,PSDA,1)),"^",7)
SET ORDN=$SELECT($PIECE($GET(^VA(200,ORD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+17 SET REQD=$PIECE($GET(^PSD(58.81,PSDA,1)),"^",6)
SET REQDT=""
IF REQD
SET Y=REQD
XECUTE ^DD("DD")
SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
SET REQDT=$EXTRACT(REQD,4,5)_"/"_$EXTRACT(REQD,6,7)_"/"_PSDYR
+18 SET PSDST=$PIECE(NODE,"^",4)
SET PSDDT=""
IF PSDST
SET Y=PSDST
XECUTE ^DD("DD")
SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
+19 SET PSDDT=$EXTRACT(PSDST,4,5)_"/"_$EXTRACT(PSDST,6,7)_"/"_PSDYR
+20 ;;Fnote and Newbal added for E3R# 3311 2-9-95.
+21 SET ^TMP("PSDRPT",$JOB,PSDNA,NUM)=PSDRN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_NEWBAL_"^"_FNOTE
End DoDot:2
End DoDot:1
+22 QUIT
PRTQUE ;queues print after compile
+1 KILL ZTSAVE,ZTIO
SET ZTIO=PSDIO
SET ZTRTN="PRINT^PSDPDR2"
SET ZTDESC="Print Narcotic Disp Report"
SET ZTDTH=$HOROLOG
+2 SET (ZTSAVE("^TMP(""PSDRPT"",$J,"),ZTSAVE("PSDS"),ZTSAVE("PSDPT"),ZTSAVE("CNT"),ZTSAVE("PSDCPY"))=""
+3 DO ^%ZTLOAD
KILL ^TMP("PSDRPT",$JOB),ZTSK
END KILL %,%H,%I,%ZIS,ALL,C,CNT,COPY,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,EXP1,FLAG,LOT,MFG,NAOU,NEWBAL,NODE,NUM
+1 KILL FNOTE,OK,ORD,ORDN,POP,PSD,PSDA,PSDCPY,PSDDT,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN,PSDST,PSDYR,QTY,REQD,REQDT,SEL,STAT,STATN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 KILL ^TMP("PSDRPT",$JOB)
DO ^%ZISC
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
