PSDSET ;BIR/JPW-Check Inpatient Site for CS Use ;6 July 94
;;3.0; CONTROLLED SUBSTANCES ;**59**;13 Feb 97;Build 1
SITE ;checks for valid cs inpatient site
K XQUIT,X,PSDA,LOC I '$D(^PS(59.4,"B")) D G:$G(XQUIT)="" END1 G END
.W ! K DA,DIC,DIE,DLAYGO,DR S (DIC,DIE,DLAYGO)=59.4,DIC("A")="Enter Controlled Substances Inpatient Site Name: ",DIC(0)="QEAL" D ^DIC K DIC,DLAYGO I Y<0 S XQUIT="" Q
.S (DA,PSDA)=+Y,DR="31///1" D ^DIE K DIE,DR S PSDSITE=PSDA
LOOP S (CNT,LOC,PSDA)=0 F PSDA=0:0 S PSDA=$O(^PS(59.4,PSDA)) Q:'PSDA S CNT=CNT+1 S:$P(^PS(59.4,PSDA,0),"^",31) LOC=LOC+1,LOC(+PSDA)=""
CHK I LOC=1 S PSDSITE=+$O(LOC(0)) W !!,"Controlled Substances Inpatient Site Name: "_$P(^PS(59.4,PSDSITE,0),"^")
I 'LOC,CNT=1 S PSDA=$O(^PS(59.4,0)),$P(^(PSDA,0),"^",31)=1,PSDSITE=+^(0) W !!,"Controlled Substances Inpatient Site Name: "_$P(^(0),"^")
I CNT>1,LOC'=1 D G:'$G(PSDSITE) END1
.K DIC,DLAYGO S (DIC,DLAYGO)=59.4,DIC("A")="Enter Controlled Substances Inpatient Site Name: ",DIC(0)="QEA" S:LOC>1 DIC("S")="I $P(^(0),""^"",31)" S:LOC=0 DIC(0)="QEAL" D ^DIC K DIC,DLAYGO
.S:Y<0 XQUIT="" Q:Y<0 S $P(^PS(59.4,+Y,0),"^",31)=1,PSDSITE=+Y_"^M"
END K LOC,PSDS,PSDSN,PSDCHO D EN^PSDSP
I $G(PSDS) S $P(PSDSITE,U,3)=PSDS,$P(PSDSITE,U,4)=$P($G(^PSD(58.8,+PSDS,0)),U),$P(PSDSITE,U,5)=1 Q
;Set up Default Dispensing Site
D:'$P(PSDSITE,U,3)&($P($G(XQY0),U)'["NUR")&($P($G(XQY0),U)'["INS")
.;Make sure there's at least one Master Vault
.Q:'$O(^PSD(58.8,"ASITE",+PSDSITE,"M",0))
.S DIC="^PSD(58.8,",DIC(0)="AEQ"
.S DIC("A")="Select Default Dispensing Site: "
.S DIC("S")="I $P($G(^(0)),U,3)=+PSDSITE,$S($P($G(^(0)),U,2)[""M"":1,$P($G(^(0)),U,2)[""S"":1,1:0),$S('$D(^(""I"")):1,+^(""I"")>DT:1,'^(""I""):1,1:0)"
.W ! D ^DIC K DIC S:$D(DTOUT) XQUIT="" Q:Y<0
.S $P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=$P(Y,U,2)
END1 K CNT,DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,LOC,PSDA,PSDS,PSDSN,X,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDSET 1890 printed Dec 13, 2024@01:48:58 Page 2
PSDSET ;BIR/JPW-Check Inpatient Site for CS Use ;6 July 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**59**;13 Feb 97;Build 1
SITE ;checks for valid cs inpatient site
+1 KILL XQUIT,X,PSDA,LOC
IF '$DATA(^PS(59.4,"B"))
Begin DoDot:1
+2 WRITE !
KILL DA,DIC,DIE,DLAYGO,DR
SET (DIC,DIE,DLAYGO)=59.4
SET DIC("A")="Enter Controlled Substances Inpatient Site Name: "
SET DIC(0)="QEAL"
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
SET XQUIT=""
QUIT
+3 SET (DA,PSDA)=+Y
SET DR="31///1"
DO ^DIE
KILL DIE,DR
SET PSDSITE=PSDA
End DoDot:1
if $GET(XQUIT)=""
GOTO END1
GOTO END
LOOP SET (CNT,LOC,PSDA)=0
FOR PSDA=0:0
SET PSDA=$ORDER(^PS(59.4,PSDA))
if 'PSDA
QUIT
SET CNT=CNT+1
if $PIECE(^PS(59.4,PSDA,0),"^",31)
SET LOC=LOC+1
SET LOC(+PSDA)=""
CHK IF LOC=1
SET PSDSITE=+$ORDER(LOC(0))
WRITE !!,"Controlled Substances Inpatient Site Name: "_$PIECE(^PS(59.4,PSDSITE,0),"^")
+1 IF 'LOC
IF CNT=1
SET PSDA=$ORDER(^PS(59.4,0))
SET $PIECE(^(PSDA,0),"^",31)=1
SET PSDSITE=+^(0)
WRITE !!,"Controlled Substances Inpatient Site Name: "_$PIECE(^(0),"^")
+2 IF CNT>1
IF LOC'=1
Begin DoDot:1
+3 KILL DIC,DLAYGO
SET (DIC,DLAYGO)=59.4
SET DIC("A")="Enter Controlled Substances Inpatient Site Name: "
SET DIC(0)="QEA"
if LOC>1
SET DIC("S")="I $P(^(0),""^"",31)"
if LOC=0
SET DIC(0)="QEAL"
DO ^DIC
KILL DIC,DLAYGO
+4 if Y<0
SET XQUIT=""
if Y<0
QUIT
SET $PIECE(^PS(59.4,+Y,0),"^",31)=1
SET PSDSITE=+Y_"^M"
End DoDot:1
if '$GET(PSDSITE)
GOTO END1
END KILL LOC,PSDS,PSDSN,PSDCHO
DO EN^PSDSP
+1 IF $GET(PSDS)
SET $PIECE(PSDSITE,U,3)=PSDS
SET $PIECE(PSDSITE,U,4)=$PIECE($GET(^PSD(58.8,+PSDS,0)),U)
SET $PIECE(PSDSITE,U,5)=1
QUIT
+2 ;Set up Default Dispensing Site
+3 if '$PIECE(PSDSITE,U,3)&($PIECE($GET(XQY0),U)'["NUR")&($PIECE($GET(XQY0),U)'["INS")
Begin DoDot:1
+4 ;Make sure there's at least one Master Vault
+5 if '$ORDER(^PSD(58.8,"ASITE",+PSDSITE,"M",0))
QUIT
+6 SET DIC="^PSD(58.8,"
SET DIC(0)="AEQ"
+7 SET DIC("A")="Select Default Dispensing Site: "
+8 SET DIC("S")="I $P($G(^(0)),U,3)=+PSDSITE,$S($P($G(^(0)),U,2)[""M"":1,$P($G(^(0)),U,2)[""S"":1,1:0),$S('$D(^(""I"")):1,+^(""I"")>DT:1,'^(""I""):1,1:0)"
+9 WRITE !
DO ^DIC
KILL DIC
if $DATA(DTOUT)
SET XQUIT=""
if Y<0
QUIT
+10 SET $PIECE(PSDSITE,U,3)=+Y
SET $PIECE(PSDSITE,U,4)=$PIECE(Y,U,2)
End DoDot:1
END1 KILL CNT,DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,LOC,PSDA,PSDS,PSDSN,X,Y
