- 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/PSOAFIN.m
r613 r623 1 PSOAFIN ;VFA/HMS autofinish rx's from cprs ;2:33 PM 11 Nov 2008 2 ;;7.0;OUTPATIENT PHARMACY;**208,250003**;DEC 1997;Build 41 3 ; Copyright (C) 2007 WorldVistA 4 ; 5 ; This program is free software; you can redistribute it and/or modify 6 ; it under the terms of the GNU General Public License as published by 7 ; the Free Software Foundation; either version 2 of the License, or 8 ; (at your option) any later version. 9 ; 10 ; This program is distributed in the hope that it will be useful, 11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ; GNU General Public License for more details. 14 ; 15 ; You should have received a copy of the GNU General Public License 16 ; along with this program; if not, write to the Free Software 17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 ; 19 ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider. The modified routines allow rxs to be finished automatically & properly update File#100 and File#52. 20 ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist. 21 ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run 22 EN I '$D(^PS(52.41,"B",+ORDERID)) Q ;Check for pending order 23 N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO 24 S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) 25 S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("VALMWD")="" 26 S ZTSAVE("ORL")="",ZTSAVE("ORDERID")="" 27 S ZTIO="NULL" ;WVEHR - 250003 28 D ^%ZTLOAD 29 Q ;Quits back to ORWDX 30 ; 31 EN1 ;Autofinish Task Begins Here 32 ;D ^%ZTER ; For testing *ONLY* 33 ;S IOP="NULL" D ^%ZIS U IO 34 S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX 35 Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 36 I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q ;Quits if Autofinish not turned on in File#59 Field#459001 37 ;Check patient eligibility 38 S VFAELD="Y" 39 I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D 40 .S VFAEL=0 41 .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y") D 42 ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1) 43 ..I VFAELL=+VAEL(1) S VFAELD="Y" 44 Q:VFAELD="N" 45 ;Check Date Verify Code Last Changed and check Verify Code never expires. 46 S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines 47 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" 48 D ^DIC K DIC 49 Q:+Y=-1 ;Quits if AUTOFINISH,RX not a user 50 S DA=+Y 51 D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX 52 K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null 53 S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for 54 S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists 55 I $G(PSOAFPAT)="" D 56 .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D 57 ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) 58 ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) 59 I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status 60 S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11 61 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 62 S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM 63 D ^PSOORFIN ;Begins execution of Rx Finishing routines 64 K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE 65 Q ;Autofinish Task Quits Here 66 ; 67 ; 68 ; 69 NOPATS ;Quit message prints instead of prescription if no patient status 70 ;Checks for nw orders in File#52.41 71 ;I $G(REA)'="" Q ;Quits if not signing a new rx 72 S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3) 73 I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q ;Quits if no new pending rxs in File#52.41 74 K PSOAFORB,PSOAFOB1,PSOAFRXS 75 I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44 76 I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44 77 I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name 78 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 79 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 80 QLBL ;Queues no patient status notice 81 D ^%ZISC 82 S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables 83 Q:PSOLAP="" 84 S ZTSAVE("*")="" 85 D ^%ZTLOAD 86 H 1 87 D ^%ZISC 88 K PSOAFDFN,PSOAFPNM 89 Q 90 ; 91 PLBL ;Prints no patient status notice 92 W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)" 93 W !!,"FOR PATIENT: ",PSOAFPNM_" "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9) 94 W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT." 95 W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT" 96 W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS" 97 W !!,"THANK YOU" 98 W !,"AUTOFINISH,RX" 99 W !,$$FMTE^XLFDT($$NOW^XLFDT()) 100 D ^%ZISC 101 EX K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE 102 Q 103 ; 104 DISPD ;Selects dispense drug if not selected in CPRS 105 S PSI=0 106 F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D Q:PSI>0 107 .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI 108 S VFASDD="Y" 109 Q 1 PSOAFIN ;VFA/HMS autofinish rx's from cprs ;4/21/07 19:10 2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 3 ; Copyright (C) 2007 WorldVistA 4 ; 5 ; This program is free software; you can redistribute it and/or modify 6 ; it under the terms of the GNU General Public License as published by 7 ; the Free Software Foundation; either version 2 of the License, or 8 ; (at your option) any later version. 9 ; 10 ; This program is distributed in the hope that it will be useful, 11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ; GNU General Public License for more details. 14 ; 15 ; You should have received a copy of the GNU General Public License 16 ; along with this program; if not, write to the Free Software 17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 ; 19 ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider. The modified routines allow rxs to be finished automatically & properly update File#100 and File#52. 20 ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist. 21 ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run 22 EN I '$D(^PS(52.41,"B",+ORDERID)) Q ;Check for pending order 23 N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK 24 S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) 25 S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("IO*")="",ZTSAVE("VALMWD")="",ZTSAVE("ORL")="",ZTSAVE("ORDERID")="" D ^%ZTLOAD 26 Q ;Quits back to ORWDX 27 ; 28 EN1 ;Autofinish Task Begins Here 29 S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX 30 Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 31 I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q ;Quits if Autofinish not turned on in File#59 Field#459001 32 ;Check patient eligibility 33 S VFAELD="Y" 34 I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D 35 .S VFAEL=0 36 .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y") D 37 ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1) 38 ..I VFAELL=+VAEL(1) S VFAELD="Y" 39 Q:VFAELD="N" 40 ;Check Date Verify Code Last Changed and check Verify Code never expires. 41 S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines 42 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" 43 D ^DIC K DIC 44 Q:+Y=-1 ;Quits if AUTOFINISH,RX not a user 45 S DA=+Y 46 D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX 47 K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null 48 S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for 49 S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists 50 I $G(PSOAFPAT)="" D 51 .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D 52 ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) 53 ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) 54 I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status 55 S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11 56 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 57 S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM 58 D ^PSOORFIN ;Begins execution of Rx Finishing routines 59 K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE 60 Q ;Autofinish Task Quits Here 61 ; 62 ; 63 ; 64 NOPATS ;Quit message prints instead of prescription if no patient status 65 ;Checks for nw orders in File#52.41 66 ;I $G(REA)'="" Q ;Quits if not signing a new rx 67 S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3) 68 I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q ;Quits if no new pending rxs in File#52.41 69 K PSOAFORB,PSOAFOB1,PSOAFRXS 70 I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44 71 I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44 72 I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name 73 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 74 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) 75 QLBL ;Queues no patient status notice 76 D ^%ZISC 77 S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables 78 Q:PSOLAP="" 79 S ZTSAVE("*")="" 80 D ^%ZTLOAD 81 H 1 82 D ^%ZISC 83 K PSOAFDFN,PSOAFPNM 84 Q 85 ; 86 PLBL ;Prints no patient status notice 87 W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)" 88 W !!,"FOR PATIENT: ",PSOAFPNM_" "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9) 89 W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT." 90 W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT" 91 W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS" 92 W !!,"THANK YOU" 93 W !,"AUTOFINISH,RX" 94 W !,$$FMTE^XLFDT($$NOW^XLFDT()) 95 D ^%ZISC 96 EX K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE 97 Q 98 ; 99 DISPD ;Selects dispense drug if not selected in CPRS 100 S PSI=0 101 F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D Q:PSI>0 102 .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI 103 S VFASDD="Y" 104 Q
Note:
See TracChangeset
for help on using the changeset viewer.
