- 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 Feb 18, 2025@23:15:19 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
