source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDORN1.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1PSDORN1 ;BIR/JPW,LTL-Nurse CS Order Entry (cont'd) ;12/14/99 16:09
2 ;;3.0; CONTROLLED SUBSTANCES ;**20,66**;13 Feb 97;Build 3
3 ;
4 ; Reference to DPT( supported by DBIA # 10035
5 ; Reference to PSD(58.8 supported by DBIA # 2711
6 ; Reference to VA(200 supported by DBIA # 10060
7 ; Line tag SIG^XUSESIG supported by DBIA # 10050
8 ;
9 I $D(ORD) F CNT1=1:1:CNT S PSDA=+ORD(CNT1) D ASK
10 Q
11ASK ;displays order for review
12 D DISPLAY
13 W !! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK",DIR("?",1)="Answer 'YES' to send this request to pharmacy for processing,"
14 S DIR("?",2)="or 'NO' to edit or delete this request",DIR("?")="or '^' to quit and DELETE this CS order request." D ^DIR K DIR
15 I $D(DIRUT) S PSDOUT=1 D DEL Q
16 I 'Y D EDIT Q:PSDOUT G ASK
17 I Y N X,X1 D SIG^XUSESIG S:X1="" PSDOUT=1 D:X1="" DEL Q:X1="" D
18 .D PHARM W !! W:$D(ORD) "Your order request #"_CNT1_" of "_CNT
19 .W ?32,"Sent to Pharmacy...",!!
20 .R:$D(ORD) "Press <RET> to continue",X:DTIME,!!
21 Q
22DISPLAY ;displays order request to screen
23 K LN S $P(LN,"-",80)=""
24 W @IOF,!,?17,"Controlled Substance "
25 W:$G(PSDEM) "*PRIORITY PICK UP* "
26 W "Order Request" I $D(ORD) W " # "_CNT1_" of "_CNT
27 W:$G(PAT) !!,"Patient: ",$P($G(^DPT(PAT,0)),U),!!
28 W !!,"Pharmacy Dispensing #: ",!
29 W "Requested by",?16,": ",$P($G(^VA(200,PSDUZ,0)),"^")
30 W ?51,$S($G(PSDT(9))]"":"Needed by: "_PSDT(9),1:"Request Date: "_REQD),!,LN,!
31 W !,"Drug",?16,": ",PSDRN,?56,"Quantity: ",?66,PSDQTY,!,"Dispensed by",?16,": N/A",?50,"Dispensed Date: N/A"
32 W !,"Disp. Location",?16,": " W:+PSDS $P($G(^PSD(58.8,+PSDS,0)),"^") W !,"Exp. Date",?16,": ",!,"Manufacturer",?16,": ",!,"Lot #",?16,": "
33 W !,"Ord. Location",?16,": ",NAOUN,!,"Order Status",?16,": ",$P($G(^PSD(58.82,1,0)),"^"),!,"Comments:"
34 I $D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)) K ^UTILITY($J,"W") F TEXT=0:0 S TEXT=$O(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT)) Q:'TEXT D
35 .S X=$G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT,0)),DIWL=5,DIWR=75,DIWF="W" D ^DIWP
36 I D ^DIWW
37 Q
38EDIT ;edit or delete order request
39 W !!,"Edit or Delete this Order Request: EDIT// " R X:DTIME I '$T S PSDOUT=1 D DEL Q
40 Q:X["^" S X=$E(X) S:X="" X="E" I "EeDd"'[X W !!,"Press <RET> to edit this order request, or enter 'D' to delete the request.",! G EDIT
41 I "Dd"[X D DEL Q
42 K DA,DIE,DR S DA=PSDA,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DR="13" D ^DIE K DIE,DR
43 Q
44DEL ;deletes order request
45 S PSDOUT=1 W !!,?25,"Request being deleted...",! K DIK S DA=PSDA,DA(1)=PSDR,DA(2)=NAOU,DIK="^PSD(58.8,"_NAOU_",1,"_PSDR_",3," D ^DIK K DIK
46 Q
47PHARM ;create worksheet entry in file 58.85
48 I $D(XRTL) D T0^%ZOSV
49 W ?5,!!,"Processing your request now..." F L +^PSD(58.85,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
50ADD S PSDREC=$P(^PSD(58.85,0),"^",3)+1 I $D(^PSD(58.85,PSDREC)) S $P(^PSD(58.85,0),"^",3)=PSDREC G ADD
51 K DA,DIC,DIE,DLAYGO,DR S (DIC,DIE,DLAYGO)=58.85,DIC(0)="L",X=PSDREC D ^DIC K DIC,DLAYGO
52 L -^PSD(58.85,0)
53 S PSDRD=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0)),"^",2):$P(^(0),"^",2),1:DT)
54 S DA=PSDREC,DR="1////"_+PSDS_";2////"_NAOU_";3////"_PSDR_";4////"_PSDA_";5////"_PSDQTY_";6////1;12////"_PSDUZ_";19////"_PSDRD_";21////"_$P($G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,2)),U,2)_";22////"_$G(PAT) D ^DIE K DIE
55 I $D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)) S ^PSD(58.85,PSDREC,1,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0) D
56 .F WORD=0:0 S WORD=$O(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD)) Q:'WORD S ^PSD(58.85,PSDREC,1,WORD,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD,0)
57 K DA,DIC,DIE,DLAYGO,DR,WORD
58 I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
59 D:$P($G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,2)),U,2) ^PSDORNP K PSDREC,PSDT(9)
60 Q
Note: See TracBrowser for help on using the repository browser.