- 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 Jan 18, 2025@02:50:11 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