PSDEN ;BIR/JPW-Enter NAOUs ; 6 July 94
;;3.0;CONTROLLED SUBSTANCES;**84,87**;13 Feb 97;Build 1
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSD PARAM",DUZ)) W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to enter/edit",!,?12,"NAOUs. PSD PARAM security key required.",! Q
S SITEN=$P($G(^PS(59.4,+PSDSITE,0)),"^"),MULTI=$S($P(PSDSITE,"^",2)="M":1,1:0)
NAOU ;entry for NAOUs into file 58.8
K DIC,DLAYGO W ! S (DIC,DLAYGO)=58.8,DIC(0)="QEAL",DIC("A")="Select NAOU: ",DIC("DR")="2////"_+PSDSITE,DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)'=""P"""
D ^DIC K DIC,DLAYGO G:Y<0 END S PSDA=+Y,NEW=+$P(Y,"^",3) D TYPE
G NAOU
END K ANS,DA,DIC,DIE,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,MULTI,NEW,PSDA,SITEN,X,Y
Q
TYPE ;selects location type
W !!,"CONTROLLED SUBSTANCES SITE : "_SITEN
I $P(^PSD(58.8,PSDA,0),"^",2)]"",+$O(^PSD(58.8,PSDA,1,0)) S ANS=$P(^PSD(58.8,PSDA,0),"^",2) G DIE
K ANS,DIR,DIRUT S DIR(0)="S^M:MASTER VAULT;S:SATELLITE VAULT;N:NARCOTIC LOCATION",DIR("A")="LOCATION TYPE"
S DIR("?")="'S' for Satellite Vault or 'N' for Narcotic location.",DIR("?",1)="Enter this NAOU's type. Select 'M' for Master Vault,"
S:$P(^PSD(58.8,PSDA,0),"^",2)]"" DIR("B")=$P(^(0),"^",2) D ^DIR K DIR
I $D(DIRUT),NEW K DIK S DIK="^PSD(58.8,",DA=+PSDA D ^DIK K DIK W $C(7),!!,"No location type entered. Entry has been deleted!",!! Q
Q:$D(DIRUT) S ANS=Y
DIE ;edit
S PSDJLP=1
K DA,DIE,DR S DIE=58.8,DA=PSDA
S:ANS="M" DR=".01T;1////"_ANS_";Q;5;3///@;14;I 'X S Y=19;15;Q;16;Q;17;Q;19;19.5;23;24;25;26;29;28;30;12;S:'$P(^(0),U,8) Y=37;13;37" ;RTW change and add Y=37;13;37 for balance discrepancy on off
S:ANS="S" DR=".01T;1////"_ANS_";Q;3;5;14;I 'X S Y=19;15;Q;16;Q;17;Q;19;19.5;23;24;25;26;29;28;30"
S:ANS="N" DR=".01T;1////"_ANS_";Q;3;18;6T;32;33"
D ^DIE K DIE,DR,DA,PSDJLP
;link ward for dispensing equipment interface
D:$O(^HL(770,"B","PSD-NDES",0))&(ANS="N")
WARD .I $O(^PSD(58.8,+PSDA,3,0)) W !!,"Current Ward(s): " S PSDA(1)=0 F S PSDA(1)=$O(^PSD(58.8,+PSDA,3,PSDA(1))) Q:'PSDA(1) W ?20,$P($G(^DIC(42,+PSDA(1),0)),U),!
.S DIR(0)="PO^42:AEMQ"
.S DIR("A")="Select Ward for dispensing equipment interface"
.S DIR("?")="When doses are dispensed the ward will be used as a path to this NAOU."
.W ! D ^DIR K DIR Q:Y<1 S PSDA(1)=0,PSDA(2)=+Y,PSDA(3)=$P(Y,U,2)
.I $D(^PSD(58.8,"AB",PSDA(2),PSDA)) D Q:$D(DIRUT) G WARD
..S DIR(0)="Y",DIR("A")="Remove "_PSDA(3)_"'s link to "_$P($G(^PSD(58.8,+PSDA,0)),U) D ^DIR K DIR
..I Y=1 W !!,PSDA(3)," removed.",! S DIK="^PSD(58.8,+PSDA,3,",DA(1)=PSDA,DA=PSDA(2) D ^DIK K DIK,DA
.F S PSDA(1)=$O(^PSD(58.8,"AB",PSDA(2),PSDA(1))) Q:'PSDA(1) S:$P($G(^PSD(58.8,PSDA(1),0)),U,2)="N"&(PSDA'=PSDA(1)) PSDA(4)=$P($G(^(0)),U)
.I $G(PSDA(4))]"" W !!,PSDA(3)," is already linked to ",PSDA(4),"." K PSDA(4) G WARD
.S DIC="^PSD(58.8,"_+PSDA_",3,",DIC(0)="LM",DLAYGO=58.8,DA(1)=PSDA
.S X=PSDA(3),DA=PSDA(2),DIC("P")=$P(^DD(58.8,21,0),U,2),DINUM=PSDA(2)
.D ^DIC K DIC,DA,DLAYGO G WARD
;Set up Default Dispensing Site
I "MS"[ANS S $P(PSDSITE,U,3)=PSDA,$P(PSDSITE,U,4)=$P($G(^PSD(58.8,+PSDA,0)),U),$P(PSDSITE,U,5)=0 D EN^PSDSP S:$G(PSDS) $P(PSDSITE,U,5)=1
K PSDA,PSDS,PSDSN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEN 3206 printed Apr 09, 2024@20:53:48 Page 2
PSDEN ;BIR/JPW-Enter NAOUs ; 6 July 94
+1 ;;3.0;CONTROLLED SUBSTANCES;**84,87**;13 Feb 97;Build 1
+2 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+3 IF '$DATA(^XUSEC("PSD PARAM",DUZ))
WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to enter/edit",!,?12,"NAOUs. PSD PARAM security key required.",!
QUIT
+4 SET SITEN=$PIECE($GET(^PS(59.4,+PSDSITE,0)),"^")
SET MULTI=$SELECT($PIECE(PSDSITE,"^",2)="M":1,1:0)
NAOU ;entry for NAOUs into file 58.8
+1 KILL DIC,DLAYGO
WRITE !
SET (DIC,DLAYGO)=58.8
SET DIC(0)="QEAL"
SET DIC("A")="Select NAOU: "
SET DIC("DR")="2////"_+PSDSITE
SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)'=""P"""
+2 DO ^DIC
KILL DIC,DLAYGO
if Y<0
GOTO END
SET PSDA=+Y
SET NEW=+$PIECE(Y,"^",3)
DO TYPE
+3 GOTO NAOU
END KILL ANS,DA,DIC,DIE,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,MULTI,NEW,PSDA,SITEN,X,Y
+1 QUIT
TYPE ;selects location type
+1 WRITE !!,"CONTROLLED SUBSTANCES SITE : "_SITEN
+2 IF $PIECE(^PSD(58.8,PSDA,0),"^",2)]""
IF +$ORDER(^PSD(58.8,PSDA,1,0))
SET ANS=$PIECE(^PSD(58.8,PSDA,0),"^",2)
GOTO DIE
+3 KILL ANS,DIR,DIRUT
SET DIR(0)="S^M:MASTER VAULT;S:SATELLITE VAULT;N:NARCOTIC LOCATION"
SET DIR("A")="LOCATION TYPE"
+4 SET DIR("?")="'S' for Satellite Vault or 'N' for Narcotic location."
SET DIR("?",1)="Enter this NAOU's type. Select 'M' for Master Vault,"
+5 if $PIECE(^PSD(58.8,PSDA,0),"^",2)]""
SET DIR("B")=$PIECE(^(0),"^",2)
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
IF NEW
KILL DIK
SET DIK="^PSD(58.8,"
SET DA=+PSDA
DO ^DIK
KILL DIK
WRITE $CHAR(7),!!,"No location type entered. Entry has been deleted!",!!
QUIT
+7 if $DATA(DIRUT)
QUIT
SET ANS=Y
DIE ;edit
+1 SET PSDJLP=1
+2 KILL DA,DIE,DR
SET DIE=58.8
SET DA=PSDA
+3 ;RTW change and add Y=37;13;37 for balance discrepancy on off
if ANS="M"
SET DR=".01T;1////"_ANS_";Q;5;3///@;14;I 'X S Y=19;15;Q;16;Q;17;Q;19;19.5;23;24;25;26;29;28;30;12;S:'$P(^(0),U,8) Y=37;13;37"
+4 if ANS="S"
SET DR=".01T;1////"_ANS_";Q;3;5;14;I 'X S Y=19;15;Q;16;Q;17;Q;19;19.5;23;24;25;26;29;28;30"
+5 if ANS="N"
SET DR=".01T;1////"_ANS_";Q;3;18;6T;32;33"
+6 DO ^DIE
KILL DIE,DR,DA,PSDJLP
+7 ;link ward for dispensing equipment interface
+8 if $ORDER(^HL(770,"B","PSD-NDES",0))&(ANS="N")
Begin DoDot:1
WARD IF $ORDER(^PSD(58.8,+PSDA,3,0))
WRITE !!,"Current Ward(s): "
SET PSDA(1)=0
FOR
SET PSDA(1)=$ORDER(^PSD(58.8,+PSDA,3,PSDA(1)))
if 'PSDA(1)
QUIT
WRITE ?20,$PIECE($GET(^DIC(42,+PSDA(1),0)),U),!
+1 SET DIR(0)="PO^42:AEMQ"
+2 SET DIR("A")="Select Ward for dispensing equipment interface"
+3 SET DIR("?")="When doses are dispensed the ward will be used as a path to this NAOU."
+4 WRITE !
DO ^DIR
KILL DIR
if Y<1
QUIT
SET PSDA(1)=0
SET PSDA(2)=+Y
SET PSDA(3)=$PIECE(Y,U,2)
+5 IF $DATA(^PSD(58.8,"AB",PSDA(2),PSDA))
Begin DoDot:2
+6 SET DIR(0)="Y"
SET DIR("A")="Remove "_PSDA(3)_"'s link to "_$PIECE($GET(^PSD(58.8,+PSDA,0)),U)
DO ^DIR
KILL DIR
+7 IF Y=1
WRITE !!,PSDA(3)," removed.",!
SET DIK="^PSD(58.8,+PSDA,3,"
SET DA(1)=PSDA
SET DA=PSDA(2)
DO ^DIK
KILL DIK,DA
End DoDot:2
if $DATA(DIRUT)
QUIT
GOTO WARD
+8 FOR
SET PSDA(1)=$ORDER(^PSD(58.8,"AB",PSDA(2),PSDA(1)))
if 'PSDA(1)
QUIT
if $PIECE($GET(^PSD(58.8,PSDA(1),0)),U,2)="N"&(PSDA'=PSDA(1))
SET PSDA(4)=$PIECE($GET(^(0)),U)
+9 IF $GET(PSDA(4))]""
WRITE !!,PSDA(3)," is already linked to ",PSDA(4),"."
KILL PSDA(4)
GOTO WARD
+10 SET DIC="^PSD(58.8,"_+PSDA_",3,"
SET DIC(0)="LM"
SET DLAYGO=58.8
SET DA(1)=PSDA
+11 SET X=PSDA(3)
SET DA=PSDA(2)
SET DIC("P")=$PIECE(^DD(58.8,21,0),U,2)
SET DINUM=PSDA(2)
+12 DO ^DIC
KILL DIC,DA,DLAYGO
GOTO WARD
End DoDot:1
+13 ;Set up Default Dispensing Site
+14 IF "MS"[ANS
SET $PIECE(PSDSITE,U,3)=PSDA
SET $PIECE(PSDSITE,U,4)=$PIECE($GET(^PSD(58.8,+PSDA,0)),U)
SET $PIECE(PSDSITE,U,5)=0
DO EN^PSDSP
if $GET(PSDS)
SET $PIECE(PSDSITE,U,5)=1
+15 KILL PSDA,PSDS,PSDSN
QUIT
