- 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/PSORENW4.m
r613 r623 1 PSORENW4 2 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264,225**;DEC 1997;Build 293 4 5 6 7 SEL 8 9 10 11 12 13 14 15 16 17 18 SELQ 19 20 21 PROCESS 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 ;I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T60 ;.S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=061 ;.F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0)62 63 64 65 66 67 68 69 70 71 DSPL 72 73 74 75 76 77 78 79 80 81 82 83 84 PROCESSX 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 INIT 101 102 103 104 ASK 105 106 107 108 109 110 111 112 113 114 115 116 117 118 POZ 119 120 1 PSORENW4 ;BIR/SAB - rx speed renew ;03/06/95 2 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264**;DEC 1997;Build 19 3 ;External reference to ^PSDRUG supported by DBIA 221 4 ;External reference to ^PS(50.7 supported by DBIA 2223 5 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 6 ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867 7 SEL I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q 8 N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q 9 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 10 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 11 K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ 12 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D 13 .S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG") 14 .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0 15 I '$G(PSOOELSE) S VALMBCK="" G SELQ 16 S VALMBCK="R" 17 D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY 18 SELQ K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1 19 Q 20 ; 21 PROCESS ; Process one order at a time 22 I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR,PSOMSG D PAUSE^VALM1 Q 23 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q 24 K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW" 25 S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2) 26 I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0) 27 S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1 28 I '$G(PSORENW("PROVIDER")) D 29 .S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4) 30 .S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) 31 S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") 32 I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5) 33 S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^") 34 S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^") 35 S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) 36 S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") 37 S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6) 38 S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7) 39 ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8) 40 ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9) 41 S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) 42 S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0 43 F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D 44 .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") 45 .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) 46 .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) 47 .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) 48 .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) 49 .K DOSE 50 I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q 51 . I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D Q 52 . . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",! 53 . I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D 54 . . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! 55 I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW") 56 I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D K T 57 .S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0 58 .F S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0) 59 I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T 60 .S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0 61 .F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0) 62 W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! 63 I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D G:$G(PSORENW("DFLG")) PROCESSX 64 .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q 65 .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 66 D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX 67 D FILDATE^PSORENW0 68 D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX 69 D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX 70 D STOP^PSORENW1 71 DSPL K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS") 72 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1 73 I $G(PSODIR("CS")) D 74 .S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) 75 .I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF 76 D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX 77 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX 78 I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX 79 D EN^PSORN52(.PSORENW) 80 D RNPSOSD^PSOUTIL 81 D CAN^PSORENW0,DCORD^PSONEW2 82 S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT") 83 S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_"," 84 PROCESSX I PSORENW("DFLG") D W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1 85 .K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK 86 .K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS") 87 .D POZ 88 K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1 89 D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) 90 K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC") 91 K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 92 I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) 93 D KLIB^PSORENW1 94 K PSORDLOK 95 S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D 96 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) 97 .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4)) 98 K RXN,RXN1,^TMP("PSORXN",$J) 99 Q 100 INIT ; 101 D ASK Q:PSORENW("DFLG") 102 D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG") 103 Q 104 ASK ;upfront questions 105 W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG") S PSORENW("ISSUE DATE")=PSOID 106 D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG") 107 S PSORNW("FILL DATE")=PSORENW("FILL DATE") 108 D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG") 109 D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG") 110 D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG") 111 S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG") 112 K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q 113 S PSOQTY=Y K DIR,DIRUT 114 D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG") 115 D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0 116 Q 117 ; 118 POZ ; 119 K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT 120 Q
Note:
See TracChangeset
for help on using the changeset viewer.
