PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95
;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5
SITE ;entry for selecting inpatient sites in file 59.4
K DIC,DLAYGO S DIC="^PS(59.4,",DLAYGO=59.4,DIC(0)="QEAL",D="B",DZ="??"
D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END
K DA,DIE,DR S DIE=59.4,DA=+Y,DR="31"_"Is "_$P(Y,U,2)_" selectable for Controlled Subs" W ! D ^DIE K DIE
END K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y
Q
;
LOW ;if auto generate, check low range for numbers
I '$D(X) S PSDFLAG=1 Q
K PSD,PSDFLAG,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D
.I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)=""
I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD D
.I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q
W:$D(PSDFLAG) " Select another range.",! K PSD,PSDL
Q
;
HIGH ;validates high range for dispensing numbers
I '$D(X) S PSDFLAG=1 Q
K PSD,PSDFLAG,PSDH,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D
.I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD
S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^")
I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q
I PSDH,X'<PSDH D MSG S PSDFLAG=1
W:$D(PSDFLAG) " Select another range.",! K PSD,PSDH,PSDL
Q
;
MSG ;prints message if range already in use
W $C(7),!!,?12," => Dispensing Site "_$S($P(^PSD(58.8,PSD,0),"^")]"":$P(^(0),"^"),1:"NAME MISSING")_" <=",!,"has set aside the range "_$P($G(^PSD(58.8,PSD,2)),"^",2)_" through "_$P($G(^(2)),"^",3)_"."
Q
;
LAST ;checks range for 'last dispensed'
I '$D(X) S PSDFLAG=1 Q
I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q
I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q
I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1
Q
;
MSG1 ;prints message if not in dispensing range
W $C(7),!!,"Last number dispensed must be within the range "_$P($G(^PSD(58.8,DA,2)),"^",2)_" to "_$S($P($G(^(2)),"^",3):$P($G(^(2)),"^",3),1:999999999)_".",!
Q
LAST1 ;checks LOW/HIGH range and LAST dispensed
I X<LOW D MSG2 S PSDFLAG=1 Q
I X>HIGH D MSG2 S PSDFLAG=1
Q
MSG2 ;prints msg if not in dispensing range
S PSDCHK=1
W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDSITE 2426 printed Oct 16, 2024@17:49:49 Page 2
PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5
SITE ;entry for selecting inpatient sites in file 59.4
+1 KILL DIC,DLAYGO
SET DIC="^PS(59.4,"
SET DLAYGO=59.4
SET DIC(0)="QEAL"
SET D="B"
SET DZ="??"
+2 DO DQ^DICQ
KILL D,DZ
WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO END
+3 KILL DA,DIE,DR
SET DIE=59.4
SET DA=+Y
SET DR="31"_"Is "_$PIECE(Y,U,2)_" selectable for Controlled Subs"
WRITE !
DO ^DIE
KILL DIE
END KILL DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y
+1 QUIT
+2 ;
LOW ;if auto generate, check low range for numbers
+1 IF '$DATA(X)
SET PSDFLAG=1
QUIT
+2 KILL PSD,PSDFLAG,PSDL
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,PSD,0))
IF $DATA(^(2))
IF $PIECE(^(2),"^")
Begin DoDot:1
+3 IF +$PIECE(^PSD(58.8,PSD,2),"^",2)
IF +$PIECE(^(2),"^",3)
SET PSDL(+PSD)=""
End DoDot:1
+4 IF $ORDER(PSDL(0))
FOR PSD=0:0
SET PSD=+$ORDER(PSDL(PSD))
if 'PSD
QUIT
Begin DoDot:1
+5 IF X'<$PIECE($GET(^PSD(58.8,PSD,2)),"^",2)
IF (X'>$PIECE($GET(^(2)),"^",3))
IF PSD'=DA
DO MSG
SET PSDFLAG=1
QUIT
End DoDot:1
+6 if $DATA(PSDFLAG)
WRITE " Select another range.",!
KILL PSD,PSDL
+7 QUIT
+8 ;
HIGH ;validates high range for dispensing numbers
+1 IF '$DATA(X)
SET PSDFLAG=1
QUIT
+2 KILL PSD,PSDFLAG,PSDH,PSDL
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,PSD,0))
IF $DATA(^(2))
IF $PIECE(^(2),"^")
Begin DoDot:1
+3 IF +$PIECE(^PSD(58.8,PSD,2),"^",2)
SET PSDL(+$PIECE(^(2),"^",2))=PSD
End DoDot:1
+4 SET PSDL=+$PIECE($GET(^PSD(58.8,DA,2)),"^",2)
SET PSDH=+$ORDER(PSDL(PSDL))
IF PSDH
SET PSD=+$PIECE(PSDL(PSDH),"^")
+5 IF X'>PSDL
WRITE !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!!
SET PSDFLAG=1
QUIT
+6 IF PSDH
IF X'<PSDH
DO MSG
SET PSDFLAG=1
+7 if $DATA(PSDFLAG)
WRITE " Select another range.",!
KILL PSD,PSDH,PSDL
+8 QUIT
+9 ;
MSG ;prints message if range already in use
+1 WRITE $CHAR(7),!!,?12," => Dispensing Site "_$SELECT($PIECE(^PSD(58.8,PSD,0),"^")]"":$PIECE(^(0),"^"),1:"NAME MISSING")_" <=",!,"has set aside the range "_$PIECE($GET(^PSD(58.8,PSD,2)),"^",2)_" through "_$PIECE($GET(^(2)),"^",3)_"."
+2 QUIT
+3 ;
LAST ;checks range for 'last dispensed'
+1 IF '$DATA(X)
SET PSDFLAG=1
QUIT
+2 IF $DATA(PSDEN)
DO LAST1
KILL LOW,HIGH,PSDCHK
QUIT
+3 IF X<$PIECE($GET(^PSD(58.8,DA,2)),"^",2)
DO MSG1
SET PSDFLAG=1
QUIT
+4 IF X>$PIECE($GET(^PSD(58.8,DA,2)),"^",3)
DO MSG1
SET PSDFLAG=1
+5 QUIT
+6 ;
MSG1 ;prints message if not in dispensing range
+1 WRITE $CHAR(7),!!,"Last number dispensed must be within the range "_$PIECE($GET(^PSD(58.8,DA,2)),"^",2)_" to "_$SELECT($PIECE($GET(^(2)),"^",3):$PIECE($GET(^(2)),"^",3),1:999999999)_".",!
+2 QUIT
LAST1 ;checks LOW/HIGH range and LAST dispensed
+1 IF X<LOW
DO MSG2
SET PSDFLAG=1
QUIT
+2 IF X>HIGH
DO MSG2
SET PSDFLAG=1
+3 QUIT
MSG2 ;prints msg if not in dispensing range
+1 SET PSDCHK=1
+2 WRITE $CHAR(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",!
+3 QUIT
