Changeset 623 for WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m
r613 r623 1 PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 6/25/07 12:16pm 2 ;;3.0; CONTROLLED SUBSTANCES ;**64**;13 Feb 97;Build 33 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) 5 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 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer to naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " 10 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)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") 18 S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") 19 S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) 20 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) 21 S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 22 S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) 23 S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") 24 S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) 25 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 26 ;*64 27 I RQTY=0 W !!,"Quantity of zero was transferred. Use menu option",!,"'Receive GS for PCA/Infusion Signed Out to Patient'",! G END 28 D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END 29 D ^PSDNTT1 30 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 31 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 32 K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) 33 Q 34 CHK ;check transfer to naou 35 S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY 36 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,"." 37 I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." 38 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" 39 S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." 40 D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q 41 Q 1 PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 22 Jun 93 2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) 5 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 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer to naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " 10 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)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") 18 S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") 19 S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) 20 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) 21 S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 22 S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) 23 S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") 24 S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) 25 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 26 D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END 27 D ^PSDNTT1 28 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 29 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 30 K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) 31 Q 32 CHK ;check transfer to naou 33 S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY 34 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,"." 35 I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." 36 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" 37 S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." 38 D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q 39 Q
Note:
See TracChangeset
for help on using the changeset viewer.
