PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 6/25/07 12:16pm
;;3.0; CONTROLLED SUBSTANCES ;**64**;13 Feb 97;Build 33
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0)
I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",! K OK Q
I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q
W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")
ASKN ;ask transfer to naou
W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In 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)
GS ;select green sheet #
W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D"
S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)"
D IX^DIC K DIC G:Y<0 END S PSDA=+Y
S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^")
S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^")
S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^")
S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14)
S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3)
S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3)
S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7)
S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^")
S PAT=+$P($G(^PSD(58.81,PSDA,9)),U)
I STAT'=10 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END
;*64
I RQTY=0 W !!,"Quantity of zero was transferred. Use menu option",!,"'Receive GS for PCA/Infusion Signed Out to Patient'",! G END
D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END
D ^PSDNTT1
END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG
K NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y
K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J)
Q
CHK ;check transfer to naou
S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY
I AOU'=NAOU W " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$C(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"."
I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"."
W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO"
S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer."
D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNTT 3215 printed Dec 13, 2024@01:47:07 Page 2
PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 6/25/07 12:16pm
+1 ;;3.0; CONTROLLED SUBSTANCES ;**64**;13 Feb 97;Build 33
+2 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+3 SET OK=$SELECT($DATA(^XUSEC("PSJ RNURSE",DUZ)):1,$DATA(^XUSEC("PSD NURSE",DUZ)):1,1:0)
+4 IF 'OK
WRITE $CHAR(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",!
KILL OK
QUIT
+5 IF $PIECE($GET(^VA(200,DUZ,20)),U,4)']""
NEW XQH
SET XQH="PSD ESIG"
DO EN^XQH
QUIT
+6 WRITE !!,"Receive a transferred Green Sheet into this NAOU"
SET PSDUZ=DUZ
SET PSDUZN=$PIECE($GET(^VA(200,PSDUZ,0)),"^")
ASKN ;ask transfer to naou
+1 WRITE !
KILL DA,DIC
SET DIC=58.8
SET DIC(0)="QEAZ"
SET DIC("A")="Select Receive Transfer In 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)
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 SET DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)"
+3 DO IX^DIC
KILL DIC
if Y<0
GOTO END
SET PSDA=+Y
+4 SET STAT=+$PIECE(Y(0),"^",11)
SET PSDPN=$PIECE(Y(0),"^",17)
SET STATN=""
IF STAT
SET STATN=$PIECE($GET(^PSD(58.82,STAT,0)),"^")
+5 SET ORD=+$PIECE(Y(0),"^",20)
SET PSDRG=+$PIECE(Y(0),"^",5)
SET PSDRGN=$PIECE($GET(^PSDRUG(PSDRG,0)),"^")
+6 SET NAOUF=+$PIECE(Y(0),"^",18)
SET NAOUFN=$PIECE($GET(^PSD(58.8,+NAOUF,0)),"^")
+7 SET PSDSP=$PIECE($GET(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14)
+8 SET MFG=$PIECE(Y(0),"^",13)
SET LOT=$PIECE(Y(0),"^",14)
SET EXP=$PIECE(Y(0),"^",15)
SET PSDS=+$PIECE(Y(0),"^",3)
+9 SET QTY=+$PIECE(Y(0),"^",6)
IF $DATA(^PSD(58.81,+PSDA,4))
IF +$PIECE(^(4),"^",3)
SET QTY=+$PIECE(^(4),"^",3)
+10 SET RQTY=+$PIECE($GET(^PSD(58.81,PSDA,7)),"^",7)
+11 SET NAOU=+$PIECE($GET(^PSD(58.81,PSDA,7)),"^",3)
SET NAOUN=$PIECE($GET(^PSD(58.8,NAOU,0)),"^")
+12 SET PAT=+$PIECE($GET(^PSD(58.81,PSDA,9)),U)
+13 IF STAT'=10
WRITE !!,"This Green Sheet has a status of "_$SELECT(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",!
GOTO END
+14 ;*64
+15 IF RQTY=0
WRITE !!,"Quantity of zero was transferred. Use menu option",!,"'Receive GS for PCA/Infusion Signed Out to Patient'",!
GOTO END
+16 DO CHK
if PSDOUT
GOTO END
NEW X,X1
DO SIG^XUSESIG
if X1=""
GOTO END
+17 DO ^PSDNTT1
END KILL %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG
+1 KILL NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y
+2 KILL XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$JOB)
+3 QUIT
CHK ;check transfer to naou
+1 SET PSDOUT=0
WRITE !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY
+2 IF AOU'=NAOU
WRITE " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$CHAR(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"."
+3 IF AOU=NAOU
WRITE " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"."
+4 WRITE !
KILL DA,DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Do you wish to complete this transfer"
SET DIR("B")="NO"
+5 SET DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,"
SET DIR("?")="answer 'NO' or '^' to quit without completing the transfer."
+6 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
SET PSDOUT=1
WRITE !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!!
QUIT
+7 QUIT
