- 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/PSOTPCAN.m
r613 r623 1 PSOTPCAN 2 ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 41 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 CAN(PSOTPRCX) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 MARK 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 MARKV 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 RXPAT 78 79 80 81 82 SET(PSOTPPST) 83 84 85 86 PCAP(PSOPAPPT) 87 88 89 PDIR(PSOTPEX) 90 91 92 93 94 95 96 97 98 VOPN 99 100 101 102 103 104 VOPNX 105 106 107 108 109 110 111 112 113 114 VOPNR 115 116 117 118 119 120 121 NOREN 122 123 124 125 DSPL(PSOTPWRN) 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 EXFLAG(PSOTPPX) 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 SCH 166 167 168 169 170 171 172 173 1 PSOTPCAN ;BIR/RTR - TPB Utility routine ;3/13/07 21:21 2 ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 39 3 ; Modified from FOIA VistA 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ;External reference to PS(55 supported by DBIA 2228 20 ;External reference to VA(200 supported by DBIA 224 21 ; 22 ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient 23 ;Called from all DC actions 24 CAN(PSOTPRCX) ; 25 Q ; placed out of order by PSO*7*227 26 I '$G(PSOTPRCX) Q 27 N PSOTPRC 28 S PSOTPRC=$P($G(^PSRX(PSOTPRCX,0)),"^",2) 29 I '$G(PSOTPRC) Q 30 I '$P($G(^PSRX(PSOTPRCX,"TPB")),"^") Q 31 I '$D(^PS(52.91,PSOTPRC,0)) Q 32 I $P($G(^PS(52.91,PSOTPRC,0)),"^",3),$P($G(^(0)),"^",3)'>DT Q 33 ;Patient is active in the TPB File, and TPB Rx is being canceled 34 I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q 35 N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y 36 S PSOTCXFL=0 37 S X1=DT,X2=-1 D C^%DTC S PSOTC3=X 38 F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL) S PSOTC2="" F S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL) D 39 .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q 40 .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^") 41 .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q 42 .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'<DT S PSOTCXFL=1 43 I 'PSOTCXFL K DA,DIE,DR S DA=PSOTPRC,DIE="^PS(52.91,",DR="2////"_DT_";3////"_6 D ^DIE K DIE,DA,DR 44 Q 45 ; 46 MARK ;Mark Rx as TPB Rx if applicable 47 N PSOTPODE,PSOZTRX 48 I '$G(PSOX("IRXN")) Q 49 I '$D(^PSRX(PSOX("IRXN"),0)) Q 50 I '$G(PSOTPBFG) Q 51 ;I $G(PSOFDR) Q 52 S PSOTPODE=$G(^PSRX(PSOX("IRXN"),0)) 53 I '$P(PSOTPODE,"^",2)!('$P(PSOTPODE,"^",3))!('$P(PSOTPODE,"^",4)) Q 54 S PSOZTRX=$P($G(^PS(53,+$P(PSOTPODE,"^",3),0)),"^") I $$UP^XLFSTR(PSOZTRX)'="NON-VA" Q 55 I '$P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^") Q 56 I $P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^",5)'=0 Q 57 I '$D(^PS(52.91,+$P(PSOTPODE,"^",2),0)) Q 58 I $P($G(^PS(52.91,+$P(PSOTPODE,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q 59 ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here 60 S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1 61 Q 62 MARKV ;Mark from Verify action 63 N PSOTPV1,PSOTPV2 64 I '$G(PSONVLP) Q 65 I '$D(^PSRX(PSONVLP,0)) Q 66 I '$G(PSOTPBFG) Q 67 ;I $G(PSOFDR) Q 68 S PSOTPV1=$G(^PSRX(PSONVLP,0)) 69 I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q 70 S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q 71 I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q 72 I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q 73 I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q 74 I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q 75 S $P(^PSRX(PSONVLP,"TPB"),"^")=1 76 Q 77 RXPAT ;Sets Rx patient status to null 78 N PSOZZTRX 79 I $G(X),$G(X)'>DT D 80 .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")="" 81 Q 82 SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE 83 N PSOZXTRX 84 I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")="" 85 Q 86 PCAP(PSOPAPPT) ;Find nearest Primary Care appointment 87 Q "TODAY AT NOON" 88 ; 89 PDIR(PSOTPEX) ; 90 Q:'$G(PSOTPEX) 91 N PSOTPEXS 92 S PSOTPEXT=0 93 S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9) 94 W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")" 95 W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" 96 W ! K DIR S DIR(0)="E",DIR("A")="Press <ret> to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSOTPEXT=1 97 Q 98 VOPN ; 99 I '$G(PSOTPPEN) Q 100 I '$D(^PSRX(PSOTPPEN,0)) Q 101 N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 102 S PSOTPPE6=1 103 S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4) 104 VOPNX ; 105 I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1 106 I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1 107 I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 108 I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 109 I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 110 I $G(PSOTPPEX) D I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option" 111 .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8 W !,$G(PSOTPPE5(PSOTPPE8)) 112 .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR 113 Q 114 VOPNR ; 115 I '$G(PSOTPPEN) Q 116 I '$D(^PS(52.41,PSOTPPEN,0)) Q 117 N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 118 S PSOTPPE6=1 119 I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN 120 S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^") 121 NOREN ; 122 S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5) 123 G VOPNX 124 ; 125 DSPL(PSOTPWRN) ; 126 N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3 127 I '$G(PSOTPWRN) Q 128 I '$D(^PS(52.41,PSOTPWRN,0)) Q 129 I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D Q 130 . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3) 131 . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) 132 . I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites 133 . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR 134 . . Q 135 . Q 136 S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^") 137 S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) 138 I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites 139 .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR 140 Q 141 EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary, 142 ;and possibly delete inactive date and reason code for patient in 52.91 143 I '$G(DT) S DT=$$DT^XLFDT 144 I '$G(PSOTPPX) Q 145 I '$D(^PS(52.91,PSOTPPX,0)) Q 146 I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q 147 I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q 148 N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9 149 S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X 150 S PSOTPPX9=0 151 F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2 S PSOTPPX3="" F S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3="" D 152 .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q 153 .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q 154 .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q 155 .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q 156 .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q 157 .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4) 158 .I 'PSOTPPX5!('PSOTPPX6) Q 159 .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q 160 .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q 161 .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1 162 I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR 163 Q 164 ; 165 SCH ;DBIA to return TPB patients to Scheduling 166 N PSOSCT,PSOSCTD 167 K ^TMP($J,"PSODFN") 168 F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT I PSOSCT=$P($G(^(PSOSCT,0)),"^") D 169 .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3) 170 .I 'PSOSCTD!(PSOSCTD>DT) D 171 ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q 172 ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)="" 173 Q
Note:
See TracChangeset
for help on using the changeset viewer.
