- 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/PSORENW0.m
r613 r623 1 PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;4/24/07 9:05am2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206**;DEC 1997;Build 39 3 4 5 6 7 8 PROCESS 9 10 11 12 13 14 15 16 17 18 19 20 DSPL 21 22 23 24 25 26 27 28 29 30 31 ANQ 32 33 34 35 36 37 38 39 PROCESSX 40 41 42 43 44 45 46 CHECK 47 48 49 50 51 52 53 54 55 56 57 58 59 60 I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 CHECKX 90 91 CHKDIV 92 93 94 95 96 CHKDIVX 97 98 DRUG 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 RXN 116 117 118 119 RETRY 120 121 122 123 124 125 126 127 128 129 RXNX 130 131 132 FILDATE 133 134 135 136 137 138 139 140 141 EDIT 142 143 144 145 146 147 148 149 EDITX 150 151 152 DELETE 153 154 155 156 157 158 CAN 159 160 161 162 163 164 165 166 167 DIR 168 169 170 171 172 DIRX 173 174 NEWPT 175 176 177 178 179 NEWPTX 180 181 EN(PSORENW) 182 183 184 185 186 187 188 189 190 191 CDOSE 192 193 194 195 196 197 198 199 200 201 1 PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am 2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237**;DEC 1997 3 ;External reference to ^PS(50.7 supported by DBIA 2223 4 ;External reference to ^PSDRUG supported by DBIA 221 5 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 6 ; 7 ;PSO*237 was not adding to Clozapine Override file, fix 8 PROCESS ; 9 D ^PSORENW1 10 D INST2^PSORENW 11 I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT 12 S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE") 13 I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW") 14 W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! 15 D CHECK G:PSORENW("DFLG") PROCESSX 16 D FILDATE 17 D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX 18 D RXN G:PSORENW("DFLG") PROCESSX 19 D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR) 20 DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX 21 S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT 22 G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX 23 G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL 24 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX 25 I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL 26 D EN^PSORN52(.PSORENW) 27 D RNPSOSD^PSOUTIL 28 D CAN,DCORD^PSONEW2 29 S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W" 30 ;PSO*237 add to Clozapine Override file 31 ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D 32 . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% 33 . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR 34 . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN") 35 . D ^DIE K DIE,DA,DR 36 . S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA 37 . K ANQDATA,X,Y,%,ANQREM 38 ; 39 PROCESSX I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1 40 D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) 41 K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN") 42 K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 43 D CLEAN^PSOVER1 44 Q 45 ; 46 CHECK ; 47 I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX 48 .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1 49 .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R" 50 ;Invalid dosage check 51 N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE 52 I PSOOLPF!(PSONOSIG) D G CHECKX 53 .S PSORENW("DFLG")=1 54 .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig") 55 .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R" 56 .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR 57 .I $G(PSORNSPD) W ! 58 ; 59 S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT 60 I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,"^",3)]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT 61 . S PSORENW("DFLG")=1 62 . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^") 63 . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA") 64 . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT 65 .I $G(ACOM)]"" D 66 ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") 67 ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" 68 ..D ^DIR I 'Y!($D(DIRUT)) Q 69 ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 70 .Q 71 I PSOY="",'$G(PSOORRNW) D 72 .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1 73 .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R" 74 K PSOX,PSOY G:PSORENW("DFLG") CHECKX 75 ; 76 I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q 77 . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached." 78 .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" 79 . S PSORENW("DFLG")=1 80 .I $G(OR0)]"" D 81 ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") 82 ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" 83 ..D ^DIR I 'Y!($D(DIRUT)) Q 84 ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 85 .K ACOM Q 86 D CHKDIV G:PSORENW("DFLG") CHECKX 87 ; 88 D CHKPRV^PSOUTIL 89 CHECKX Q 90 ; 91 CHKDIV ; 92 G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX 93 W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division." 94 I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX 95 D:$P($G(PSOSYS),"^",3) DIR 96 CHKDIVX Q 97 ; 98 DRUG ; 99 K PSOY 100 S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0) 101 I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG")) 102 .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q 103 .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 104 D SET^PSODRG 105 D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only 106 ;D ^PSODRDUP Q:$G(PSORX("DFLG")) ; Set PSORX("DFLG")=1 if process to stop 107 S PSONOOR=PSORENW("NOO") 108 ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR 109 ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN) 110 K PSORX("INTERVENE") 111 S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS") 112 K PSOY,PSONEW("STATUS") 113 Q 114 ; 115 RXN ; 116 K PSOX 117 S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #"))) 118 S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1)) 119 RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY 120 .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file." 121 .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file." 122 .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D 123 ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",! 124 ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered." 125 ..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR 126 ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1 127 .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #"))) 128 .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1)) 129 RXNX K PSOX 130 Q 131 ; 132 FILDATE ; 133 S PSORENW("IRXN")=PSORENW("OIRXN") 134 D NEXT^PSOUTIL(.PSORENW) 135 I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D 136 .D RENFDT^PSOUTIL(.PSORENW) 137 .I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y 138 K PSORENW("IRXN") 139 Q 140 ; 141 EDIT ; 142 K DIR,X,Y 143 S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N") 144 S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to." 145 D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1 146 G:PSORENW("DFLG") EDITX 147 K PSOQUIT,PSORX("FN") I Y D INIT^PSORENW3,EN^PSOORNE4(.PSORENW) S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D FULL^VALM1 Q 148 Q:$G(PSORX("FN")) 149 EDITX S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1 150 Q 151 ; 152 DELETE ; 153 K DA,DIK 154 S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5," 155 D ^DIK K DIK,DIC 156 Q 157 ; 158 CAN ; 159 K REA,DA,MSG 160 S REA="C",DA=PSORENW("OIRXN") 161 S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"") 162 S PSCAN(PSORENW("ORX #"))=DA_"^C" 163 D CAN^PSOCAN 164 K REA,DA,MSG,PSCAN 165 Q 166 ; 167 DIR ; 168 S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N" 169 S DIR("?")="Answer YES to Continue, NO to bypass" 170 D ^DIR K DIR 171 S:$D(DIRUT)!('Y) PSORENW("DFLG")=1 172 DIRX K DIRUT,DTOUT,DUOUT,X,Y 173 Q 174 NEWPT ; 175 S PSOQFLG=0 176 S PSODFN=PSORENW("PSODFN") 177 D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX 178 D PROFILE^PSOREF1 179 NEWPTX Q 180 ; 181 EN(PSORENW) ; Entry Point for Batch Barcode Option 182 S PSORENRX=$G(PSOBBC("OIRXN")) 183 I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q 184 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q 185 .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENRX,0)),"^") 186 K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD 187 D KLIB^PSORENW1 188 I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX) 189 K PSORENRX,PSOBBCLK 190 Q 191 CDOSE ;Validate Dosage field on Renewel, Copy, Edit 192 ;PSOOCPRX must be set to internal Rx number 193 Q:'$G(PSOOCPRX) 194 N PSOOLP,PSOOKZ 195 S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP)) Q:PSOOLP=""!(PSOOLPF) I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1 196 Q:PSOOLPF 197 S PSOOKZ=0 198 I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F S PSOOLP=$O(^PSRX(PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ) I $G(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'="" S PSOOKZ=1 199 I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1 200 I 'PSOOKZ S PSONOSIG=1 201 Q
Note:
See TracChangeset
for help on using the changeset viewer.
