PSDRPT ;BIR/BJW-Reprint Misc (VA FORM 10-2321) ; 3 Mar 98
;;3.0; CONTROLLED SUBSTANCES ;**8,69**;13 Feb 97;Build 13
;**Y2K compliance** display 4 digit year on va forms
;Reference to PSD(58.8 supported by DBIA # 2711
;Reference to ^PSD(58.81 supported by DBIA2808
;Reference to ^PSD(58.86 supported by DBIA4472
;Reference to ^PSDRUG( supported by DBIA #221
;
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):1,$D(^XUSEC("PSD TECH ADV",DUZ)):1,1:0)
I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to reprint",!,?12,"this transfer copy of VA FORM 10-2321.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM or PSD TECH ADV security key required.",! K OK Q
W !!,"Reprint Transfer Between NAOUs VA FORM 10-2321",!
W $C(7),!,"Please note that you may reprint only the copy of the VA FORM 10-2321 for",!,"Green Sheets transferred from your NAOU that have NOT BEEN RECEIVED on",!,"the transfer to NAOU.",!
ASKN ;ask transfer from naou
W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer From NAOU: "
S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)"
D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2)
S TYPE=3 G GS
TYPE ;select type return to stock or turn in for destruction
K DA,DIR,DIRUT S DIR(0)="SO^1:RETURN TO STOCK;2:TURN IN FOR DESTRUCTION"
S DIR("A")="Select Type of VA FORM 10-2321 to Reprint"
S DIR("?",1)="Answer '1' to reprint a Return to Stock VA FORM 10-2321,"
S DIR("?",2)="answer '2' to reprint a Turn in For Destruction VA FORM 10-2321 or",DIR("?")="answer '^' to quit without reprinting any forms."
D ^DIR K DIR G:$D(DIRUT) END S TYPE=Y
G:TYPE'=2 GS
CHK ;check for type of destructions
W ! K DA,DIR,DIRUT S DIR(0)="YO",DIR("B")="YES",DIR("A")="Is this a Green Sheet Turn in for Destructions reprint"
S DIR("?",1)="Answer 'YES' to enter Green Sheet number, 'NO' to select",DIR("?")="a Holding for Destructions number, or '^' to quit."
D ^DIR K DIR I $D(DIRUT) D MSG1 G END
I 'Y D LOOK G:PSDOUT END G PRINT
GS ;select green sheet #
W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D"
S:TYPE=1 DIC("S")="I $P(^(0),""^"",3)=+PSDS,$P(^(0),""^"",12)=3"
S:TYPE=2 DIC("S")="I $P(^(0),""^"",3)=+PSDS,$P(^(0),""^"",12)=2"
S:TYPE=3 DIC("S")="I $P(^(0),""^"",11)=10,$P(^(0),""^"",18)=AOU"
D IX^DIC K DIC G:Y<0 END S PSDA=+Y
S PSDPN=$P(Y(0),"^",17),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3)
I TYPE'=3,'$D(^PSD(58.81,PSDA,3)) D MSG G:PSDOUT END
I TYPE=3,'$D(^PSD(58.81,PSDA,7)) D MSG G:PSDOUT END
I TYPE'=3 S NODE=^PSD(58.81,PSDA,3) S:TYPE=1 RECD=$P(NODE,"^"),RQTY=$P(NODE,"^",2),REAS=$P(NODE,"^",3) S:TYPE=2 RECD=$P(NODE,"^",4),RQTY=$P(NODE,"^",5),PSDHLD=$P(NODE,"^",8),REAS=$P(NODE,"^",6)
I TYPE=3 S NODE=^PSD(58.81,PSDA,7),RECD=$P(NODE,"^"),NAOUT=+$P(NODE,"^",3),RQTY=$P(NODE,"^",7),NAOUTN=$P($G(^PSD(58.8,NAOUT,0)),"^")
PRINT ;print 2321
;2nd line added for E3R# 3771 to print comments.
S REPRINT=1 S:'$D(REAS) REAS=""
S:$D(^PSD(58.86,+$G(PSDHLD),2)) PSDCOMS=$P(^(2),"^",1)
W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q
S COMP=$S(TYPE=1:3,TYPE=2:2,1:999)
I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT
S Y=RECD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4)
S (PG,PSDOUT)=0,RECDT=$E(RECD,4,5)_"/"_$E(RECD,6,7)_"/"_PSDYR
I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD
D ^PSDGSRV2
END K %,%DT,%H,%I,AOU,AOUN,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG
K NAOUT,NAOUTN,NODE,NUM,OK,ORD,PG,PSDCOMS,PSDA,PSDHLD,PSDOK,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDTYP,PSDUZ,PSDYR,REAS,RECD,RECDT,REPRINT,RQTY,STAT,STATN,SUM,TYPE,X,Y
Q
MSG ;check and write msg if not ok
W !!,"Green Sheet #",PSDPN," has not been ",$S(TYPE=1:"returned to stock",TYPE=2:"turned in for destruction",1:"transferred between NAOUs"),".",!
MSG1 W !,"No Reprint of VA FORM 10-2321",!!
S PSDOUT=1
Q
LOOK ;lookup destructions #
S PSDOUT=0
W ! K DA,DIC S DIC=58.86,DIC(0)="QEAZ",DIC("A")="Select Destructions Holding #: "
S DIC("S")="I $P(^(0),""^"",7)=+PSDS,'+$P(^(0),""^"",11)" D ^DIC K DIC I Y<0 D MSG1 Q
S PSDHLD=+Y,RQTY=+$P(Y(0),"^",3),RECD=+$P(Y(0),"^",6),PSDOK=1,PSDR=+$P(Y(0),"^",2),PSDRN=$S(PSDR:$P($G(^PSDRUG(+PSDR,0)),"^"),1:$G(^PSD(58.86,+PSDHLD,1)))
S:PSDRN']"" PSDRN="UNKNOWN" S (MFG,LOT,EXP)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRPT 4702 printed Dec 13, 2024@01:48:55 Page 2
PSDRPT ;BIR/BJW-Reprint Misc (VA FORM 10-2321) ; 3 Mar 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**8,69**;13 Feb 97;Build 13
+2 ;**Y2K compliance** display 4 digit year on va forms
+3 ;Reference to PSD(58.8 supported by DBIA # 2711
+4 ;Reference to ^PSD(58.81 supported by DBIA2808
+5 ;Reference to ^PSD(58.86 supported by DBIA4472
+6 ;Reference to ^PSDRUG( supported by DBIA #221
+7 ;
+8 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+9 SET OK=$SELECT($DATA(^XUSEC("PSJ RNURSE",DUZ)):1,$DATA(^XUSEC("PSD NURSE",DUZ)):1,$DATA(^XUSEC("PSJ RPHARM",DUZ)):1,$DATA(^XUSEC("PSD TECH ADV",DUZ)):1,1:0)
+10 IF 'OK
WRITE $CHAR(7),!!,?9,"** Please contact your Coordinator for access to reprint",!,?12,"this transfer copy of VA FORM 10-2321.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM or PSD TECH ADV security key required.",!
KILL OK
QUIT
+11 WRITE !!,"Reprint Transfer Between NAOUs VA FORM 10-2321",!
+12 WRITE $CHAR(7),!,"Please note that you may reprint only the copy of the VA FORM 10-2321 for",!,"Green Sheets transferred from your NAOU that have NOT BEEN RECEIVED on",!,"the transfer to NAOU.",!
ASKN ;ask transfer from naou
+1 WRITE !
KILL DA,DIC
SET DIC=58.8
SET DIC(0)="QEAZ"
SET DIC("A")="Select Transfer From NAOU: "
+2 SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)"
+3 DO ^DIC
KILL DIC
if Y<0
GOTO END
SET AOU=+Y
SET AOUN=$PIECE(Y,"^",2)
+4 SET TYPE=3
GOTO GS
TYPE ;select type return to stock or turn in for destruction
+1 KILL DA,DIR,DIRUT
SET DIR(0)="SO^1:RETURN TO STOCK;2:TURN IN FOR DESTRUCTION"
+2 SET DIR("A")="Select Type of VA FORM 10-2321 to Reprint"
+3 SET DIR("?",1)="Answer '1' to reprint a Return to Stock VA FORM 10-2321,"
+4 SET DIR("?",2)="answer '2' to reprint a Turn in For Destruction VA FORM 10-2321 or"
SET DIR("?")="answer '^' to quit without reprinting any forms."
+5 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET TYPE=Y
+6 if TYPE'=2
GOTO GS
CHK ;check for type of destructions
+1 WRITE !
KILL DA,DIR,DIRUT
SET DIR(0)="YO"
SET DIR("B")="YES"
SET DIR("A")="Is this a Green Sheet Turn in for Destructions reprint"
+2 SET DIR("?",1)="Answer 'YES' to enter Green Sheet number, 'NO' to select"
SET DIR("?")="a Holding for Destructions number, or '^' to quit."
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG1
GOTO END
+4 IF 'Y
DO LOOK
if PSDOUT
GOTO END
GOTO PRINT
GS ;select green sheet #
+1 WRITE !
KILL DA,DIC
SET DIC("A")="Select the Green Sheet #: "
SET DIC=58.81
SET DIC(0)="QEASZ"
SET D="D"
+2 if TYPE=1
SET DIC("S")="I $P(^(0),""^"",3)=+PSDS,$P(^(0),""^"",12)=3"
+3 if TYPE=2
SET DIC("S")="I $P(^(0),""^"",3)=+PSDS,$P(^(0),""^"",12)=2"
+4 if TYPE=3
SET DIC("S")="I $P(^(0),""^"",11)=10,$P(^(0),""^"",18)=AOU"
+5 DO IX^DIC
KILL DIC
if Y<0
GOTO END
SET PSDA=+Y
+6 SET PSDPN=$PIECE(Y(0),"^",17)
SET PSDR=+$PIECE(Y(0),"^",5)
SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
+7 SET MFG=$PIECE(Y(0),"^",13)
SET LOT=$PIECE(Y(0),"^",14)
SET EXP=$PIECE(Y(0),"^",15)
SET PSDS=+$PIECE(Y(0),"^",3)
+8 IF TYPE'=3
IF '$DATA(^PSD(58.81,PSDA,3))
DO MSG
if PSDOUT
GOTO END
+9 IF TYPE=3
IF '$DATA(^PSD(58.81,PSDA,7))
DO MSG
if PSDOUT
GOTO END
+10 IF TYPE'=3
SET NODE=^PSD(58.81,PSDA,3)
if TYPE=1
SET RECD=$PIECE(NODE,"^")
SET RQTY=$PIECE(NODE,"^",2)
SET REAS=$PIECE(NODE,"^",3)
if TYPE=2
SET RECD=$PIECE(NODE,"^",4)
SET RQTY=$PIECE(NODE,"^",5)
SET PSDHLD=$PIECE(NODE,"^",8)
SET REAS=$PIECE(NODE,"^",6)
+11 IF TYPE=3
SET NODE=^PSD(58.81,PSDA,7)
SET RECD=$PIECE(NODE,"^")
SET NAOUT=+$PIECE(NODE,"^",3)
SET RQTY=$PIECE(NODE,"^",7)
SET NAOUTN=$PIECE($GET(^PSD(58.8,NAOUT,0)),"^")
PRINT ;print 2321
+1 ;2nd line added for E3R# 3771 to print comments.
+2 SET REPRINT=1
if '$DATA(REAS)
SET REAS=""
+3 if $DATA(^PSD(58.86,+$GET(PSDHLD),2))
SET PSDCOMS=$PIECE(^(2),"^",1)
+4 WRITE !!,"Number of copies of VA FORM 10-2321? "
READ NUM:DTIME
IF '$TEST!(NUM="^")!(NUM="")
WRITE !!,"No copies printed!!",!!
QUIT
+5 SET COMP=$SELECT(TYPE=1:3,TYPE=2:2,1:999)
+6 IF NUM'?1N!(NUM=0)
WRITE !!,"Enter a whole number between 1 and 9",!
GOTO PRINT
+7 SET Y=RECD
XECUTE ^DD("DD")
SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
+8 SET (PG,PSDOUT)=0
SET RECDT=$EXTRACT(RECD,4,5)_"/"_$EXTRACT(RECD,6,7)_"/"_PSDYR
+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 DO ^PSDGSRV2
END KILL %,%DT,%H,%I,AOU,AOUN,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG
+1 KILL NAOUT,NAOUTN,NODE,NUM,OK,ORD,PG,PSDCOMS,PSDA,PSDHLD,PSDOK,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDTYP,PSDUZ,PSDYR,REAS,RECD,RECDT,REPRINT,RQTY,STAT,STATN,SUM,TYPE,X,Y
+2 QUIT
MSG ;check and write msg if not ok
+1 WRITE !!,"Green Sheet #",PSDPN," has not been ",$SELECT(TYPE=1:"returned to stock",TYPE=2:"turned in for destruction",1:"transferred between NAOUs"),".",!
MSG1 WRITE !,"No Reprint of VA FORM 10-2321",!!
+1 SET PSDOUT=1
+2 QUIT
LOOK ;lookup destructions #
+1 SET PSDOUT=0
+2 WRITE !
KILL DA,DIC
SET DIC=58.86
SET DIC(0)="QEAZ"
SET DIC("A")="Select Destructions Holding #: "
+3 SET DIC("S")="I $P(^(0),""^"",7)=+PSDS,'+$P(^(0),""^"",11)"
DO ^DIC
KILL DIC
IF Y<0
DO MSG1
QUIT
+4 SET PSDHLD=+Y
SET RQTY=+$PIECE(Y(0),"^",3)
SET RECD=+$PIECE(Y(0),"^",6)
SET PSDOK=1
SET PSDR=+$PIECE(Y(0),"^",2)
SET PSDRN=$SELECT(PSDR:$PIECE($GET(^PSDRUG(+PSDR,0)),"^"),1:$GET(^PSD(58.86,+PSDHLD,1)))
+5 if PSDRN']""
SET PSDRN="UNKNOWN"
SET (MFG,LOT,EXP)=""
+6 QUIT
