Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m

    r613 r623  
    1 PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95
    2         ;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5
    3 SITE    ;entry for selecting inpatient sites in file 59.4
    4         K DIC,DLAYGO S DIC="^PS(59.4,",DLAYGO=59.4,DIC(0)="QEAL",D="B",DZ="??"
    5         D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END
    6         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
    7 END     K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y
    8         Q
    9         ;
    10 LOW     ;if auto generate, check low range for numbers
    11         I '$D(X) S PSDFLAG=1 Q
    12         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
    13         .I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)=""
    14         I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD  D
    15         .I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q
    16         W:$D(PSDFLAG) "  Select another range.",! K PSD,PSDL
    17         Q
    18         ;
    19 HIGH    ;validates high range for dispensing numbers
    20         I '$D(X) S PSDFLAG=1 Q
    21         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
    22         .I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD
    23         S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^")
    24         I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q
    25         I PSDH,X'<PSDH D MSG S PSDFLAG=1
    26         W:$D(PSDFLAG) "  Select another range.",! K PSD,PSDH,PSDL
    27         Q
    28         ;
    29 MSG     ;prints message if range already in use
    30         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)_"."
    31         Q
    32         ;
    33 LAST    ;checks range for 'last dispensed'
    34         I '$D(X) S PSDFLAG=1 Q
    35         I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q
    36         I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q
    37         I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1
    38         Q
    39         ;
    40 MSG1    ;prints message if not in dispensing range
    41         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)_".",!
    42         Q
    43 LAST1   ;checks LOW/HIGH range and LAST dispensed
    44         I X<LOW D MSG2 S PSDFLAG=1 Q
    45         I X>HIGH D MSG2 S PSDFLAG=1
    46         Q
    47 MSG2    ;prints msg if not in dispensing range
    48         S PSDCHK=1
    49         W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",!
    50         Q
     1PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95
     2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
     3SITE ;entry for selecting inpatient sites in file 59.4
     4 K DIC,DLAYGO S (DIC,DLAYGO)="^PS(59.4,",DIC(0)="QEAL",D="B",DZ="??"
     5 D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END
     6 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
     7END K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y
     8 Q
     9 ;
     10LOW ;if auto generate, check low range for numbers
     11 I '$D(X) S PSDFLAG=1 Q
     12 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
     13 .I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)=""
     14 I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD  D
     15 .I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q
     16 W:$D(PSDFLAG) "  Select another range.",! K PSD,PSDL
     17 Q
     18 ;
     19HIGH ;validates high range for dispensing numbers
     20 I '$D(X) S PSDFLAG=1 Q
     21 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
     22 .I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD
     23 S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^")
     24 I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q
     25 I PSDH,X'<PSDH D MSG S PSDFLAG=1
     26 W:$D(PSDFLAG) "  Select another range.",! K PSD,PSDH,PSDL
     27 Q
     28 ;
     29MSG ;prints message if range already in use
     30 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)_"."
     31 Q
     32 ;
     33LAST ;checks range for 'last dispensed'
     34 I '$D(X) S PSDFLAG=1 Q
     35 I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q
     36 I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q
     37 I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1
     38 Q
     39 ;
     40MSG1 ;prints message if not in dispensing range
     41 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)_".",!
     42 Q
     43LAST1 ;checks LOW/HIGH range and LAST dispensed
     44 I X<LOW D MSG2 S PSDFLAG=1 Q
     45 I X>HIGH D MSG2 S PSDFLAG=1
     46 Q
     47MSG2 ;prints msg if not in dispensing range
     48 S PSDCHK=1
     49 W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",!
     50 Q
Note: See TracChangeset for help on using the changeset viewer.