source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNSTK.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1PSDNSTK ;BIR/JPW-Inactivate Stocked Drugs ; 8 Aug 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
4 W !!,?5,"You may inactivate a Stocked Drug for a single NAOU,",!,?5,"or enter ^ALL to inactivate the Drug in ALL NAOUs.",!
5 K DA,DIC,PSDOUT F Q:$D(PSDOUT) W ! S ALL=1,DIC=58.8,DIC(0)="QEA",DIC("A")="Select NAOU: ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)'=""P""" D ^DIC K DIC Q:Y<0&(X'="^ALL") D:X'="^ALL" INACT1 I ALL D ASK Q:$D(PSDOUT)
6END K %,%DT,%H,%I,ALL,ANS1,ANS2,CNT,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,NAOU,NAOUN,PSDOUT,PSDR,PSDRN,PSDT,QUE,RDT,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
7 K ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDMSG",$J)
8 S:$D(ZTQUEUED) ZTREQ="@"
9 Q
10INACT1 ;inactivate a drug for a single NAOU
11 S NAOU=+Y,NAOUN=$P(Y,"^",2),ALL=0
12 I '$D(^PSD(58.8,NAOU,1,0)) W !!,"There are no stocked drugs for this NAOU!!",!! Q
13LOOP K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,NAOU,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
14 W ! S DIC="^PSD(58.8,"_NAOU_",1,",DA(1)=+NAOU,DIC(0)="QEAM" D ^DIC K DIC I $D(DTOUT)!$D(DUOUT) S PSDOUT=1 Q
15 Q:Y<0 S PSDR=+Y K DA,DIE,DR S DA(1)=+NAOU,DIE="^PSD(58.8,"_NAOU_",1,",DA=+PSDR,DR="13;I X="""" S Y=""@1"";14;I X'=""O"" S Y=""@1"";14.5;@1" D ^DIE K DIE I $D(Y)!$D(DTOUT) S PSDOUT=1 Q
16 S PSDRN=$P($G(^PSDRUG(+PSDR,0)),"^")
17 I $P($G(^PSD(58.8,+NAOU,1,+PSDR,0)),"^",14) W !!,PSDRN," is now INACTIVE.",!! G LOOP
18 W !!,"This "_PSDRN_" is ACTIVE on "_NAOUN_".",!!
19 G LOOP
20ASK ;ask inactivation date and reason
21 ;clashed with CMOP W ! K DA,DIR,DIRUT S DIR(0)="50,.01O",DIR("A")="Select DRUG",DIR("?")="Enter the DRUG you wish to inactivate in all NAOUs." D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q
22 K DA,DIC S DIC=50,DIC("S")="I $P($G(^(2)),""^"",3)[""N""",DIC(0)="AQEOM",DIC("A")="Select DRUG: " D ^DIC K DIC S:Y<0 PSDOUT=1 Q:$G(PSDOUT) S PSDR=+Y,PSDRN=$P(Y,"^",2),(ANS1,ANS2)=""
23 W !! K DA,DIR,DIRUT S DIR(0)="58.8001,13" D ^DIR K DIR I $D(DIRUT)!'Y S PSDOUT=1 Q
24 S PSDT=Y K DA,DIR,DIRUT,DTOUT,DUOUT S DIR(0)="58.8001,14" D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) S PSDOUT=1 Q
25 S ANS1=Y G:ANS1'="O" QUE K DA,DIR,DIRUT,DTOUT,DUOUT S DIR(0)="58.8001,14.5" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S PSDOUT=1 Q
26 S ANS2=Y
27QUE ;asks queueing information
28 S QUE=0 W !! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to queue this job",DIR("?",1)="To queue this job to run at a later time and free up your terminal now,"
29 S DIR("?")="accept the default, enter 'N' to run immediately or '^' to quit." D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 W $C(7),!!,"The DRUG you selected will not be inactivated.",!! Q
30 I 'Y W !!,"Inactivating now..." G START
31 S QUE=1 W !!,"You will be notified by MailMan when the job is completed. ",!!
32 S ZTIO="",ZTRTN="START^PSDNSTK",ZTDESC="CS PHARM MASS DRUG INACTIVATION" S (ZTSAVE("PSDR"),ZTSAVE("PSDRN"),ZTSAVE("ANS1"),ZTSAVE("ANS2"),ZTSAVE("QUE"),ZTSAVE("PSDT"),ZTSAVE("PSDSITE"))="" D ^%ZTLOAD K ZTSK Q
33START ;
34 S CNT=0 F NAOU=0:0 S NAOU=$O(^PSD(58.8,NAOU)) Q:'NAOU I $P($G(^PSD(58.8,NAOU,0)),"^",3)=+PSDSITE,$P($G(^PSD(58.8,NAOU,0)),"^",2)'="P",$D(^PSD(58.8,NAOU,1,PSDR,0)),$P(^(0),"^",14)="" D DIE S CNT=CNT+1
35 I 'QUE W $C(7),!!,PSDRN_" has been inactivated in "_CNT_" NAOU(s).",! Q
36MSG ;send mailman message with completed info
37 K XMY,^TMP("PSDMSG",$J) D NOW^%DTC S Y=X X ^DD("DD") S RDT=Y S ^TMP("PSDMSG",$J,1,0)="CS PHARM DRUG Inactivation background job has run to completion."
38 S ^TMP("PSDMSG",$J,2,0)="Run Date: "_RDT,^TMP("PSDMSG",$J,3,0)="",^TMP("PSDMSG",$J,4,0)="** "_PSDRN_" has been inactivated as of "_RDT_" in "_CNT_" NAOU(s)."
39 S XMSUB="CS PHARM MASS DRUG INACTIVATION SUMMARY",XMDUZ="CONTROLLED SUBSTANCES PHARMACY",XMTEXT="^TMP(""PSDMSG"",$J,",XMY(DUZ)="" S:'$D(XMY) XMY(.5)="" D ^XMD K XMY,^TMP("PSDMSG",$J)
40 G END
41DIE ;inactivate a Drug for NAOUs
42 K DA,DIE,DR S DA(1)=+NAOU,DA=+PSDR,DIE="^PSD(58.8,"_NAOU_",1,",DR="13////"_PSDT_";14////"_ANS1_";14.5////"_ANS2 D ^DIE K DIE,DR
43 Q
Note: See TracBrowser for help on using the repository browser.