source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDOPT1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1PSDOPT1 ;BIR/JPW,LTL-Outpatient Rx Entry (cont'd) ; 20 July 94
2 ;;3.0; CONTROLLED SUBSTANCES ;**30,66**;13 Feb 97;Build 3
3 ;Reference to PS(52.5 supported by DBIA #786
4 ;References to ^PSD(58.8 are covered by DBIA #2711
5 ;References to file 58.81 are covered by DBIA #2808
6 ;Reference to PSRX( supported by DBIA #986
7 ;Reference to routine PSOCSRL supported by DBIA #983
8UPDATE W !!,"Creating an Outpatient Transaction..."
9 F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
10 D NOW^%DTC S PSDT=+% S BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)-QTY
11 L -^PSD(58.8,+PSDS,1,PSDR,0)
12 W "updating..."
13 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
14FIND S PSDA=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDA)) S $P(^PSD(58.81,0),"^",3)=PSDA G FIND
15 K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
16 L -^PSD(58.81,0)
17ADD ;set trans
18 S ^PSD(58.81,PSDA,0)=PSDA_"^6^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_QTY_"^"_PSDUZ_"^^^"_BAL
19 S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($G(NEW(1)):NEW(1),1:"")_"^"_DAT_"^"_$S($G(NEW(2)):NEW(2),1:"")_"^"_RXNUM_"^"_PSDRPH
20 S ^PSD(58.81,PSDA,"CS")=1
21 S DIK="^PSD(58.81,",DA=PSDA D IX^DIK K DA,DIK
22 W "vault activity..."
23DIE I '$D(^PSD(58.8,+PSDS,1,PSDR,4,0)) S ^(0)="^58.800119PA^^"
24 K DA,DIC,DD,DO S DA(1)=PSDR,DA(2)=+PSDS,(X,DINUM)=PSDA,DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",4," D FILE^DICN K DIC,DINUM
25 ;monthly activity
26 I '$D(^PSD(58.8,+PSDS,1,PSDR,5,0)) S ^(0)="^58.801A^^"
27 I '$D(^PSD(58.8,+PSDS,1,PSDR,5,$E(DT,1,5)*100,0)) K DA,DIC S DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,",DIC(0)="LM",DLAYGO=58.8,(X,DINUM)=$E(DT,1,5)*100,DA(2)=+PSDS,DA(1)=PSDR D ^DIC K DA,DIC,DINUM,DLAYGO
28 K DA,DIE,DR S DIE="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,",DA(2)=+PSDS,DA(1)=PSDR,DA=$E(DT,1,5)*100,DR="9////^S X=$P($G(^(0)),""^"",6)+QTY" D ^DIE K DA,DIE,DR
29 W "done."
30 ;PSD*3*30 (Dave B) Check for already released
31 I $G(PSDREL)'="" Q
32 I $G(PSDRTS)=1 K PSDRTS Q
33PSDREL S X="PSOCSRL" X ^%ZOSF("TEST") I $T S XTYPE=$S($G(NEW(2)):"P"_U_NEW(2),$G(NEW(1)):1_U_NEW(1),1:"") D EN^PSOCSRL(PSDRX,XTYPE,PSDRPH)
34 Q
35 ;
36PSDRTS ;Returned to stock continued
37 W !,"Updating balances"
38 F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
39 D NOW^%DTC S PSDT=+%,BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4),$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
40 L -^PSD(58.8,+PSDS,1,PSDR,0) W "."
41 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
42FIND1 S PSDA=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDA)) S $P(^PSD(58.81,0),"^",3)=PSDA G FIND1
43 K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
44 L -^PSD(58.81,0)
45 S ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_PSDUZ_"^^^"_BAL
46 S ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_"Returned by Outpatient"
47 S ^PSD(58.81,PSDA,"CS")=1
48 S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($G(PSDFILL)="R":PSDNUM1,1:"")_"^"_DAT_"^"_$S($G(PSDFILL)="P":PSDNUM1,1:"")_"^"_RXNUM_"^"_PSDRPH
49 S PSDRTS=1,QTY=-PSDQTY D DIE
50 Q
51 ;
52PSDORIG ;Check original labels
53 ;Check for suspense
54 I +$P($G(^PSRX(PSDRX,2)),U,2)'<PSDOIN S PSDRXFD=$P(^(2),U,2) D
55 .S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
56 .I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Original suspended." S PSDRX(1)="" Q
57 .K PSDLBL D VER^PSDOPT
58 .I $G(PSOVR) F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I '+$P($G(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2),'$P($G(^(0)),"^",5) S PSDLBL(1)=1
59 .I '$G(PSOVR) F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I '+$P($G(^PSRX(PSDRX,"L",PSDLBL,0)),"^",2),$P($G(^(0)),"^",5)'["INTERACTION" S PSDLBL(1)=1
60 .K PSOVR,PSDERR,PSDSTA,PSDRXIN I '$G(PSDLBL(1)) S PSDRX(1)="",PSDOUT=1 W !!,"Original label not printed." Q
61 Q
62PSDRFL ;Check refill labels
63 I $D(^PSRX(PSDRX,1,PSDFLNO,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
64 .F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I $P(^PSRX(PSDRX,"L",PSDLBL,0),U,2)=PSDFLNO S PSDLBL(1)=1
65 .I '$G(PSDLBL(1)) W !!,"Refill #",PSDFLNO," label not printed." S PSDOUT=1,PSDRX(1)="" Q
66 Q
67PSDPRTL ;Chec partial labels
68 I $D(^PSRX(PSDRX,"P",PSDFLNO,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
69 .F PSDLBL=0:0 S PSDLBL=$O(^PSRX(PSDRX,"L",PSDLBL)) Q:'PSDLBL I $P(^PSRX(PSDRX,"L",0),U,2)=99-PSDFLNO S PSDLBL(1)=1
70 .I '$G(PSDLBL(1)) W !!,"Partial #",PSDFLNO," label not printed." S PSDOUT=1,PSDRX(1)="" Q
71 Q
72RTSMUL ; Setup local array of refills in reverse order
73 S PSD1=0 F S PSD1=$O(^PSD(58.81,"AOP",PSDRX,PSD1)) Q:PSD1'>0 S DATA6=$G(^PSD(58.81,PSD1,6)) D
74 .S PSDXXX=PSD1
75 .S PSD1MUL=PSD1*-1
76 .S PSDMUL(PSD1MUL)=$P(DATA6,"^",2)
77 Q
Note: See TracBrowser for help on using the repository browser.