- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m
r613 r623 1 PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;5/22/07 10:01am2 ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206**;DEC 1997;Build 39 3 4 5 6 7 8 9 10 11 12 13 EN1 14 15 16 17 EN2(PSOBINTR,PSOBLGTH) 18 19 20 21 22 23 24 25 26 27 28 29 30 EN3(PSOBINTR,PSOBLGTH) 31 32 33 34 35 36 37 38 39 40 41 42 43 START 44 45 46 47 48 49 50 51 52 53 PATCH 54 55 56 57 58 59 60 61 62 63 64 65 PATCHR 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 PATCHQ 85 86 87 DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D Q 1112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 NUMFILLS(PSIRXN) 136 137 138 139 140 141 142 143 144 145 REFIP(RXI,RFIL,TYP) 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 WARN1 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 1 PSOUTLA1 ;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 ; 13 EN1 ;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 17 EN2(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 ; 30 EN3(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) 43 START ; 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 53 PATCH ;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 65 PATCHR ;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="@" 84 PATCHQ Q 85 ; 86 ;PSO*186 87 DEACHK(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 ; 135 NUMFILLS(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 ; 145 REFIP(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 ; 168 WARN1 ;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 TracChangeset
for help on using the changeset viewer.
