source: WorldVistAEHR/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAOUT.m@ 1710

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

initial load of WorldVistAEHR

File size: 7.8 KB
RevLine 
[613]1PSAOUT ;BHM/DB - Return Drugs to Manufacturer ;23 FEB 04
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**51,64**; 10/24/97;Build 4
3 ;References to ^PSDRUG( are covered by IA #2095
4 ;References to ^DIC(51.5 are covered by DBIA # 1931
5 ;References to ^PSRX( are covered by DBIA # 254
6 ;References to ^PSD(58.86 are covered by DBIA # 4472
7 S PSACNT=0
8 D Q
9 K DIR S DIR(0)="S^1:Print Report;2:Enter drugs Return to Manufacturer" D ^DIR K DIR G Q:$D(DIRUT) I +Y=1 G RPT
10 S (PSALOC,PSANUM)=0 F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:PSALOC'>0 S PSALOCN=PSALOC
111 ;Select Drug
12 R !!,"Scan Drug barcode or enter a drug name : ",AN:DTIME S PSACNT=$G(PSACNT)+1 G DONE:AN["^" G DONE:AN="" I AN=" " W "??" G 1
13 I $D(^PSDRUG("NDC",AN)) S PSADRG=$O(^PSDRUG("NDC",AN,0)) G FOUND
14 I $D(^PSDRUG("C",AN)) S PSADRG=$O(^PSDRUG("C",AN,0)) G FOUND
15 I AN?.AN,$D(^PSDRUG(AN,0)) S PSADRG=AN G FOUND
16 I AN["-",$P(AN,"-",3)'="" S PSANDC=$P(AN,"-")_$P(AN,"-",2)_$P(AN,"-",3) I $D(^PSDRUG("NDC",PSANDC)) S PSADRG=$O(^PSDRUG("NDC",PSANDC,0)) G FOUND
17 I AN["-",$P(AN,"-",3)="" S PSARX=$P(AN,"-",2),PSADRG=$P($G(^PSRX(PSARX,0)),"^",6) I $G(PSADRG)>0 G FOUND
18 I AN?.AE S X=AN,DIC(0)="QEZ",DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0),$P($G(^(2)),""^"",3)'[""N""",DIC="^PSDRUG(" D ^DIC K DIC G:+Y'>0 NONDRUG S PSADRG=+Y G FOUND
19 W !!,"Sorry, I could not find a match. Please enter the drug name.",!! G FM
20FOUND ;Might have match
21 S PSADRUGN=$P($G(^PSDRUG(PSADRG,0)),"^") W " ",$G(PSADRUGN) S DIC("B")=PSADRUGN
22 I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N" W !!,"Sorry, Controlled Substances cannot be selected through this option." K PSADRG,PSADRUGN,X,AN G 1
23OK K DIR S DIR("A")="Is this correct",DIR(0)="Y",DIR("B")="YES" D ^DIR G DONE:$D(DIRUT)
24 I +Y>0 G PROCEED
25FM ;Fileman search
26 S DIC(0)="AEQMZ",DIC("A")="Select Drug : ",DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0),$P($G(^(2)),""^"",3)'[""N""",DIC="^PSDRUG(" D ^DIC G DONE:+Y'>0 S PSADRG=+Y K DIC G FOUND
27PROCEED ;On to the next series of questions
28CON K DIR S DIR(0)="N",DIR("A")="Number of containers " D ^DIR K DIR S PSACON=+Y I $D(DIRUT) G DONE
29 K PSAOU
30 S PSAOU=$P($G(^PSDRUG(PSADRG,"660")),"^",2) I $G(PSAOU)>0 S PSAOU(1)=$P(^DIC(51.5,PSAOU,0),"^")
31 S PSAPDUOU=$P($G(^PSDRUG(PSADRG,660)),"^",6)
32QTY K DIR S DIR(0)="N",DIR("A")="Number of Dispense units being returned: " D ^DIR G DONE:$D(DIRUT)>0 S PSAQTY=Y
33OU K DIC,Y,X S DIC(0)="QAEMZ",DIC="^DIC(51.5,",DIC("A")="Package type: ",DR=.01 S:$G(PSAOU(1))'="" DIC("B")=PSAOU(1) D ^DIC K DIC I +Y<0 G DONE
34 S PSAOU(1)=Y(0)
35 K DIR S DIR("A")="Is it ok to file the data entered",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR G Q:$D(DIRUT) I Y'>0 W !,"ok, try again,",! G CON
36 W !,"Updating Destruction holding file."
37 F L +^PSD(58.86,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
38FIND S PSAHLD=$P(^PSD(58.86,0),"^",3)+1 I $D(^PSD(58.86,PSAHLD)) S $P(^PSD(58.86,0),"^",3)=PSAHLD G FIND
39 D NOW^%DTC S PSADT=%
40 K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.86,DIC(0)="L",(X,DINUM)=PSAHLD D ^DIC K DIC,DINUM,DLAYGO
41 L -^PSD(58.86,0)
42 W !,"Updating Drug Accountability Transaction file."
43PSTRAN S PSAIEN=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAIEN)) S $P(^PSD(58.81,0),"^",3)=PSAIEN G PSTRAN
44 S DIC="^PSD(58.81,",DIC(0)="L",DLAYG0=58.81,(DINUM,X)=PSAIEN D ^DIC K DIC,DLAYGO
45 S DIE="^PSD(58.81,",DA=PSAIEN,DR="1////^S X=10;3////^S X=PSADT;4////^S X=PSADRG;6////^S X=DUZ;47////^S X=PSAHLD" D ^DIE
46UPDT K DA,DIE,DR S DIE=58.86,DA=PSAHLD,DR="1////"_+PSADRG_";2////"_PSAQTY_";11////"_PSACON_";12////"_$P(PSAOU(1),U,1)_";9///^S X=DUZ;10////^S X=PSADT;6////^S X=PSALOCN;19////^S X=$G(PSAPDUOU)"
47 I +PSADRG=99999999 S ^PSD(58.86,DA,1)=PSADRUGN
48 D ^DIE K DIE,DA,DR S ^PSD(58.86,PSAHLD,2)="Returned to Manufacturer"
49 S ^XTMP("PSA",$J,PSACNT)=PSADRG_"^"_PSAQTY_"^"_PSAOU_"^"_PSACON
50 W !!!!!!! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y G DONE
51 G 1
52DONE I $G(PSACNT)'>0 G Q
53 K DIR S DIR("A")="Would you like to print the returns report ",DIR(0)="Y",DIR("B")="YES" D ^DIR G Q:$D(DIRUT)>0 I Y'>0 G Q
54RPT ;print report
55 W !,"If you are returning the items to the manufacturer at this time, the program",!,"will add today's date to the item to show when it was actually returned.",!
56 K DIR S DIR("A")="Are you returning items to the manufacturer at this time",DIR(0)="Y",DIR("B")="YES" D ^DIR G Q:$D(DIRUT)>0 I Y>0 S PSARET=1
57 D NOW^%DTC S X1=X,X2=-90 D C^%DTC S Y=X D DD^%DT S %DT("B")=Y
58BGNDT S %DT="AEP",%DT("A")="Beginning Date: " D ^%DT I +Y<1!($D(DTOUT))!(X["^")!(X']"") G Q
59 S PSABEG=+Y
60ENDDT D NOW^%DTC S Y=+% D DD^%DT S %DT("B")=$P(Y,"@"),%DT="AE",%DT("A")="Ending Date : " D ^%DT I +Y<1!($D(DTOUT))!(X["^")!(X']"") S PSAOUT=1 G Q
61 I Y<PSABEG W !!,"Ending Date cannot be before the Start Date." G ENDDT
62 S PSAEND=+Y
63 K IO("Q") S %ZIS="Q" W ! D ^%ZIS I POP W !,"NO DEVICE SELECTED.",! G Q
64 I $D(IO("Q")) K ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSAOUT",ZTDTH=$H,ZTDESC="PSA OUTDATED REPORT" F X="PSARET","PSABEG","PSAEND" S ZTSAVE(X)=""
65 I D ^%ZTLOAD,HOME^%ZIS G Q
66 U IO
67START ;
68 K ^XTMP("PSA",$J) S PG=0
69 S Y=PSABEG,PSADT=PSABEG-.1 D DD^%DT S PSABEG(1)=Y
70 S Y=PSAEND D DD^%DT S PSAEND(1)=Y,PSAEND=PSAEND+.999999
71 D NOW^%DTC S PSARETD=$P(%,"."),^XTMP("PSA",$J,0)=PSARETD_"^"_PSARETD,Y=PSARETD
72 D DD^%DT S PSARETD=Y K Y
73LOOP ;Loop through "AC" xref
74 ;^PSD(58.86,"AC",DATE/TIME DESTROYED,DISPENSING SITE,DRUG,DA)=""
75 S PSADT=$O(^PSD(58.86,"AC",PSADT)) G BEGIN:PSADT'>0 G BEGIN:PSADT>PSAEND
76 S PSALOC1=0
77LOC S PSALOC1=$O(^PSD(58.86,"AC",PSADT,PSALOC1)) G LOOP:PSALOC1'>0 G LOOP:PSALOC1'>0 S PSADRG=0
78DRG S PSADRG=$O(^PSD(58.86,"AC",PSADT,PSALOC1,PSADRG)) G LOC:PSADRG'>0 S PSAIEN=0
79IEN S PSAIEN=$O(^PSD(58.86,"AC",PSADT,PSALOC1,PSADRG,PSAIEN)) G DRG:PSAIEN'>0
80 S PSADATA=$G(^PSD(58.86,PSAIEN,0)),PSADATA2=$G(^PSD(58.86,PSAIEN,2))
81 I $E(PSADATA2,1,3)'="Ret" G IEN
82 F X=1:1:14 S PSA(X)=$P(PSADATA,"^",X)
83 I $G(PSA(2))=99999999 S PSA(2)=$G(^PSD(58.86,PSAIEN,1))
84 S ^XTMP("PSA",$J,PSA(1))=PSA(8)_"^"_PSA(2)_"^"_PSA(3)_"^"_PSA(10)_"^"_PSA(9)_"^"_PSADT_"^"_$G(^PSD(58.86,PSAIEN,2))_"^"_PSA(12)_"^"_PSA(14)
85 I $G(PSARET)=1,$G(^PSD(58.86,PSAIEN,2))'["on" S ^PSD(58.86,PSAIEN,2)=^PSD(58.86,PSAIEN,2)_" on "_PSARETD
86 G IEN
87PRINT ;Print data
88 S PG=$G(PG)+1 W @IOF,!!!,?25,"Items to be Returned Report",?70,"Page : ",$G(PG),!,?24,PSABEG(1)," thru ",PSAEND(1),!,"Printed on: ",PSADT(1),?50,"Printed by: ",$P($G(^VA(200,DUZ,0)),"^"),! F X=1:1:((IOM/2)-2) W "- "
89 W !,?50,"Total Dispense"
90 W !,"Drug Name",?30,"Containers",?50,"Units / Cost",?66,"Entered by",! F X=1:1:(IOM-1) W "-"
91 Q
92BEGIN S PSAIEN=0 D NOW^%DTC S Y=+% D DD^%DT S PSADT(1)=Y D PRINT
93PNT1 S PSAIEN=$O(^XTMP("PSA",$J,PSAIEN)) G EORPT:PSAIEN'>0 S PSADATA=^XTMP("PSA",$J,PSAIEN),PSADRUGN=$P(PSADATA,"^",2)
94 W !,$S('$D(^PSDRUG(PSADRUGN,0)):PSADRUGN,1:$P(^PSDRUG(PSADRUGN,0),"^")) I $L(PSADRUGN)>37 W !
95 W ?38,$J($P(PSADATA,"^",1),2)," (",$P(PSADATA,"^",8),")",?50,$J($P(PSADATA,"^",3),3)
96 I $P(PSADATA,"^",9)]"",$P(PSADATA,"^",1)]"" W ?55,$J(($P(PSADATA,"^",1)*$P(PSADATA,"^",9)),5,2)
97 S PSANAME=$S($P(PSADATA,"^",4)']"":"",1:$P($G(^VA(200,$P(PSADATA,"^",4),0)),"^")) I PSANAME'="" S PSANM1=$P(PSANAME,",",1),PSANM2=$P(PSANAME,",",2),PSANAME=$E(PSANM2,1)_$E(PSANM1,1)
98 W ?64,PSANAME S DATA=$P(PSADATA,"^",6),X2=$E(DATA,1,3)+1700 W " (",$E(DATA,4,5),"/",$E(DATA,6,7),"/",$E(X2,3,4),")"
99 I $Y>(IOSL-5) D HDR G Q:$G(PSAOUT)=1
100 G PNT1
101EORPT W !!,"End of report" D ^%ZISC
102Q K AN,DA,DATA,DIC,DIR,DIE,DIRUT,DLAYG0,DR,PG,PSA,PSABEG,PSACNT,PSACON,PSADATA,PSADATA2,PSADRG
103 K PSADRUGN,PSADT,PSAEND,PSAHLD,PSAIEN,PSALOC,PSALOC1,PSALOCN,PSANAME,PSANDC,PSANM1,PSANM2,PSANUM,PSAOU
104 K PSAPDUOU,PSAOUT,PSAQTY,PSARET,PSARETD,PSARX,X,X1,X2,Y,^XTMP("PSA",$J) Q
105NONDRUG W !,"The item could not be found in the drug file.",!
106 K DIR S DIR("A")="Is this a non-va drug",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR G Q:$D(DIRUT)=1
107 I +Y'>0 G FM
108 S PSADRG=99999999,PSADRUGN=AN
109ASKD W !,PSADRUGN," //" R AN:DTIME I AN="" G CON
110 G Q:AN["^" S PSADRUGN=AN W " ok, press ENTER to confirm.",! G ASKD
111HDR I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSAOUT=1 Q
112 D PRINT Q
Note: See TracBrowser for help on using the repository browser.