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