- PSORENW ; BIR/SAB - renew main driver ;Oct 20, 2022@1540
- ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206,388,390,417,313,411,504,508,550,457,477,441,545,753**;DEC 1997;Build 53
- ;External reference to ^PSDRUG( supported by DBIA 221
- ;External reference to $$L^PSSLOCK supported by DBIA 2789
- ;External reference to UL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference to LK^ORX2 supported by DBIA 867
- ;External reference to ULK^ORX2 supported by DBIA 867
- ;External reference to ^PS(50.7 supported by DBIA 2223
- ;External reference to MAIN^TIUEDIT supported by DBIA 2410
- ;
- ASK ;
- D MW^PSOCMOPA(.PSORENW)
- K PSORENW("FILL DATE"),ZZCOPY D FILLDT^PSODIR2(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request cancelled",VALMBCK="R"
- I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
- S PSORNW("FILL DATE")=PSORENW("FILL DATE")
- I PSORENW("DFLG") S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
- S PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW") S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="M":"MAIL",PSORENW("MAIL/WINDOW")="P":"PARK",1:"WINDOW")
- S PSORENW("MAIL EXEMPTION")=$$GET1^DIQ(52,PSORENW("OIRXN"),100.2,"I") ;p753
- D NOORE^PSONEW(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request cancelled",VALMBCK="R"
- I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0
- ASKX Q
- ;
- EOJ ;
- K VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR,PSOMAILX
- N ZRXN
- S RXN=$O(^TMP("PSORXN",$J,0)) I RXN S ZRXN=RXN D
- .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
- .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
- .;saves drug allergy order chks pso*7*411
- .I $D(^TMP("PSODAOC",$J)) D Q:$G(PSORX("DFLG"))
- ..I $G(PSORX("DFLG")) K ^TMP("PSODAOC",$J) Q
- ..S RXN=ZRXN
- .S PSOARENW=1 D DAOC^PSONEW K PSOARENW
- I $G(PSORNEDT),'$O(^TMP("PSORXN",$J,0)),$D(^TMP("PSODAOC",$J)) S ZRXN=PSORNEDT,PSOARENW=1 D DAOC^PSONEW K PSOARENW,PSORNEDT
- K ZZCOPY,ZRXN,RXN,RXN1,^TMP("PSORXN",$J),^TMP("PSODAOC",$J)
- I $G(PSONOTE) D MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
- K PSONOTE
- Q
- OERR ;entry for renew backdoor
- N PSORNEDT,PSORXIEN,PSOCHECK,PSODEAU,PSDRGIEN
- S PSORXIEN=+$P($G(PSOLST(ORN)),"^",2) D:PSORXIEN>0 ; Clozapine check
- . N PSDRGIEN S PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I") ; drug IEN
- . Q:'PSDRGIEN
- . I $$GET1^DIQ(50,PSDRGIEN,17.5)="PSOCLO1" S VALMSG="Cannot Renew a Clozapine Order",VALMBCK="R",PSORXIEN=0 W $C(7)
- Q:'(PSORXIEN>0) ; didn't pass Clozapine check
- ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
- S PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN)
- S PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- I $$DRUGSCHD^PSOUTIL(PSDRGIEN) D Q:'$L($G(PSORX("RXDEA")))
- . N PSODIR,PSODEAU
- . D FULL^VALM1 S PSODEAU=$$SLDEA^PSODIR($P($G(^PSRX(PSORXIEN,0)),U,4),.PSORX,$$RXDEA^PSOUTIL(PSORXIEN),PSDRGIEN)
- . I $L($G(PSODEAU)) S PSORX("DEA")=PSODEAU,PSOCHECK=1 D PAUSE^VALM1 Q
- . N PSODIR S PSODIR("CS")=1 D PROV^PSODIR(.PSODIR)
- . I $G(PSODIR("PROVIDER"))&$L($G(PSORX("RXDEA"))) D Q
- .. S PSORXED("PROVIDER")=PSODIR("PROVIDER"),PSOCHECK=1
- .. D PAUSE^VALM1
- . I 'PSOCHECK S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) D PAUSE^VALM1
- ;I 'PSOCHECK&(($P(PSOCHECK,U,4)'=1)&($P(PSOCHECK,U,4)'=2)) S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) Q
- I 'PSOCHECK S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) Q
- ;I $$TITRX^PSOUTL(PSORXIEN)="t" D Q
- ;. S VALMSG="Cannot Renew a 'Titration Rx'.",VALMBCK="R" W $C(7)
- I $$TITRX^PSOUTL(PSORXIEN)="t" D TIMTRX^PSOOTMRX Q ;P441
- I $$LMREJ^PSOREJU1(PSORXIEN,,.VALMSG,.VALMBCK) Q
- ; PSO*7*508 - check if the Rx is an eRx. If so, inform the user and ask to proceed.
- N ERXORN,ERXIEN,ERXPROC S ERXORN=$$GET1^DIQ(52,$P(PSOLST(ORN),U,2),39.3)
- S ERXIEN=$$CHKERX^PSOERXU1(ERXORN)
- I ERXIEN D FULL^VALM1 S ERXPROC=$$PROVPMT^PSOERXU1(ERXIEN) Q:'ERXPROC
- ; PSO*7*508 - end
- S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
- K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
- K PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY
- D PSOL^PSSLOCK(PSORXIEN) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULPAT Q
- S PSOBCKDR=1,PSOFROM="NEW",PSORENW("OIRXN")=PSORXIEN,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
- I $$CONJ^PSOUTL(PSORENW("OIRXN")) S VALMSG="Cannot be renewed - invalid Except conjunction" S VALMBCK="" D ULPAT Q
- S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9)
- D FULL^VALM1,ASK D:PSORENW("QFLG") KLIB^PSORENW1 D:PSORENW("QFLG") ULPAT D:PSORENW("QFLG") PSOUL^PSSLOCK(PSORXIEN) G:PSORENW("QFLG") EOJ D ^PSORENW0
- D ULPAT,EOJ,KLIB^PSORENW1 K PSOOPT,PSONEW,PSORX("DFLG"),X,Y
- Q
- ULPAT K PSOMSG D UL^PSSLOCK(PSODFN) S X=PSODFN_";DPT(" D ULK^ORX2 K X
- Q
- RENEW(PLACER,PSOCPDRG) ;passes flag to CPRS for front door renews
- ;-1=couldn't find order, 0=unable to renew, 1=renewable
- ;Placer=Pharmacy number
- N PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA,RX0,X1,X2
- I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
- S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
- S RX0=^PSRX(RXN,0),PSODRG=+$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0)
- S PSOIFLAG=0,PSOOLDOI=+$P($G(^PSRX(RXN,"OR1")),"^"),PSONEWOI=+$P($G(^PSDRUG(+$G(PSODRG),2)),"^") I PSONEWOI,PSONEWOI'=PSOOLDOI S PSOIFLAG=1
- S PSOINA=$P($G(^PS(50.7,PSONEWOI,0)),"^",4)
- I PSOINA,DT>PSOINA Q "0^This Orderable Item has been Inactivated."
- I ST=5 S PSOSURX=$O(^PS(52.5,"B",RXN,0)) I PSOSURX,$P($G(^PS(52.5,PSOSURX,0)),"^",7)="L" Q "0^Rx loading into a CMOP Transmission."
- S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,2)),"^",6)<X Q "0^Prescription Expired more than 120 Days."
- S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,3)),"^",5),$P($G(^(3)),"^",5)<X,$P(^("STA"),"^")=12 Q "0^Prescription Discontinued more than 120 Days."
- I $G(PSOCPDRG),$G(PSOCPDRG)'=$G(PSODRG) Q "0^Drug Mismatch, Non-Renewable."
- N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=RXN D CDOSE^PSORENW0 I PSOOLPF Q "0^Non-Renewable, invalid Dosage of "_$G(PSOOLPD)
- I PSONOSIG Q "0^Non-Renewable, missing Sig."
- I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Drug is No longer used by Outpatient Pharmacy."
- I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^This Drug has been Inactivated."
- I ($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2)!($P(PSODRUG0,"^",3)["W") Q "0^Non-Renewable "_$S($P(PSODRUG0,"^",3)["A":"Drug Narcotic.",1:"Drug.")
- I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription."
- S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached."
- I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12,ST'=14 Q "0^Prescription is in a Non-Renewable Status."
- I $P($G(^PSRX(RXN,"OR1")),"^",4) Q "0^Duplicate Rx Renewal Request."
- I $O(^PS(52.41,"AQ",RXN,0)) Q "0^Duplicate Rx Renewal Request."
- ;N TITMSG
- ;I $$TITRX^PSOUTL(RXN)="t" D Q TITMSG
- ;. S TITMSG="0^Prescription was marked as 'Titration to Maintenance Dose' by Pharmacy and cannot be renewed."
- ;. S TITMSG=TITMSG_" To repeat the titration, enter a new prescription or copy the prior titration order."
- ;. S TITMSG=TITMSG_" To continue the maintenance dose, refill this prescription if refills are available"
- ;. S TITMSG=TITMSG_" or enter a new prescription for the maintenance dose."
- K PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,TITMSG
- Q 1_$S($G(PSOIFLAG):"^"_$G(PSONEWOI),1:"")
- ;
- INST1 ;Set Pharmacy Instructions array
- N PSOTZ
- ;for titration renewal, copy patient instructions from 52.41 - *p441
- I $$TITRX^PSOUTL(RXN)="t",$G(PSOORRNW),$G(ORD) D Q
- .I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),PSOTZ=0 D
- ..F S PSOTZ=$O(^PS(52.41,ORD,2,PSOTZ)) Q:'PSOTZ S PHI(PSOTZ)=^PS(52.41,ORD,2,PSOTZ,0)
- ;
- I $O(^PSRX(RXN,"PI",0)) S PHI=$G(^PSRX(RXN,"PI",0)),PSOTZ=0 D
- .F S PSOTZ=$O(^PSRX(RXN,"PI",PSOTZ)) Q:PSOTZ="" S PHI(PSOTZ)=$G(^PSRX(RXN,"PI",PSOTZ,0))
- Q
- INST2 ;Set Instructions and Comments
- I '$G(PSORENW("OIRXN")) Q
- I $G(PSOFDR) Q
- N PSOPHL,PSOPRL
- I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) K PHI S PHI=$G(^PSRX(PSORENW("OIRXN"),"PI",0)),PSOPHL="" D
- .F S PSOPHL=$O(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL)) Q:PSOPHL="" S PHI(PSOPHL)=$G(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0))
- I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) K PRC S PRC=$G(^PSRX(PSORENW("OIRXN"),"PRC",0)),PSOPRL="" D
- .F S PSOPRL=$O(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL)) Q:PSOPRL="" S PRC(PSOPRL)=$G(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORENW 9212 printed Feb 19, 2025@00:00:10 Page 2
- PSORENW ; BIR/SAB - renew main driver ;Oct 20, 2022@1540
- +1 ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206,388,390,417,313,411,504,508,550,457,477,441,545,753**;DEC 1997;Build 53
- +2 ;External reference to ^PSDRUG( supported by DBIA 221
- +3 ;External reference to $$L^PSSLOCK supported by DBIA 2789
- +4 ;External reference to UL^PSSLOCK supported by DBIA 2789
- +5 ;External reference to PSOL^PSSLOCK supported by DBIA 2789
- +6 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
- +7 ;External reference to LK^ORX2 supported by DBIA 867
- +8 ;External reference to ULK^ORX2 supported by DBIA 867
- +9 ;External reference to ^PS(50.7 supported by DBIA 2223
- +10 ;External reference to MAIN^TIUEDIT supported by DBIA 2410
- +11 ;
- ASK ;
- +1 DO MW^PSOCMOPA(.PSORENW)
- +2 KILL PSORENW("FILL DATE"),ZZCOPY
- DO FILLDT^PSODIR2(.PSORENW)
- if $GET(PSORENW("DFLG"))
- SET VALMSG="Renew Rx request cancelled"
- SET VALMBCK="R"
- +3 IF PSORENW("DFLG")!('$DATA(PSORENW("FILL DATE")))
- SET PSORENW("QFLG")=1
- SET PSORENW("DFLG")=0
- GOTO ASKX
- +4 SET PSORNW("FILL DATE")=PSORENW("FILL DATE")
- +5 IF PSORENW("DFLG")
- SET PSORENW("QFLG")=1
- SET PSORENW("DFLG")=0
- GOTO ASKX
- +6 SET PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW")
- SET PSORX("MAIL/WINDOW")=$SELECT(PSORENW("MAIL/WINDOW")="M":"MAIL",PSORENW("MAIL/WINDOW")="P":"PARK",1:"WINDOW")
- +7 ;p753
- SET PSORENW("MAIL EXEMPTION")=$$GET1^DIQ(52,PSORENW("OIRXN"),100.2,"I")
- +8 DO NOORE^PSONEW(.PSORENW)
- if $GET(PSORENW("DFLG"))
- SET VALMSG="Renew Rx request cancelled"
- SET VALMBCK="R"
- +9 IF PSORENW("DFLG")!('$DATA(PSORENW("FILL DATE")))
- SET PSORENW("QFLG")=1
- SET PSORENW("DFLG")=0
- ASKX QUIT
- +1 ;
- EOJ ;
- +1 KILL VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR,PSOMAILX
- +2 NEW ZRXN
- +3 SET RXN=$ORDER(^TMP("PSORXN",$JOB,0))
- IF RXN
- SET ZRXN=RXN
- Begin DoDot:1
- +4 SET RXN1=^TMP("PSORXN",$JOB,RXN)
- DO EN^PSOHLSN1(RXN,$PIECE(RXN1,"^"),$PIECE(RXN1,"^",2),"",$PIECE(RXN1,"^",3))
- +5 IF $PIECE(^PSRX(RXN,"STA"),"^")=5
- DO EN^PSOHLSN1(RXN,"SC","ZS",$PIECE(RXN1,"^",4))
- +6 ;saves drug allergy order chks pso*7*411
- +7 IF $DATA(^TMP("PSODAOC",$JOB))
- Begin DoDot:2
- +8 IF $GET(PSORX("DFLG"))
- KILL ^TMP("PSODAOC",$JOB)
- QUIT
- +9 SET RXN=ZRXN
- End DoDot:2
- if $GET(PSORX("DFLG"))
- QUIT
- +10 SET PSOARENW=1
- DO DAOC^PSONEW
- KILL PSOARENW
- End DoDot:1
- +11 IF $GET(PSORNEDT)
- IF '$ORDER(^TMP("PSORXN",$JOB,0))
- IF $DATA(^TMP("PSODAOC",$JOB))
- SET ZRXN=PSORNEDT
- SET PSOARENW=1
- DO DAOC^PSONEW
- KILL PSOARENW,PSORNEDT
- +12 KILL ZZCOPY,ZRXN,RXN,RXN1,^TMP("PSORXN",$JOB),^TMP("PSODAOC",$JOB)
- +13 IF $GET(PSONOTE)
- DO MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
- +14 KILL PSONOTE
- +15 QUIT
- OERR ;entry for renew backdoor
- +1 NEW PSORNEDT,PSORXIEN,PSOCHECK,PSODEAU,PSDRGIEN
- +2 ; Clozapine check
- SET PSORXIEN=+$PIECE($GET(PSOLST(ORN)),"^",2)
- if PSORXIEN>0
- Begin DoDot:1
- +3 ; drug IEN
- NEW PSDRGIEN
- SET PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- +4 if 'PSDRGIEN
- QUIT
- +5 IF $$GET1^DIQ(50,PSDRGIEN,17.5)="PSOCLO1"
- SET VALMSG="Cannot Renew a Clozapine Order"
- SET VALMBCK="R"
- SET PSORXIEN=0
- WRITE $CHAR(7)
- End DoDot:1
- +6 ; didn't pass Clozapine check
- if '(PSORXIEN>0)
- QUIT
- +7 ; Checking whether the Provider still qualifies as prescriber for the renewed Rx
- +8 SET PSOCHECK=$$CHKRXPRV^PSOUTIL(PSORXIEN)
- +9 SET PSDRGIEN=$$GET1^DIQ(52,PSORXIEN,6,"I")
- +10 IF $$DRUGSCHD^PSOUTIL(PSDRGIEN)
- Begin DoDot:1
- +11 NEW PSODIR,PSODEAU
- +12 DO FULL^VALM1
- SET PSODEAU=$$SLDEA^PSODIR($PIECE($GET(^PSRX(PSORXIEN,0)),U,4),.PSORX,$$RXDEA^PSOUTIL(PSORXIEN),PSDRGIEN)
- +13 IF $LENGTH($GET(PSODEAU))
- SET PSORX("DEA")=PSODEAU
- SET PSOCHECK=1
- DO PAUSE^VALM1
- QUIT
- +14 NEW PSODIR
- SET PSODIR("CS")=1
- DO PROV^PSODIR(.PSODIR)
- +15 IF $GET(PSODIR("PROVIDER"))&$LENGTH($GET(PSORX("RXDEA")))
- Begin DoDot:2
- +16 SET PSORXED("PROVIDER")=PSODIR("PROVIDER")
- SET PSOCHECK=1
- +17 DO PAUSE^VALM1
- End DoDot:2
- QUIT
- +18 IF 'PSOCHECK
- SET VALMSG=$PIECE(PSOCHECK,"^",2)
- SET VALMBCK="R"
- WRITE $CHAR(7)
- DO PAUSE^VALM1
- End DoDot:1
- if '$LENGTH($GET(PSORX("RXDEA")))
- QUIT
- +19 ;I 'PSOCHECK&(($P(PSOCHECK,U,4)'=1)&($P(PSOCHECK,U,4)'=2)) S VALMSG=$P(PSOCHECK,"^",2),VALMBCK="R" W $C(7) Q
- +20 IF 'PSOCHECK
- SET VALMSG=$PIECE(PSOCHECK,"^",2)
- SET VALMBCK="R"
- WRITE $CHAR(7)
- QUIT
- +21 ;I $$TITRX^PSOUTL(PSORXIEN)="t" D Q
- +22 ;. S VALMSG="Cannot Renew a 'Titration Rx'.",VALMBCK="R" W $C(7)
- +23 ;P441
- IF $$TITRX^PSOUTL(PSORXIEN)="t"
- DO TIMTRX^PSOOTMRX
- QUIT
- +24 IF $$LMREJ^PSOREJU1(PSORXIEN,,.VALMSG,.VALMBCK)
- QUIT
- +25 ; PSO*7*508 - check if the Rx is an eRx. If so, inform the user and ask to proceed.
- +26 NEW ERXORN,ERXIEN,ERXPROC
- SET ERXORN=$$GET1^DIQ(52,$PIECE(PSOLST(ORN),U,2),39.3)
- +27 SET ERXIEN=$$CHKERX^PSOERXU1(ERXORN)
- +28 IF ERXIEN
- DO FULL^VALM1
- SET ERXPROC=$$PROVPMT^PSOERXU1(ERXIEN)
- if 'ERXPROC
- QUIT
- +29 ; PSO*7*508 - end
- +30 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
- KILL PSOPLCK
- SET VALMBCK=""
- QUIT
- +31 KILL PSOPLCK
- SET X=PSODFN_";DPT("
- DO LK^ORX2
- IF 'Y
- SET VALMSG="Another person is entering orders for this patient."
- SET VALMBCK=""
- DO UL^PSSLOCK(PSODFN)
- QUIT
- +32 KILL PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY
- +33 DO PSOL^PSSLOCK(PSORXIEN)
- IF '$GET(PSOMSG)
- SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
- SET VALMBCK=""
- KILL PSOMSG
- DO ULPAT
- QUIT
- +34 SET PSOBCKDR=1
- SET PSOFROM="NEW"
- SET PSORENW("OIRXN")=PSORXIEN
- SET PSOOPT=3
- SET (PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
- +35 IF $$CONJ^PSOUTL(PSORENW("OIRXN"))
- SET VALMSG="Cannot be renewed - invalid Except conjunction"
- SET VALMBCK=""
- DO ULPAT
- QUIT
- +36 SET PSONEW("DAYS SUPPLY")=$PIECE(^PSRX(PSORENW("OIRXN"),0),"^",8)
- SET PSONEW("# OF REFILLS")=$PIECE(^(0),"^",9)
- +37 DO FULL^VALM1
- DO ASK
- if PSORENW("QFLG")
- DO KLIB^PSORENW1
- if PSORENW("QFLG")
- DO ULPAT
- if PSORENW("QFLG")
- DO PSOUL^PSSLOCK(PSORXIEN)
- if PSORENW("QFLG")
- GOTO EOJ
- DO ^PSORENW0
- +38 DO ULPAT
- DO EOJ
- DO KLIB^PSORENW1
- KILL PSOOPT,PSONEW,PSORX("DFLG"),X,Y
- +39 QUIT
- ULPAT KILL PSOMSG
- DO UL^PSSLOCK(PSODFN)
- SET X=PSODFN_";DPT("
- DO ULK^ORX2
- KILL X
- +1 QUIT
- RENEW(PLACER,PSOCPDRG) ;passes flag to CPRS for front door renews
- +1 ;-1=couldn't find order, 0=unable to renew, 1=renewable
- +2 ;Placer=Pharmacy number
- +3 NEW PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA,RX0,X1,X2
- +4 IF $GET(PLACER)["S"!('$GET(PLACER))
- QUIT "-1^Not a Valid Outpatient Medication Order."
- +5 SET RXN=PLACER
- IF '$DATA(^PSRX(RXN,0))
- QUIT "-1^Not a Valid Outpatient Medication Order."
- +6 SET RX0=^PSRX(RXN,0)
- SET PSODRG=+$PIECE(^PSRX(RXN,0),"^",6)
- SET ST=+^("STA")
- SET PSODRUG0=^PSDRUG(PSODRG,0)
- +7 SET PSOIFLAG=0
- SET PSOOLDOI=+$PIECE($GET(^PSRX(RXN,"OR1")),"^")
- SET PSONEWOI=+$PIECE($GET(^PSDRUG(+$GET(PSODRG),2)),"^")
- IF PSONEWOI
- IF PSONEWOI'=PSOOLDOI
- SET PSOIFLAG=1
- +8 SET PSOINA=$PIECE($GET(^PS(50.7,PSONEWOI,0)),"^",4)
- +9 IF PSOINA
- IF DT>PSOINA
- QUIT "0^This Orderable Item has been Inactivated."
- +10 IF ST=5
- SET PSOSURX=$ORDER(^PS(52.5,"B",RXN,0))
- IF PSOSURX
- IF $PIECE($GET(^PS(52.5,PSOSURX,0)),"^",7)="L"
- QUIT "0^Rx loading into a CMOP Transmission."
- +11 SET X1=DT
- SET X2=-120
- DO C^%DTC
- IF $PIECE($GET(^PSRX(RXN,2)),"^",6)<X
- QUIT "0^Prescription Expired more than 120 Days."
- +12 SET X1=DT
- SET X2=-120
- DO C^%DTC
- IF $PIECE($GET(^PSRX(RXN,3)),"^",5)
- IF $PIECE($GET(^(3)),"^",5)<X
- IF $PIECE(^("STA"),"^")=12
- QUIT "0^Prescription Discontinued more than 120 Days."
- +13 IF $GET(PSOCPDRG)
- IF $GET(PSOCPDRG)'=$GET(PSODRG)
- QUIT "0^Drug Mismatch, Non-Renewable."
- +14 NEW PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG
- SET PSOOCPRX=RXN
- DO CDOSE^PSORENW0
- IF PSOOLPF
- QUIT "0^Non-Renewable, invalid Dosage of "_$GET(PSOOLPD)
- +15 IF PSONOSIG
- QUIT "0^Non-Renewable, missing Sig."
- +16 IF $PIECE($GET(^PSDRUG(PSODRG,2)),"^",3)'["O"
- QUIT "0^Drug is No longer used by Outpatient Pharmacy."
- +17 IF $GET(^PSDRUG(PSODRG,"I"))]""
- IF DT>$GET(^("I"))
- QUIT "0^This Drug has been Inactivated."
- +18 IF ($PIECE(PSODRUG0,"^",3)[1)!($PIECE(PSODRUG0,"^",3)[2)!($PIECE(PSODRUG0,"^",3)["W")
- QUIT "0^Non-Renewable "_$SELECT($PIECE(PSODRUG0,"^",3)["A":"Drug Narcotic.",1:"Drug.")
- +19 IF $DATA(^PS(53,+$PIECE(RX0,"^",3),0))
- IF '$PIECE(^(0),"^",5)
- QUIT "0^Non-Renewable Prescription."
- +20 SET PSOLC=$PIECE(RX0,"^")
- SET PSOLC=$EXTRACT(PSOLC,$LENGTH(PSOLC))
- IF $ASCII(PSOLC)'<90
- QUIT "0^Max number of renewals (26) has been reached."
- +21 IF ST
- IF ST'=2
- IF ST'=5
- IF ST'=6
- IF ST'=11
- IF ST'=12
- IF ST'=14
- QUIT "0^Prescription is in a Non-Renewable Status."
- +22 IF $PIECE($GET(^PSRX(RXN,"OR1")),"^",4)
- QUIT "0^Duplicate Rx Renewal Request."
- +23 IF $ORDER(^PS(52.41,"AQ",RXN,0))
- QUIT "0^Duplicate Rx Renewal Request."
- +24 ;N TITMSG
- +25 ;I $$TITRX^PSOUTL(RXN)="t" D Q TITMSG
- +26 ;. S TITMSG="0^Prescription was marked as 'Titration to Maintenance Dose' by Pharmacy and cannot be renewed."
- +27 ;. S TITMSG=TITMSG_" To repeat the titration, enter a new prescription or copy the prior titration order."
- +28 ;. S TITMSG=TITMSG_" To continue the maintenance dose, refill this prescription if refills are available"
- +29 ;. S TITMSG=TITMSG_" or enter a new prescription for the maintenance dose."
- +30 KILL PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,TITMSG
- +31 QUIT 1_$SELECT($GET(PSOIFLAG):"^"_$GET(PSONEWOI),1:"")
- +32 ;
- INST1 ;Set Pharmacy Instructions array
- +1 NEW PSOTZ
- +2 ;for titration renewal, copy patient instructions from 52.41 - *p441
- +3 IF $$TITRX^PSOUTL(RXN)="t"
- IF $GET(PSOORRNW)
- IF $GET(ORD)
- Begin DoDot:1
- +4 IF $ORDER(^PS(52.41,ORD,2,0))
- SET PHI=^PS(52.41,ORD,2,0)
- SET PSOTZ=0
- Begin DoDot:2
- +5 FOR
- SET PSOTZ=$ORDER(^PS(52.41,ORD,2,PSOTZ))
- if 'PSOTZ
- QUIT
- SET PHI(PSOTZ)=^PS(52.41,ORD,2,PSOTZ,0)
- End DoDot:2
- End DoDot:1
- QUIT
- +6 ;
- +7 IF $ORDER(^PSRX(RXN,"PI",0))
- SET PHI=$GET(^PSRX(RXN,"PI",0))
- SET PSOTZ=0
- Begin DoDot:1
- +8 FOR
- SET PSOTZ=$ORDER(^PSRX(RXN,"PI",PSOTZ))
- if PSOTZ=""
- QUIT
- SET PHI(PSOTZ)=$GET(^PSRX(RXN,"PI",PSOTZ,0))
- End DoDot:1
- +9 QUIT
- INST2 ;Set Instructions and Comments
- +1 IF '$GET(PSORENW("OIRXN"))
- QUIT
- +2 IF $GET(PSOFDR)
- QUIT
- +3 NEW PSOPHL,PSOPRL
- +4 IF $ORDER(^PSRX(PSORENW("OIRXN"),"PI",0))
- KILL PHI
- SET PHI=$GET(^PSRX(PSORENW("OIRXN"),"PI",0))
- SET PSOPHL=""
- Begin DoDot:1
- +5 FOR
- SET PSOPHL=$ORDER(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL))
- if PSOPHL=""
- QUIT
- SET PHI(PSOPHL)=$GET(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0))
- End DoDot:1
- +6 IF $ORDER(^PSRX(PSORENW("OIRXN"),"PRC",0))
- KILL PRC
- SET PRC=$GET(^PSRX(PSORENW("OIRXN"),"PRC",0))
- SET PSOPRL=""
- Begin DoDot:1
- +7 FOR
- SET PSOPRL=$ORDER(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL))
- if PSOPRL=""
- QUIT
- SET PRC(PSOPRL)=$GET(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0))
- End DoDot:1
- +8 QUIT