- 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 Feb 18, 2025@23:14:45 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
