source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN1.m@ 767

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

initial load of WorldVistAEHR

File size: 7.9 KB
Line 
1PSOCAN1 ;BIR/BHW - modular rx cancel with speed cancel ability ;2/22/93
2 ;;7.0;OUTPATIENT PHARMACY;**8,20,24,27,32,131,163,185,238**;DEC 1997
3 ;External reference to File #55 supported by DBIA 2228
4 ;External reference to ^PSDRUG supported by DBIA 221
5 ;External reference to ^DPT supported by DBIA 10035
6 ;External references L, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
7 ;
8PAT S RXCNT=0 K X,PSODFN,ASKED,BC,DELCNT,WARN W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode"
9 S DIR("?")="Enter a P if you are going to enter the patient name. Enter a B if you are going to enter or wand the barcode."
10 D ^DIR K DIR G:$D(DIRUT) ^PSOCAN S BC=Y
11BC D KCAN1^PSOCAN3 S OUT=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter the barcode number or wand the barcode to discontinue all prescriptions for one patient" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D
12 .D PSOINST^PSOSUPAT Q:OUT S RX=$P(BCNUM,"-",2) D:$D(^PSRX(RX,0))
13 ..S PSODFN=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(PSODFN,0)),"^")
14 ..D ICN^PSODPT(PSODFN)
15 .I '$D(^PSRX(RX,0)) W !,$C(7),"No Prescription record for this barcode." S OUT=1
16 G:OUT BC
17NAM D KCAN^PSOCAN3 S PSOCANRA=1 I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PAT S PSODFN=+Y S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
18 N PSONEW,PSORX S PSFROM="N" D CHK^PSOCAN G:DEAD NAM K PSOSD D ^PSOBUILD S PSOOPT=-1 D ^PSODSPL G:'$D(PSOSD) NAM
19 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PAT
20 W ! S DIR("A")="Discontinue all or specific Rx#'s?",DIR(0)="SBO^A:ALL Rx's;S:SPECIFIC Rx's"
21 S DIR("?")="Enter the letter A for all listed Rx's OR the letter for specific Rx's." D ^DIR K DIR I $D(DIRUT) D ULP^PSOCAN G PAT
22 S ALL=Y G:Y="S" LINE D RTESTA D COM I '$D(INCOM)!($D(DIRUT)) D ULP^PSOCAN G NAM
23 K PSOSDX,PSOSDXY,PENCAN,PSOCANPN S SPEED=1,(DRG,DRUG,IN,STA)="",II=0 F S STA=$O(PSOSD(STA)) Q:STA="" F S DRUG=$O(PSOSD(STA,DRUG)) Q:DRUG="" S II=II+1,DRG=DRUG D
24 .I STA="PENDING" S DA=$P(PSOSD(STA,DRG),"^",10) S PSOSDX(DA)="" Q
25 .;PSO*7*238
26 .I STA="ZNONVA" D Q
27 ..D NOW^%DTC
28 ..N TMP
29 ..S TMP(55.05,PSOOI_","_PSODFN_",",5)=1
30 ..S TMP(55.05,PSOOI_","_PSODFN_",",6)=%
31 ..D FILE^DIE("","TMP")
32 .S PSOCANPN=1
33 .D PSPEED
34 K SPEED D ASK D:$G(REA)="C"&('$G(PSOSDXY))&($O(PSOSDX(0)))&($G(PSOCANPN)) D:'$G(PSOCANPN) K PSOCANPN,PSOSDX,PSOSDXY,PENCAN D ULP^PSOCAN G PAT
35 .S PENCAN="" F S PENCAN=$O(PSOSDX(PENCAN)) Q:'PENCAN S DA=PENCAN D PSOL^PSSLOCK(DA_"S") I $G(PSOMSG) D PEN,PSOUL^PSSLOCK(DA_"S")
36LINE W !! S DIR(0)="LO^1:"_$S($G(PSOHI):PSOHI,1:PSOSD),DIR("A")="ENTER THE LINE #",DIR("?",1)="Enter the line number(s) displayed to the left of the Rx#."
37 S DIR("?",2)=" Separate the numbers with commas (Example: 3,8,10,7),",DIR("?",3)=" OR a dash (Example: 12-20), OR a combination of commas and",DIR("?",4)=" dashes (Example: 3-5,1,12)."
38 S DIR("?")="Do not exceed 245 characters including commas and dashes." D ^DIR K DIR D:$D(DIRUT) ULP^PSOCAN G:$G(DIRUT) KILL I Y["." W !?53,$C(7),"INVALID LINE NUMBER(S)." G LINE
39 S LINE=Y K PSCAN,PSOCAN S (DRG,IN,STA)="",CNT=0
40 F S STA=$O(PSOSD(STA)) Q:STA="" F S DRG=$O(PSOSD(STA,DRG)) Q:DRG="" S CNT=CNT+1,PSOCAN(CNT)=$S(STA'="PENDING":$P(PSOSD(STA,DRG),"^"),1:$P(PSOSD(STA,DRG),"^",10)_"^P")
41 F CNT=1:1 S PLINE=$P(LINE,",",CNT) Q:'$P(LINE,",",CNT) S IN=$S(IN="":PSOCAN(PLINE),1:IN_","_PSOCAN(PLINE))
42 D RTEST D SPEED D ULP^PSOCAN G:BC="P" NAM G:BC="B" BC
43PSPEED S (YY,DA)=$P(PSOSD(STA,DRG),"^"),RX=$P($G(^PSRX(DA,0)),"^") D SPEED1 Q:PSPOP!($D(PSINV(RX)))
44 Q:$G(SPEED)&(REA="R")
45SHOW S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"")
46PSHOW S LC=0 W !,$P(^PSRX(DA,0),"^")," ",DRG,?52,$S($D(^DPT(+$P(^PSRX(DA,0),"^",2),0)):$P(^(0),"^"),1:"PATIENT UNKNOWN")
47 I REA="C" W !?25,"Rx to be Discontinued",! G SHOW1
48 W !?21,"*** Rx to be Reinstated ***",!
49SHOW1 ;S LC=LC+3 I LC>20 R !,"Press return to continue",X:DTIME G:X'="" SHOW1 S LC=0
50 I $Y+4>IOSL K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E",DIR("A")="Press Return to Continue",DIR("?")="Press Return to continue Listing Orders" D ^DIR K DIR,DTOUT,DIRUT,DUOUT W @IOF
51 Q
52SPEED1 S PSPOP=0 I $G(PSODIV),+$P($G(^PSRX(DA,2)),"^",9)'=$G(PSOSITE) D:'$G(SPEED) DIV^PSOCAN
53 K STAT S STAT=+$P(^PSRX(DA,"STA"),"^"),REA=$E("C00CCCCCCCCCR000C",STAT+1)
54 Q:$G(SPEED)&(REA="R")
55 I REA="R",$P($G(^PSRX(DA,"PKI")),"^") S PKI=1 S PSINV(RX)="" Q
56 I REA=0!(PSPOP)!($P(^PSRX(+YY,"STA"),"^")>12),$P(^("STA"),"^")<16 S PSINV(RX)="" Q
57 S:REA'=0&('PSPOP) PSCAN(RX)=DA_"^"_REA,RXCNT=$G(RXCNT)+1
58 Q
59AREC S:'$G(DEAD) REA=$S($G(REA)="L":"L",1:$P(PSCAN($P(^PSRX(DA,0),"^")),"^",2)) S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB
60 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
61 D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1) S ^PSRX(DA,"A",ACNT+1,0)=%_"^"_REA_"^"_DUZ_"^"_RFCNT_"^"_$S($G(MSG)]"":MSG,1:$G(ACOM)_$G(INCOM)) S ACOM=""
62 I $D(PKIR) N J S J=ACNT+2 D ADR^PSOPKIV1
63 D EXP^PSOHELP1
64 Q
65SPEED D COM Q:'$D(INCOM)!($D(DIRUT)) N PKI K PSINV,PSCAN F II=1:1 S DA=$P(IN,",",II) Q:'$P(IN,",",II) D
66 .I $P(DA,"^",2)="P" S DA=+DA D Q
67 ..D PSOL^PSSLOCK(DA_"S") I $G(PSOMSG) D PEN D PSOUL^PSSLOCK(DA_"S")
68 .I $D(^PSRX(DA,0)) S YY=DA,RX=$P(^(0),"^") S:DA<0 PSINV(RX)="" D:DA>0 SPEED1
69 G:'$D(PSCAN) INVALD S II="",RXCNT=0 F S II=$O(PSCAN(II)) Q:II="" S DA=+PSCAN(II),REA=$P(PSCAN(II),"^",2),RXCNT=RXCNT+1 D SHOW
70 ;
71ASK G:'$D(PSCAN) INVALD W ! S DIR("A")="OK to "_$S($G(RXCNT)>1:"Change Status",REA="C":"Discontinue",1:"Reinstate"),DIR(0)="Y",DIR("B")="N" D ^DIR K DIR I $D(DIRUT) S:$O(PSOSDX(0)) PSOSDXY=1 Q
72 I 'Y S:$O(PSOSDX(0)) PSOSDXY=1 K PSCAN D INVALD Q
73 S RX="" F S RX=$O(PSCAN(RX)) Q:RX="" D PSOL^PSSLOCK(+PSCAN(RX)) I $G(PSOMSG) D ACT D PSOUL^PSSLOCK(+PSCAN(RX))
74 D INVALD Q
75ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
76 D CAN^PSOCAN Q
77INVALD K PSCAN Q:'$D(PSINV) W !! F I=1:1:80 W "="
78 W $C(7),!!,"The Following Rx Number(s) Are Invalid Choices, Expired, "_$S($G(PKI):"Digitally Signed",1:""),!,"Discontinued by Provider, or Marked As Deleted:" S II="" F S II=$O(PSINV(II)) Q:II="" W !?10,II
79 K PSINV I $G(PSOERR)!($G(SPEED)) K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DIRUT,DUOUT
80 G KILL Q
81LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(" D ^DIC K DIC Q
82 ;
83COM W !
84 K MSG ;Added to prevent INCOM from being superseded in AREC tag if DC comments entered.
85 S DIR("A")="Comments"_$S($D(PKIR):"/Reason for DCing",1:""),DIR(0)="F^5:75"
86 S DIR("?")="Comments must be entered. Comments must be 5 to 75 characters and must not contain embedded uparrow"
87 S:$D(INCOM) DIR("B")=INCOM
88 D ^DIR I $D(DIRUT) K DIR,DTOUT,DUOUT,Y Q
89 S INCOM=Y S:$D(PKIR) PKIR=Y K DIR,DTOUT,DIRUT,DUOUT
90 D NOOR^PSOCAN4
91 Q
92KILL D KILL^PSOCAN2
93 K PSOMSG,PSOPLCK,PSOWUN,PSOULRX
94 Q
95PEN ;discontinue pending orders
96 S PSODAPND=DA
97 K ^PS(52.41,"AOR",$P(^PS(52.41,DA,0),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA) S $P(^PS(52.41,DA,0),"^",3)="DC",^PS(52.41,DA,4)=INCOM_" Discontinued by Pharmacy."
98 D EN^PSOHLSN(+^PS(52.41,DA,0),"OC",INCOM,PSONOOR)
99 S DA=PSODAPND K PSODAPND
100 Q
101RTEST ;
102 Q:'$G(LINE)
103 N PCIN,PCINFLAG,PCINX
104 S PCINFLAG=0 F PCIN=1:1 S PCINX=$P(LINE,",",PCIN) Q:$P(LINE,",",PCIN)']"" D
105 .Q:'$G(PCINX)
106 .Q:'$G(PSOCAN(PCINX))
107 .I PSOCAN(PCINX)'["^P" I $P($G(^PSRX(+$G(PSOCAN(PCINX)),"STA")),"^")'=12,'$G(PCINFLAG) S PSOCANRD=+$P($G(^PSRX($G(PSOCAN(PCINX)),0)),"^",4) S PCINFLAG=1
108 .I PSOCAN(PCINX)["^P",'$G(PCINFLAG) S PSOCANRD=+$P($G(^PS(52.41,+$P(PSOCAN(PCINX),"^"),0)),"^",5) S PCINFLAG=1
109 I '$G(PCINFLAG) S PSOCANRZ=1
110 Q
111RTESTA ;
112 N PFIN,PFINZ,PFINFLAG
113 S PFINFLAG=0 S PFIN="" F S PFIN=$O(PSOSD(PFIN)) Q:PFIN="" S PFINZ="" F S PFINZ=$O(PSOSD(PFIN,PFINZ)) Q:PFINZ="" D
114 .I $G(PFIN)'="PENDING" I $P($G(^PSRX(+$P($G(PSOSD(PFIN,PFINZ)),"^"),"STA")),"^")'=12,'$G(PFINFLAG) S PSOCANRD=+$P($G(^(0)),"^",4),PFINFLAG=1
115 .I $G(PFIN)="PENDING",'$G(PFINFLAG) S PSOCANRD=+$P($G(^PS(52.41,+$P($G(PSOSD(PFIN,PFINZ)),"^",10),0)),"^",5) S PFINFLAG=1
116 I '$G(PFINFLAG) S PSOCANRZ=1
117 Q
Note: See TracBrowser for help on using the repository browser.