| [623] | 1 | PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,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 PDA^PPPPDA1 supported by DBIA 1374
|
|---|
| 20 | ;External reference ^PS(55 supported by DBIA 2228
|
|---|
| 21 | ;External reference ^DIC(31 supported by DBIA 658
|
|---|
| 22 | ;External reference ^DPT(D0,.372 supported by DBIA 1476
|
|---|
| 23 | ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
|
|---|
| 24 | ;External reference ^ORRDI1 is supported by DBIA 4659
|
|---|
| 25 | ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
|
|---|
| 26 | ;
|
|---|
| 27 | ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
|
|---|
| 28 | ;
|
|---|
| 29 | START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END
|
|---|
| 30 | D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
|
|---|
| 31 | ;call to add bingo board data to file 52.11
|
|---|
| 32 | F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D
|
|---|
| 33 | .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
|
|---|
| 34 | .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
|
|---|
| 35 | K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1
|
|---|
| 36 | G:$G(NOBG) NX
|
|---|
| 37 | S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
|
|---|
| 38 | I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
|
|---|
| 39 | I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1
|
|---|
| 40 | NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START
|
|---|
| 41 | D EOJ G START
|
|---|
| 42 | END Q
|
|---|
| 43 | ;---------------------------------------------------------
|
|---|
| 44 | INIT ;
|
|---|
| 45 | S PSORX("QFLG")=0
|
|---|
| 46 | D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
|
|---|
| 47 | I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
|
|---|
| 48 | INITX Q
|
|---|
| 49 | ;
|
|---|
| 50 | PT ;
|
|---|
| 51 | K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0,DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA
|
|---|
| 52 | I +Y'>0 S PSORX("QFLG")=1 G PTX
|
|---|
| 53 | OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
|
|---|
| 54 | K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
|
|---|
| 55 | ;PSO*195 move SSN write to here and add DISPPRF call
|
|---|
| 56 | D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE
|
|---|
| 57 | W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here!
|
|---|
| 58 | S PSONOAL="" D ALLERGY^PSOORUT2 D I PSONOAL'="" D PAUSE
|
|---|
| 59 | .I PSONOAL'="" W !,$C(7)," No Allergy Assessment!"
|
|---|
| 60 | D REMOTE
|
|---|
| 61 | N PSOUPDT
|
|---|
| 62 | S PSOUPDT=1
|
|---|
| 63 | I XQY0["PSO LMOE FINISH" S PSOUPDT=0
|
|---|
| 64 | D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
|
|---|
| 65 | D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN)
|
|---|
| 66 | ;
|
|---|
| 67 | I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3
|
|---|
| 68 | I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL
|
|---|
| 69 | D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
|
|---|
| 70 | I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
|
|---|
| 71 | S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
|
|---|
| 72 | K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
|
|---|
| 73 | I '$D(^PS(55,PSODFN,0)) D
|
|---|
| 74 | .S PSOPBM=$P(TM,".")
|
|---|
| 75 | .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
|
|---|
| 76 | ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
|
|---|
| 77 | D RXSTA
|
|---|
| 78 | S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
|
|---|
| 79 | I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
|
|---|
| 80 | .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
|
|---|
| 81 | .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
|
|---|
| 82 | .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
|
|---|
| 83 | S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
|
|---|
| 84 | I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
|
|---|
| 85 | .W !!,"Patient Status Required!!",! D ELIG
|
|---|
| 86 | .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
|
|---|
| 87 | .I $D(DIRUT)!(Y=-1) D Q
|
|---|
| 88 | ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
|
|---|
| 89 | ..I $G(PSOPBM) D K PSOPBM
|
|---|
| 90 | ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
|
|---|
| 91 | .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
|
|---|
| 92 | .K DIRUT,DTOUT,DUOUT,X,Y,DA
|
|---|
| 93 | Q:$G(PSOFIN)
|
|---|
| 94 | I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".")
|
|---|
| 95 | D ^PSOBUILD
|
|---|
| 96 | F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
|
|---|
| 97 | I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
|
|---|
| 98 | K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
|
|---|
| 99 | S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
|
|---|
| 100 | D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
|
|---|
| 101 | S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
|
|---|
| 102 | PTX ;
|
|---|
| 103 | K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
|
|---|
| 104 | Q
|
|---|
| 105 | EOJ ;
|
|---|
| 106 | K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM
|
|---|
| 107 | K:'$G(MEDP) PSOQFLG
|
|---|
| 108 | D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
|
|---|
| 109 | K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
|
|---|
| 110 | K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT
|
|---|
| 111 | K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
|
|---|
| 112 | Q
|
|---|
| 113 | ELIG ; shows eligibility and disabilities
|
|---|
| 114 | D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
|
|---|
| 115 | W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
|
|---|
| 116 | .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
|
|---|
| 117 | .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
|
|---|
| 118 | .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
|
|---|
| 119 | K N
|
|---|
| 120 | Q
|
|---|
| 121 | PROFILE ;
|
|---|
| 122 | S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
|
|---|
| 123 | I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
|
|---|
| 124 | S (PSODRG,PSOX)="" F S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG="" F S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX="" S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1
|
|---|
| 125 | K PSOX
|
|---|
| 126 | PROFILEX Q
|
|---|
| 127 | ;
|
|---|
| 128 | MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
|
|---|
| 129 | I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
|
|---|
| 130 | N MAIL
|
|---|
| 131 | S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q
|
|---|
| 132 | MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
|
|---|
| 133 | W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
|
|---|
| 134 | R !,"MAIL: ",MAIL:120
|
|---|
| 135 | I MAIL?1"^".E Q
|
|---|
| 136 | I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
|
|---|
| 137 | W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
|
|---|
| 138 | S $P(^PS(55,PSODFN,0),"^",3)=MAIL
|
|---|
| 139 | Q
|
|---|
| 140 | REMOTE ;
|
|---|
| 141 | I $T(HAVEHDR^ORRDI1)']"" Q
|
|---|
| 142 | I '$$HAVEHDR^ORRDI1 Q
|
|---|
| 143 | I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D Q
|
|---|
| 144 | .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR
|
|---|
| 145 | Q
|
|---|
| 146 | PAUSE ;
|
|---|
| 147 | W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
|
|---|
| 148 | Q
|
|---|
| 149 | ;
|
|---|
| 150 | RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
|
|---|
| 151 | N DA,PSOSTA
|
|---|
| 152 | I '$G(PSODFN) Q
|
|---|
| 153 | S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS"))
|
|---|
| 154 | I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D
|
|---|
| 155 | .D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
|
|---|
| 156 | .S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
|
|---|
| 157 | .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
|
|---|
| 158 | .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE
|
|---|
| 159 | Q
|
|---|
