- 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 Feb 18, 2025@23:15:23 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