source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSRL.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: 5.8 KB
Line 
1PSOCSRL ;BIR/BHW-release interface for control substance pkg ;7/22/94
2 ;;7.0;OUTPATIENT PHARMACY;**27,71,118,148,247**;DEC 1997;Build 18
3 ;External reference to ^PSDRUG supported by DBIA 221
4 ;External reference to ^PS(55 supported by DBIA 2228
5 ;External reference to ^PS(59.7 supported by DBIA 694
6 ;External reference to $$SERV^IBARX1 supported by DBIA 2245
7EN(RXP,XTYPE,PSRH) ;
8 N NCPDP
9 I '$D(PSOPAR) D G:'$D(PSOPAR) EX
10 .D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! Q
11 .S PSOCSUB=1
12 K XFLAG D CS^PSOCMOPB(RXP) I $G(XFLAG) K XFLAG Q
13 S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D G EX
14 .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!",!
15 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
16 Q:'$D(^XUSEC("PSORPH",PSRH))
17 I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G EX
18 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2))
19 I +$P($G(^PSRX(+RXP,"STA")),"^")=13!+$P($G(^PSRX(+RXP,0)),"^",2)=0 W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PERSCRIPTION NUMBER" G EX
20 I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,1:1) G EX
21 G:$G(XTYPE)]"" REF
22ORI ;orig
23 K LBLP,ISUF I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") W !!?7,$C(7),$C(7),"ORIGINAL PRESCRIPTION WAS LAST RELEASED ON "_Y,! G EX
24 I $P(^PSRX(RXP,2),"^",15) S RESK=$P(^(2),"^",15) W !,"Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G EX
25 S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
26 I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D G:$G(PSOUT) EX D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE
27 .S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1 S ISUF=1 Q
28 .;
29 .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5) S LBLP=1
30 .Q:'$G(LBLP) D ASK Q:$G(PSOUT)
31 .;
32 .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
33 .I $$MANREL^PSOBPSUT(RXP,0)="^" K LBLP Q
34 .;
35 .S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
36 .Q:$P($G(^PSRX(RXP,2)),"^",13)
37 .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23///"_PSRH
38 .D ^DIE K DIE,DR,DA,LBL
39 .D EN^PSOHLSN1(RXP,"ZD")
40 .; ECME - 3rd Party Billing
41 .;
42 .; - Notifying IB through ECME of the Rx being released
43 .D IBSEND^PSOBPSUT(RXP,0)
44 G EX
45REF ;release ref or par
46 K LBLP,ISUF,IFN D QTY S:($P($G(XTYPE),"^")="P") $P(^PSRX(RXP,"TYPE"),"^")=0
47EX K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,Y,RXP,REC,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,QDRUG,QTY,XTYPE,PSRH,Y,PSIN
48 K DIR,DUOUT,DTOUT,LBL,LBLP,PSOUT
49 Q
50UPDATE I $G(ISUF) W $C(7),!!?7,$S($P(XTYPE,"^")=1:"RE",$P(XTYPE,"^")="P":"PARTIAL ",1:"ORIGINAL")_"FILL ON SUSPENSE !",!,$C(7) Q
51 S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
52 W !?7,"PRESCRIPTION NUMBER "_$P(^PSRX(RXP,0),"^")_" RELEASED"
53 Q
54QTY S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
55 D:$P($G(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0)),"^")'<PSIN K ISUF,LBLP G:$G(PSOUT) EX
56 .S RXFD=$E($P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1 S ISUF=1 D UPDATE Q
57 .I $P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^",$S($P($G(XTYPE),"^"):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
58 .;
59 .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('$P(XTYPE,"^"):(99-$P(XTYPE,"^",2)),1:$P(XTYPE,"^",2)) S LBLP=1
60 .Q:'$G(LBLP) D ASK Q:$G(PSOUT)
61 .;
62 .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
63 .I XTYPE,$$MANREL^PSOBPSUT(RXP,$P(XTYPE,"^",2))="^" K LBLP Q
64 .;
65 .S IFN=$P(XTYPE,"^",2) S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
66 .D NOW^%DTC S DIE="^PSRX("_RXP_","""_$P(XTYPE,"^")_""","
67 .S DA(1)=RXP,DA=$P(XTYPE,"^",2)
68 .S DR=$S(+XTYPE:17,1:8)_"///"_%_";"_$S(+XTYPE:4,1:.05)_"////"_PSRH
69 .D ^DIE K DIE,DR,DA
70 .K PSODISPP S:'$P($G(XTYPE),"^") PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
71 .;
72 .; - Notifying IB through ECME of the Rx being released
73 .I XTYPE D IBSEND^PSOBPSUT(RXP,$P(XTYPE,"^",2))
74 .;
75 .K:+XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,$P(XTYPE,"^",2),0)),"^"),$P(XTYPE,"^",2),RXP)
76 .I +XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^"),YY=$P(XTYPE,"^",2) D CP^PSOCP
77 W:$G(IFN) !!?7,"PRESCRIPTION NUMBER "_$P(^PSRX(RXP,0),"^")_$S('+$G(XTYPE):" Partial Fill",1:" REFILL")_" #"_$P(XTYPE,"^",2)_" RELEASED"
78 W:'$G(IFN) !!?7,$S(+$G(XTYPE):"REFILL",1:"PARTIAL")_" #"_$P(XTYPE,"^",2)_" NOT RELEASED"
79 K IFN
80 Q
81ASK ;confirm
82 W ! K DIR S DIR(0)="SA^1:YES;0:NO",DIR("B")="Yes",DIR("A",1)="Are You sure you want to release "_$S($G(XTYPE)']"":"Original ",$P(XTYPE,"^")=1:"Re",1:"Partial ")_"fill"_$S($P(XTYPE,"^",2):" #"_$P(XTYPE,"^",2),1:"")
83 S DIR("A")="for Prescription #"_$P(^PSRX(RXP,0),"^")_": " D ^DIR K DIR
84 S:'Y!($D(DIRUT)) PSOUT=1
85 ;bingo board call
86 I Y,$G(XTYPE)="",$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
87 I Y,$G(XTYPE)["P",$P($G(^PSRX(RXP,"P",$P(XTYPE,"^",2),0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,"P",$P(XTYPE,"^",2),0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
88 I Y,+$G(XTYPE)=1,$P($G(^PSRX(RXP,1,$P(XTYPE,"^",2),0)),"^",2)["W" S BINGRPR="W",BNGRDV=$P(^PSRX(RXP,1,$P(XTYPE,"^",2),0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
89 I $D(DISGROUP),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
90 Q
Note: See TracBrowser for help on using the repository browser.