source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP3.m@ 1766

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1PSODISP3 ;ISC-BHAM/SAB rx speed release ;08/30/95 10:24
2 ;;7.0;OUTPATIENT PHARMACY;**15,13,148**;DEC 1997
3 ;External reference ^PS(59.7 supported by DBIA 694
4 ;External reference ^XTMP("PSA" supported by DBIA 1036
5 ;External reference $$SERV^IBARX supported by DBIA 2245
6SEL N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
7 K ^UTILITY($J,"PSOPCE"),QFLG,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
8 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSOPCECT)=1 D FULL^VALM1 S LST=Y D
9 . D ASK Q:$G(QFLG) S PSOLIST=0,PSOPID=1
10 . F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" D
11 . . K ISUF,IFN S ORN=$P(LST,",",ORD)
12 . . S RXP=$P(PSOLST($P(LST,",",ORD)),"^",2),POERR=1
13 . . D:+PSOLST(ORN)=52 FULL^VALM1,BC1^PSODISP W ! S PSOLIST=PSOLIST+1
14 . . I PSOLIST=5 D
15 . . . K DIR,DIRUT S DIR(0)="E",DIR("A",1)="",DIR("A")="Press Return to Continue"
16 . . . W ! D ^DIR K DIR,DIRUT S PSOLIST=0
17 . I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV D
18 . . K DIR,DIRUT S DIR(0)="E",DIR("A",1)="",DIR("A")="Press Return to Continue"
19 . . W ! D ^DIR K DIR,DIRUT
20 I '$G(PSOOELSE) S VALMBCK="" Q
21 S VALMBCK="R",PSORXED=1 D BLD^PSOORUT1
22 ;D PCE^PSODISP
23EX K SPEED,PSOPCECT,PSOOELSE,QFLG,PSORXED,OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,ORD,LST,POERR,PSOLIST
24 K REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN
25 Q
26ASK ;
27 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) S VALMSG="Site Parameters must be defined to use the Release option!",VALMBCK="R",QFLG=1 Q
28 S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D S VALMBCK="R",QFLG=1 Q
29 .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",! H 3
30 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
31RPH S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC I "^"[X S QFLG=1 Q
32 G:Y=-1 RPH K DIC I $D(DIRUT) S QFLG=1 Q
33 S PSRH=+Y
34 ;check for Drug Acct background job K8 & K7.1
35 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y Q
36 I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT Q
37 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X Q:Y=-1
38 K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
39 I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ Q
40 I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
41 K PSA,DIC,DA,X,Y,DIQ
42 Q
Note: See TracBrowser for help on using the repository browser.