Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOUTLA1

PSOUTLA1.m

Go to the documentation of this file.
  1. PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ; 17 Jun 2011 2:21 PM
  1. ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206,388,444**;DEC 1997;Build 34
  1. ;External reference to File ^PS(55 supported by DBIA 2228
  1. ;External reference to File ^PSDRUG supported by DBIA 221
  1. ;External reference to File ^PS(59.7 supported by DBIA 694
  1. ;External reference to File ^PS(51 supported by DBIA 2224
  1. ;
  1. ;*186 - add DEACHK function
  1. ;*218 - add REFIP function
  1. ;*259 - reverse *218 delete restriction only warn of deleting
  1. ; also add del of last refill only
  1. ;
  1. EN1 ;Formats condensed, back door sig in BSIG array
  1. ;pass in 1) Internal Rx from 52
  1. ; 2) max length of BSIG array
  1. ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
  1. EN2(PSOBINTR,PSOBLGTH) ;
  1. K BSIG
  1. N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
  1. S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
  1. S (BVAR,BVAR1)="",III=1
  1. 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
  1. .S BVAR1=$P(BBSIG," ",(CNT))
  1. .S BLIM=BVAR
  1. .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
  1. I $G(BVAR)'="" S BSIG(III)=BVAR
  1. I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
  1. Q
  1. ;
  1. EN3(PSOBINTR,PSOBLGTH) ;
  1. ;Pass in to EN3 the internal Rx number from 52, and the length of
  1. ;the array you want. Returns expanded Sig, or warning from PSOHELP
  1. ;concantenated with the condensed Sig in the BSIG array
  1. ;BACK DOOR ONLY
  1. K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
  1. S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
  1. S (SIG,X)=BBSIG
  1. I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START
  1. 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
  1. .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q
  1. .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1
  1. ..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)
  1. START ;
  1. S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_" "_BBSIG)
  1. S (BVAR,BVAR1)="",III=1
  1. 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
  1. .S BVAR1=$P(BBSIG," ",(CNT))
  1. .S BLIM=BVAR
  1. .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
  1. I $G(BVAR)'="" S BSIG(III)=BVAR
  1. I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
  1. Q
  1. PATCH ;Allow sites to backfill more than what was done at install
  1. N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
  1. S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7)
  1. I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4)
  1. 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
  1. 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)_"."
  1. 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.",!
  1. I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
  1. 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.",!
  1. 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
  1. 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)
  1. W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ
  1. PATCHR ;Begin task
  1. N PSOPAL,PSOLPD,PSOLPRX
  1. S PSOBACKA=PSOBACKA-.01
  1. I '$G(PSOBACKB) S PSOBACKB=DT
  1. 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
  1. .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q
  1. .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q
  1. .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D
  1. ..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))
  1. ..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)=""
  1. ..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)=""
  1. ..S $P(^PSRX(PSOLPRX,0),"^",19)=1
  1. .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
  1. .D EN^PSOHLSN1(PSOLPRX,"ZC","")
  1. .I PSOLPSTA'="",PSOLPSTA<10 D
  1. ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOLPRX,"STA"),"^")=11,PSOLPSTA=11
  1. .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:"")
  1. .D EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. PATCHQ Q
  1. ;
  1. ;PSO*186
  1. DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
  1. ;
  1. ; If no refills allowed indicate that and set Max refills to number
  1. ; of fills thus far, or if new order, then num of refills will not be
  1. ; found and Max refills will be 0.
  1. ;
  1. ; Function returns: 1 = no refills allowed
  1. ; Function returns: 2 = no refills allowed
  1. ; 0 = ok to refill
  1. ; Input Variables: PSIRXN = internal RX number or "*"=(new order)
  1. ; PSDEA = DEA special handling for drug ordered
  1. ; PSDAYS = Days supply ordered
  1. ; PCLOZ = Clozapine patient? (Optional)
  1. ; Output Variables: PSOCS = Controlled sub flag (Optional)
  1. ; PSMAXRF= Max Refill allowed by DEA restriction
  1. ; (Optional)
  1. ;
  1. S PSIRXN=+$G(PSIRXN),PSDEA=$G(PSDEA),PSDAYS=+$G(PSDAYS)
  1. S PSOCS=+$G(PSOCS),PSMAXRF=+$G(PSMAXRF),PCLOZ=$G(PCLOZ)
  1. ;
  1. ;if clozapine patient (passed in 0 or 1), set max refills and quit
  1. I PCLOZ=0 S PSMAXRF=0 Q 1
  1. I PCLOZ=1 S PSMAXRF=1 Q 0
  1. ;
  1. ;no refills if PSDEA = 'A' & not 'B' or 'F',
  1. I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D Q 2 ;*388
  1. . S PSMAXRF=$$NUMFILLS(PSIRXN)
  1. ;
  1. N QQ
  1. F QQ=1:1 Q:$E(PSDEA,QQ)="" I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D
  1. . S PSOCS=1
  1. . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1
  1. ;
  1. ;no refills allowed on sched 2
  1. I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 2 ;*388
  1. ;
  1. ; Checking past dispensed DAYS SUPPLY to make sure the refill does not exceed maximum allowed (PSO*7*444)
  1. S PSDAYS=+$G(PSDAYS)
  1. I PSOCS,$$TOTALDS+PSDAYS>184 Q 1
  1. I 'PSOCS,$$TOTALDS+PSDAYS>365 Q 1
  1. ;
  1. ;set max refill for controlled substance & other based on days supply
  1. I $G(PSIRXN) D
  1. . S PSMAXRF=$$MAXNUMRF^PSOUTIL(+$P(^PSRX(PSIRXN,0),"^",6),PSDAYS,+$P(^PSRX(PSIRXN,0),"^",3))
  1. E D
  1. . I PSOCS D
  1. . . I PSDAYS'>90 S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
  1. . . I PSDAYS>90 S PSMAXRF=182\PSDAYS-1
  1. . E D
  1. . . I PSDAYS'>90 S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
  1. . . I PSDAYS>90 S PSMAXRF=365\PSDAYS-1
  1. ;
  1. ;get number of fills if applies & compare to Max refills
  1. N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN)
  1. I PNFILLS'<PSMAXRF S PSMAXRF=PNFILLS Q 1
  1. ;
  1. Q 0
  1. ;
  1. NUMFILLS(PSIRXN) ;Return number of fills thus far, or 0 if doesn't apply
  1. ; function returns: if Active drug, then number of refills thus far
  1. ; else return 0 for does not apply
  1. ; Input Variables: PSIRXN = internal RX number (Optional)
  1. Q:'$G(PSIRXN) 0
  1. N RFN,RFNC
  1. S (RFN,RFNC)=0
  1. F S RFN=$O(^PSRX(PSIRXN,1,RFN)) Q:'RFN S RFNC=RFNC+1
  1. Q RFNC
  1. ;
  1. TOTALDS(RXIEN) ; Return the Total number of Days Supply for a prescription
  1. ; Input: RXIEN - PRESCRIPTION file (#52) IEN (Internal Entry Number)
  1. ;Output: TOTALDS - Sum of DAYS SUPPLY field from all Rx Fills (original + Refills only)
  1. ;
  1. Q:'$G(RXIEN) 0
  1. N TOTALDS,RXFILL
  1. S TOTALDS=$$GET1^DIQ(52,RXIEN,8)
  1. S RXFILL=0
  1. F S RXFILL=$O(^PSRX(RXIEN,1,RXFILL)) Q:'RXFILL D
  1. . S TOTALDS=TOTALDS+$$GET1^DIQ(52.1,RXFILL_","_RXIEN,1.1)
  1. Q TOTALDS
  1. ;
  1. REFIP(RXI,RFIL,TYP) ;Check if refill is Not Released and In Process and
  1. ; pending Auto Release by an external dispense machine.
  1. ; Input: RXI = internal Prescription no.
  1. ; RFIL= refill number
  1. ; TYP ="R"-refill or "P"-partial
  1. ; Returns 1 = In Process (Not OK to delete)
  1. ; 0 = Not In Process (OK to delete)
  1. ;
  1. ;assumes a refill is Not In Process by the external dispense machine
  1. ;unless it finds a record in this file and is marked to the contrary
  1. ;
  1. N PSIEN,IP,FOUND,EXDATA,EXDIV
  1. S (IP,FOUND)=0,PSIEN=""
  1. ;find first specified refill processing backwards, in case dupes
  1. F S PSIEN=$O(^PS(52.51,"B",RXI,PSIEN),-1) Q:PSIEN="" D Q:FOUND
  1. . S EXDATA=^PS(52.51,PSIEN,0)
  1. . I $P(EXDATA,"^",9)=RFIL D
  1. . . S EXDIV=$P(EXDATA,"^",11)
  1. . . Q:'$P($G(^PS(59,EXDIV,"DISP")),"^",2) ;quit, not auto release
  1. . . S FOUND=1
  1. . I FOUND,$P(^PS(52.51,PSIEN,0),"^",10)'=2 S IP=1
  1. Q IP
  1. ;
  1. WARN1 ;partial del checks *259
  1. N PSR,PSOL
  1. S PSR=0 F S PSR=$O(^PSRX(DA(1),"P",PSR)) Q:'PSR S PSOL=PSR
  1. I DA=PSOL,$P(^PSRX(DA(1),"P",DA,0),"^",19) D Q
  1. .D EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
  1. ;
  1. ;Warn of In Process, Only delete if answered Yes ;*259
  1. I $$REFIP^PSOUTLA1(DA(1),DA,"P") D I 'Y Q ;reset $T
  1. . D EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
  1. . D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
  1. . D EN^DDIOL("","","!")
  1. . K DIR
  1. . S DIR("A")="Do you want to continue? "
  1. . S DIR("B")="Y"
  1. . S DIR(0)="YA^^"
  1. . S DIR("?")="Enter Y for Yes or N for No."
  1. . D ^DIR
  1. . K DIR
  1. Q