source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m@ 1005

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

revised back to 6/30/08 version

File size: 9.4 KB
Line 
1PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;10/20/06 3:44pm
2 ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259**;DEC 1997;Build 5
3 ;External reference to File ^PS(55 supported by DBIA 2228
4 ;External reference to File ^PSDRUG supported by DBIA 221
5 ;External reference to File ^PS(59.7 supported by DBIA 694
6 ;External reference to File ^PS(51 supported by DBIA 2224
7 ;
8 ;*186 - add DEACHK function
9 ;*218 - add REFIP function
10 ;*259 - reverse *218 delete restriction only warn of deleting
11 ; also add del of last refill only
12 ;
13EN1 ;Formats condensed, back door sig in BSIG array
14 ;pass in 1) Internal Rx from 52
15 ; 2) max length of BSIG array
16 ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
17EN2(PSOBINTR,PSOBLGTH) ;
18 K BSIG
19 N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
20 S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
21 S (BVAR,BVAR1)="",III=1
22 S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
23 .S BVAR1=$P(BBSIG," ",(CNT))
24 .S BLIM=BVAR
25 .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
26 I $G(BVAR)'="" S BSIG(III)=BVAR
27 I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
28 Q
29 ;
30EN3(PSOBINTR,PSOBLGTH) ;
31 ;Pass in to EN3 the internal Rx number from 52, and the length of
32 ;the array you want. Returns expanded Sig, or warning from PSOHELP
33 ;concantenated with the condensed Sig in the BSIG array
34 ;BACK DOOR ONLY
35 K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
36 S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
37 S (SIG,X)=BBSIG
38 I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START
39 S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START
40 .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q
41 .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1
42 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
43START ;
44 S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_" "_BBSIG)
45 S (BVAR,BVAR1)="",III=1
46 S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
47 .S BVAR1=$P(BBSIG," ",(CNT))
48 .S BLIM=BVAR
49 .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
50 I $G(BVAR)'="" S BSIG(III)=BVAR
51 I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
52 Q
53PATCH ;Allow sites to backfill more than what was done at install
54 N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
55 S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7)
56 I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4)
57 I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y
58 I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"."
59 I W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",!
60 I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
61 W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",!
62 K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ
63 W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7)
64 W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ
65PATCHR ;Begin task
66 N PSOPAL,PSOLPD,PSOLPRX
67 S PSOBACKA=PSOBACKA-.01
68 I '$G(PSOBACKB) S PSOBACKB=DT
69 F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB) F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX D
70 .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q
71 .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q
72 .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D
73 ..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2))
74 ..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)=""
75 ..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)=""
76 ..S $P(^PSRX(PSOLPRX,0),"^",19)=1
77 .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
78 .D EN^PSOHLSN1(PSOLPRX,"ZC","")
79 .I PSOLPSTA'="",PSOLPSTA<10 D
80 ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOLPRX,"STA"),"^")=11,PSOLPSTA=11
81 .S PSOLPSTX=$S(PSOLPSTA=3:"OH",PSOLPSTA=16:"OH",PSOLPSTA=12:"OD",PSOLPSTA=15:"OD",PSOLPSTA=14:"OD",1:"SC"),PSOLPSTZ=$S(PSOLPSTA=0:"CM",PSOLPSTA=1:"IP",PSOLPSTA=4:"IP",PSOLPSTA=5:"ZS",PSOLPSTA=11:"ZE",1:"")
82 .D EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
83 S:$D(ZTQUEUED) ZTREQ="@"
84PATCHQ Q
85 ;
86 ;PSO*186
87DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
88 ;
89 ; If no refills allowed indicate that and set Max refills to number
90 ; of fills thus far, or if new order, then num of refills will not be
91 ; found and Max refills will be 0.
92 ;
93 ; Function returns: 1 = no refills allowed
94 ; 0 = ok to refill
95 ; Input Variables: PSIRXN = internal RX number or "*"=(new order)
96 ; PSDEA = DEA special handling for drug ordered
97 ; PSDAYS = Days supply ordered
98 ; PCLOZ = Clozapine patient? (Optional)
99 ; Output Variables: PSOCS = Controlled sub flag (Optional)
100 ; PSMAXRF= Max Refill allowed by DEA restriction
101 ; (Optional)
102 ;
103 S PSIRXN=+$G(PSIRXN),PSDEA=$G(PSDEA),PSDAYS=+$G(PSDAYS)
104 S PSOCS=+$G(PSOCS),PSMAXRF=+$G(PSMAXRF),PCLOZ=$G(PCLOZ)
105 ;
106 ;if clozapine patient (passed in 0 or 1), set max refills and quit
107 I PCLOZ=0 S PSMAXRF=0 Q 1
108 I PCLOZ=1 S PSMAXRF=1 Q 0
109 ;
110 ;no refills if PSDEA = 'A' & not 'B' or 'F',
111 I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F") D Q 1
112 . S PSMAXRF=$$NUMFILLS(PSIRXN)
113 ;
114 N QQ
115 F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D
116 . S PSOCS=1
117 . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1
118 ;
119 ;no refills allowed on sched 2
120 I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 1
121 ;
122 ;set max refill for controlled substance & other based on days supply
123 S PSDAYS=+$G(PSDAYS)
124 I PSOCS D
125 . S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
126 E D
127 . S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
128 ;
129 ;get number of fills if applies & compare to Max refills
130 N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN)
131 I PNFILLS'<PSMAXRF S PSMAXRF=PNFILLS Q 1
132 ;
133 Q 0
134 ;
135NUMFILLS(PSIRXN) ;Return number of fills thus far, or 0 if doesn't apply
136 ; function returns: if Active drug, then number of refills thus far
137 ; else return 0 for does not apply
138 ; Input Variables: PSIRXN = internal RX number (Optional)
139 Q:'$G(PSIRXN) 0
140 N RFN,RFNC
141 S (RFN,RFNC)=0
142 F S RFN=$O(^PSRX(PSIRXN,1,RFN)) Q:'RFN S RFNC=RFNC+1
143 Q RFNC
144 ;
145REFIP(RXI,RFIL,TYP) ;Check if refill is Not Released and In Process and
146 ; pending Auto Release by an external dispense machine.
147 ; Input: RXI = internal Prescription no.
148 ; RFIL= refill number
149 ; TYP ="R"-refill or "P"-partial
150 ; Returns 1 = In Process (Not OK to delete)
151 ; 0 = Not In Process (OK to delete)
152 ;
153 ;assumes a refill is Not In Process by the external dispense machine
154 ;unless it finds a record in this file and is marked to the contrary
155 ;
156 N PSIEN,IP,FOUND,EXDATA,EXDIV
157 S (IP,FOUND)=0,PSIEN=""
158 ;find first specified refill processing backwards, in case dupes
159 F S PSIEN=$O(^PS(52.51,"B",RXI,PSIEN),-1) Q:PSIEN="" D Q:FOUND
160 . S EXDATA=^PS(52.51,PSIEN,0)
161 . I $P(EXDATA,"^",9)=RFIL D
162 . . S EXDIV=$P(EXDATA,"^",11)
163 . . Q:'$P($G(^PS(59,EXDIV,"DISP")),"^",2) ;quit, not auto release
164 . . S FOUND=1
165 . I FOUND,$P(^PS(52.51,PSIEN,0),"^",10)'=2 S IP=1
166 Q IP
167 ;
168WARN1 ;partial del checks *259
169 N PSR,PSOL
170 S PSR=0 F S PSR=$O(^PSRX(DA(1),"P",PSR)) Q:'PSR S PSOL=PSR
171 I DA=PSOL,$P(^PSRX(DA(1),"P",DA,0),"^",19) D Q
172 .D EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
173 ;
174 ;Warn of In Process, Only delete if answered Yes ;*259
175 I $$REFIP^PSOUTLA1(DA(1),DA,"P") D I 'Y Q ;reset $T
176 . D EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
177 . D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
178 . D EN^DDIOL("","","!")
179 . K DIR
180 . S DIR("A")="Do you want to continue? "
181 . S DIR("B")="Y"
182 . S DIR(0)="YA^^"
183 . S DIR("?")="Enter Y for Yes or N for No."
184 . D ^DIR
185 . K DIR
186 Q
Note: See TracBrowser for help on using the repository browser.