PSORX1 ;BIR/SAB-medication processing driver ;8/17/16 5:10pm
;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,300,170,320,326,324,334,251,454,488,497,519**;DEC 1997;Build 5
;
;External reference ^PS(55 supported by DBIA 2228
;External reference ^DIC(31 supported by DBIA 658
;External reference ^DPT(D0,.372 supported by DBIA 1476
;External reference DISPPRF^DGPFAPI supported by DBIA #4563
;External reference ^ORRDI1 is supported by DBIA 4659
;External reference ^XTMP("ORRDI" is supported by DBIA 4660
;External reference ^PSUHL supported by DBIA 4803
;
;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
;
START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG,^TMP($J,"PSOTDD"),^TMP("PSORXPO",$J),^TMP("PSORXBO",$J)
I '$G(PSOONEVA) N PSOONEVA S PSOONEVA=1
D EOJ S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END
D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
;call to add bingo board data to file 52.11
F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D
.I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
.S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX
G:$G(NOBG) NX
S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL")!($G(PSOFROM)="UNHOLD") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START
D EOJ G START
END Q
;---------------------------------------------------------
INIT ;
S PSORX("QFLG")=0
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
INITX Q
;
PT ;
K ^TMP("PSORXDC",$J),^TMP($J,"PSEXC","OUT"),CLOZPAT,DIC,PSODFN,PSOPTLK
S PSORX("QFLG")=0,DIC(0)="QEAM" D EN^PSOPATLK S Y=PSOPTLK
I +Y'>0 S PSORX("QFLG")=1 G PTX
OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
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
;PSO*195 move SSN write to here and add DISPPRF call
S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")
W " ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
I $G(XQY0)["PSO LMOE FINISH",'$G(MEDP),$D(^TMP($J,"PSOFLPO",PSODFN)) D
.I '$D(IOINORM)!('$D(IOINHI)) S X="IORVOFF;IORVON;IOINHI;IOINORM" D ENDR^%ZISS
.W " ",IORVON_IOINHI,"<This patient has flagged orders>",IOINORM_IORVOFF
S PSONOAL="" D ALLERGY^PSOORUT2 D I PSONOAL'="" D PAUSE
.I PSONOAL'="" W !,$C(7)," No Allergy Assessment!"
D REMOTE
; bwf - 1/9/2014 - PHARMACY INNOVATIONS, adding call and on screen message to get remote rx's from MDWS.
I $G(PSOONEVA) D
.N TFL,TFILIST,TFLP,TFLSITE,TFLIEN,TFLCNT,TFLDUP
.D TFL^VAFCTFU1(.TFL,PSODFN)
.S TFLCNT=0
.S TFILIST="^VAMC^M&ROC^M&ROC(M&RO)^OC^OPC^CBOC^PRRTP^DOM^HCS^MC(M)^MC(M&D)^MORC^NHC^VANPH^SOC^SARRTP^" ; only exact matches
.S TFLP=0 F S TFLP=$O(TFL(TFLP)) Q:'TFLP!(TFLCNT=2) D
..S TFLSITE=$P(TFL(TFLP),U) Q:TFLSITE=""
..Q:$D(TFLDUP(TFLSITE))
..S TFLDUP(TFLSITE)=""
..Q:TFILIST'[(U_$P(TFL(TFLP),U,5)_U)
..S TFLCNT=$G(TFLCNT)+1
.I $G(TFLCNT)<2 Q
.I '$$GET1^DIQ(59.7,1,101,"I") D Q
..W !!,"The OneVA Pharmacy flag is turned off. Queries will NOT"
..W !,"be made to other VA Pharmacy locations.",!
.K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="locations",DIR("A",1)="Would you like to query prescriptions from other OneVA Pharmacy" D ^DIR ;CHANGE PROMPT DEFAULT FROM YES TO NO ;*519
.K DIR
.Q:'Y
.W !!,"Please wait. Checking for prescriptions at other VA Pharmacy locations. This may take a moment...",!
.D REMOTERX^PSORRX1(PSODFN,PSOSITE)
N PSOUPDT
S PSOUPDT=1
I $G(XQY0)["PSO LMOE FINISH" S PSOUPDT=0
D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
D:($G(XQY0)["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN)
;
I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3
I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL
D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
;Call to display remote/local prescriptions
I '$G(PSOFIN) D RDICHK^PSORMRX(PSODFN)
S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
I '$D(^PS(55,PSODFN,0)) D
.K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
D RXSTA
S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
.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
.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
.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)
S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
.W !!,"Patient Status Required!!",! D ELIG
.W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
.I $D(DIRUT)!(Y=-1) D Q
..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
..I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
.S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
.K DIRUT,DTOUT,DUOUT,X,Y,DA
Q:$G(PSOFIN)
D ^PSOBUILD
F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
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
K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
I $O(RXFL("")),$P(^PS(55,PSODFN,0),"^",7)="" D
. N %
. D NOW^%DTC
. S $P(^PS(55,PSODFN,0),"^",7)=$E(%,1,12),$P(^(0),"^",8)="A" D LOGDFN^PSUHL(PSODFN)
PTX ;
K X,Y,^TMP("PS",$J),^TMP($J,"PSEXC","OUT"),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR,PSOPTLK
Q
EOJ ;
I $G(PSODFN) K ^TMP($J,"PSOINTERVENE",PSODFN)
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
K:'$G(MEDP) PSOQFLG
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
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
K ^TMP("PSORXDD",$J),^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J),^TMP("PSORXPO",$J)
I '$G(MEDP),'$G(PSOQUIT) K PAT
K ^TMP("PSORXBO",$J),PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG,^TMP($J,"PSOFLPO")
K PPL,PPL1,PSOQFLAG ;*334 ADDED KILLS
K ^XTMP("PSORRX1",$J),PSORCNT ;*454 added kill
Q
ELIG ; shows eligibility and disabilities
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)
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
.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)
.W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
.W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
K N
Q
PROFILE ;
S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
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
K PSOX
PROFILEX Q
;
MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
N MAIL
S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q
MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions. Please select mail"
W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
R !,"MAIL: ",MAIL:120
I MAIL?1"^".E Q
I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
S $P(^PS(55,PSODFN,0),"^",3)=MAIL
Q
REMOTE ;
I $T(HAVEHDR^ORRDI1)']"" Q
I '$$HAVEHDR^ORRDI1 Q
D HD^PSODDPR2():(($Y+5)'>IOSL)
I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !!,"Remote data not available - Only local order checks processed.",! D HD^PSODDPR2():(($Y+5)'>IOSL) Q
Q
PAUSE ;
W ! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
;
RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
N DA,PSOSTA
I '$G(PSODFN) Q
S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS"))
I $G(XQY0)["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D
.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)
.S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
.I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORX1 10345 printed Dec 13, 2024@02:34:25 Page 2
PSORX1 ;BIR/SAB-medication processing driver ;8/17/16 5:10pm
+1 ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,300,170,320,326,324,334,251,454,488,497,519**;DEC 1997;Build 5
+2 ;
+3 ;External reference ^PS(55 supported by DBIA 2228
+4 ;External reference ^DIC(31 supported by DBIA 658
+5 ;External reference ^DPT(D0,.372 supported by DBIA 1476
+6 ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
+7 ;External reference ^ORRDI1 is supported by DBIA 4659
+8 ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
+9 ;External reference ^PSUHL supported by DBIA 4803
+10 ;
+11 ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
+12 ;
START KILL PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG,^TMP($JOB,"PSOTDD"),^TMP("PSORXPO",$JOB),^TMP("PSORXBO",$JOB)
+1 IF '$GET(PSOONEVA)
NEW PSOONEVA
SET PSOONEVA=1
+2 DO EOJ
SET (PSOBCK,PSOERR)=1
DO INIT
if PSORX("QFLG")
GOTO END
+3 DO PT
if $GET(PSORX("QFLG"))
GOTO END
DO FULL^VALM1
IF $GET(NOPROC)
KILL NOPROC
GOTO NX
+4 ;call to add bingo board data to file 52.11
+5 FOR SLPPL=0:0
SET SLPPL=$ORDER(RXRS(SLPPL))
if 'SLPPL
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PSRX(SLPPL,"STA")),"^")'=5
KILL RXRS(SLPPL)
QUIT
+7 SET RXREC=SLPPL
DO WIND^PSOSUPOE
IF $GET(PBINGRTE)
DO BBADD^PSOSUPOE
SET (BINGCRT,BINGRTE)=1
if $GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
End DoDot:1
+8 KILL TM,TM1
IF $GET(PSORX("PSOL",1))]""!($DATA(RXRS))
DO ^PSORXL
KILL PSORX
+9 if $GET(NOBG)
GOTO NX
+10 SET TM=$PIECE(^TMP("PSOBB",$JOB),"^")
SET TM1=$PIECE(^TMP("PSOBB",$JOB),"^",2)
KILL ^TMP("PSOBB",$JOB)
+11 IF $GET(PSOFROM)="NEW"!($GET(PSOFROM)="REFILL")!($GET(PSOFROM)="PARTIAL")!($GET(PSOFROM)="UNHOLD")
if $DATA(BINGCRT)&($DATA(BINGRTE)&($DATA(DISGROUP)))
DO ^PSOBING1
KILL BINGCRT,BINGRTE,BBRX,BBFLG
NX IF $GET(POERR("DEAD"))!$GET(PSOQFLG)
DO EOJ
GOTO START
+1 DO EOJ
GOTO START
END QUIT
+1 ;---------------------------------------------------------
INIT ;
+1 SET PSORX("QFLG")=0
+2 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
SET PSORX("QFLG")=1
+3 IF $PIECE($GET(PSOPAR),"^",2)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("VERIFY")=1
INITX QUIT
+1 ;
PT ;
+1 KILL ^TMP("PSORXDC",$JOB),^TMP($JOB,"PSEXC","OUT"),CLOZPAT,DIC,PSODFN,PSOPTLK
+2 SET PSORX("QFLG")=0
SET DIC(0)="QEAM"
DO EN^PSOPATLK
SET Y=PSOPTLK
+3 IF +Y'>0
SET PSORX("QFLG")=1
GOTO PTX
OERR if $GET(MEDP)
NEW PAT,POERR
KILL PSOXFLG
SET (DFN,PSODFN)=+Y
SET PSORX("NAME")=$PIECE(Y,"^",2)
+1 KILL NPPROC,PSOQFLG,DIC,DR,DIQ
SET DIC=2
SET DA=PSODFN
SET DR=.351
SET DIQ="PSOPTPST"
DO EN^DIQ1
+2 KILL DIC,DA,DR,DIQ
DO DEAD^PSOPTPST
IF $GET(PSOQFLG)
SET NOPROC=1
QUIT
+3 ;PSO*195 move SSN write to here and add DISPPRF call
+4 SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
WRITE !!?10,$CHAR(7),PSORX("NAME")
+5 WRITE " ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")"
KILL SSN
+6 IF $GET(XQY0)["PSO LMOE FINISH"
IF '$GET(MEDP)
IF $DATA(^TMP($JOB,"PSOFLPO",PSODFN))
Begin DoDot:1
+7 IF '$DATA(IOINORM)!('$DATA(IOINHI))
SET X="IORVOFF;IORVON;IOINHI;IOINORM"
DO ENDR^%ZISS
+8 WRITE " ",IORVON_IOINHI,"<This patient has flagged orders>",IOINORM_IORVOFF
End DoDot:1
+9 SET PSONOAL=""
DO ALLERGY^PSOORUT2
Begin DoDot:1
+10 IF PSONOAL'=""
WRITE !,$CHAR(7)," No Allergy Assessment!"
End DoDot:1
IF PSONOAL'=""
DO PAUSE
+11 DO REMOTE
+12 ; bwf - 1/9/2014 - PHARMACY INNOVATIONS, adding call and on screen message to get remote rx's from MDWS.
+13 IF $GET(PSOONEVA)
Begin DoDot:1
+14 NEW TFL,TFILIST,TFLP,TFLSITE,TFLIEN,TFLCNT,TFLDUP
+15 DO TFL^VAFCTFU1(.TFL,PSODFN)
+16 SET TFLCNT=0
+17 ; only exact matches
SET TFILIST="^VAMC^M&ROC^M&ROC(M&RO)^OC^OPC^CBOC^PRRTP^DOM^HCS^MC(M)^MC(M&D)^MORC^NHC^VANPH^SOC^SARRTP^"
+18 SET TFLP=0
FOR
SET TFLP=$ORDER(TFL(TFLP))
if 'TFLP!(TFLCNT=2)
QUIT
Begin DoDot:2
+19 SET TFLSITE=$PIECE(TFL(TFLP),U)
if TFLSITE=""
QUIT
+20 if $DATA(TFLDUP(TFLSITE))
QUIT
+21 SET TFLDUP(TFLSITE)=""
+22 if TFILIST'[(U_$PIECE(TFL(TFLP),U,5)_U)
QUIT
+23 SET TFLCNT=$GET(TFLCNT)+1
End DoDot:2
+24 IF $GET(TFLCNT)<2
QUIT
+25 IF '$$GET1^DIQ(59.7,1,101,"I")
Begin DoDot:2
+26 WRITE !!,"The OneVA Pharmacy flag is turned off. Queries will NOT"
+27 WRITE !,"be made to other VA Pharmacy locations.",!
End DoDot:2
QUIT
+28 ;CHANGE PROMPT DEFAULT FROM YES TO NO ;*519
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="locations"
SET DIR("A",1)="Would you like to query prescriptions from other OneVA Pharmacy"
DO ^DIR
+29 KILL DIR
+30 if 'Y
QUIT
+31 WRITE !!,"Please wait. Checking for prescriptions at other VA Pharmacy locations. This may take a moment...",!
+32 DO REMOTERX^PSORRX1(PSODFN,PSOSITE)
End DoDot:1
+33 NEW PSOUPDT
+34 SET PSOUPDT=1
+35 IF $GET(XQY0)["PSO LMOE FINISH"
SET PSOUPDT=0
+36 DO CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
+37 if ($GET(XQY0)["PSO LMOE FINISH")&('$GET(SNGLPAT))
DO DISPPRF^DGPFAPI(PSODFN)
+38 ;
+39 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
WRITE !?10,"Patient has another language preference!",!
HANG 3
+40 IF $GET(^PS(55,"ASTALK",PSODFN))
WRITE !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",!
HANG 2
DO MAIL
+41 DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
+42 ;Call to display remote/local prescriptions
+43 IF '$GET(PSOFIN)
DO RDICHK^PSORMRX(PSODFN)
+44 SET PSOQFLG=0
SET DIC="^PS(55,"
SET DLAYGO=55
+45 IF '$DATA(^PS(55,PSODFN,0))
Begin DoDot:1
+46 KILL DD,DO
SET DIC(0)="L"
SET (DINUM,X)=PSODFN
DO FILE^DICN
if Y<1
Begin DoDot:2
+47 SET $PIECE(^PS(55,PSODFN,0),"^")=PSODFN
KILL DIK
SET DA=PSODFN
SET DIK="^PS(55,"
SET DIK(1)=.01
DO EN^DIK
KILL DIK
End DoDot:2
KILL DIC,DA,DR,DD,DO
End DoDot:1
+48 DO RXSTA
+49 SET PSOLOUD=1
if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
DO EN^PSOHLUP(PSODFN)
KILL PSOLOUD
+50 IF $GET(^PS(55,PSODFN,"PS"))']""
Begin DoDot:1
+51 LOCK +^PS(55,PSODFN):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE $CHAR(7),!!,"Patient Data is Being Edited by Another User!",!
SET POERR("QFLG")=1
if $GET(PSOFIN)
SET PSOQUIT=1
QUIT
+52 SET PSOXFLG=1
SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")",!
KILL SSN
+53 SET DIE=55
SET DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1"
SET DA=PSODFN
WRITE !!,?5,">>PHARMACY PATIENT DATA<<",!
DO ^DIE
LOCK -^PS(55,PSODFN)
End DoDot:1
IF $GET(POERR("QFLG"))
GOTO EOJ
+54 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
IF PSOX]""
SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
+55 IF $GET(^PS(55,PSODFN,"PS"))']""
Begin DoDot:1
+56 WRITE !!,"Patient Status Required!!",!
DO ELIG
+57 WRITE !
KILL POERR("QFLG"),DIC,DR,DIE
SET DIC("A")="RX PATIENT STATUS: "
SET DIC(0)="QEAMZ"
SET DIC=53
DO ^DIC
KILL DIC
+58 IF $DATA(DIRUT)!(Y=-1)
Begin DoDot:2
+59 WRITE $CHAR(7),"Required Data!",!
SET POERR("QFLG")=1
if $GET(PSOFIN)
SET PSOQUIT=1
+60 IF $ORDER(^PS(55,PSODFN,0))=""
SET DA=PSODFN
SET DIK="^PS(55,"
DO ^DIK
End DoDot:2
QUIT
+61 SET ^PS(55,PSODFN,"PS")=+Y
SET PSORX("PATIENT STATUS")=$PIECE(^PS(53,+Y,0),"^")
+62 KILL DIRUT,DTOUT,DUOUT,X,Y,DA
End DoDot:1
IF $GET(POERR("QFLG"))
GOTO EOJ
+63 if $GET(PSOFIN)
QUIT
+64 DO ^PSOBUILD
+65 FOR PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY"
SET RTN=PT_"^PSOPTPST"
DO @RTN
if $GET(POERR("DEAD"))!($GET(PSOQFLG))
QUIT
+66 IF $GET(POERR("DEAD"))
SET POERR("QFLG")=1
FOR II=0:0
SET II=$ORDER(^PS(52.41,"P",PSODFN,II))
if $PIECE($GET(^PS(52.41,II,0)),"^",3)'="DC"&($PIECE($GET(^(0)),"^",3)'="DE")
DO DC^PSOORFI2
+67 KILL PSOERR("DEAD"),II
IF $GET(PSOQFLG)
SET POERR("QFLG")=1
GOTO EOJ
QUIT
+68 SET (PAT,PSOXXDFN)=PSODFN
SET POERR=1
DO ^PSOORUT2
DO BLD^PSOORUT1
DO EN^PSOLMUTL
+69 DO CLEAR^VALM1
if $GET(PSOQUIT)
GOTO PTX
DO EN^PSOLMAO
+70 SET (DFN,PSODFN)=PSOXXDFN
KILL DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
+71 IF $ORDER(RXFL(""))
IF $PIECE(^PS(55,PSODFN,0),"^",7)=""
Begin DoDot:1
+72 NEW %
+73 DO NOW^%DTC
+74 SET $PIECE(^PS(55,PSODFN,0),"^",7)=$EXTRACT(%,1,12)
SET $PIECE(^(0),"^",8)="A"
DO LOGDFN^PSUHL(PSODFN)
End DoDot:1
PTX ;
+1 KILL X,Y,^TMP("PS",$JOB),^TMP($JOB,"PSEXC","OUT"),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR,PSOPTLK
+2 QUIT
EOJ ;
+1 IF $GET(PSODFN)
KILL ^TMP($JOB,"PSOINTERVENE",PSODFN)
+2 KILL 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
+3 if '$GET(MEDP)
KILL PSOQFLG
+4 DO KVA^VADPT
DO FULL^VALM1
KILL PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
+5 KILL 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
+6 KILL ^TMP("PSORXDD",$JOB),^TMP("PSORXDC",$JOB),^TMP("PSOAL",$JOB),^TMP("PSOAO",$JOB),^TMP("PSOSF",$JOB),^TMP("PSOPF",$JOB),^TMP("PSOPI",$JOB),^TMP("PSOPO",$JOB),^TMP("PSOHDR",$JOB),^TMP("PSORXPO",$JOB)
+7 IF '$GET(MEDP)
IF '$GET(PSOQUIT)
KILL PAT
+8 KILL ^TMP("PSORXBO",$JOB),PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG,^TMP($JOB,"PSOFLPO")
+9 ;*334 ADDED KILLS
KILL PPL,PPL1,PSOQFLAG
+10 ;*454 added kill
KILL ^XTMP("PSORRX1",$JOB),PSORCNT
+11 QUIT
ELIG ; shows eligibility and disabilities
+1 DO ELIG^VADPT
WRITE !,"Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
SET N=0
FOR
SET N=$ORDER(VAEL(1,N))
if 'N
QUIT
WRITE !,?10,$PIECE(VAEL(1,N),"^",2)
+2 WRITE !,"Disabilities: "
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+3 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET PSCNT=$PIECE(I1,"^",2)
+4 if $LENGTH(PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3)
WRITE !,?15
+5 WRITE $SELECT($GET(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_"), "
End DoDot:1
+6 KILL N
+7 QUIT
PROFILE ;
+1 SET (PSORX("REFILL"),PSORX("RENEW"))=0
SET PSOX=""
DO ^PSOBUILD
+2 IF '$GET(PSOSD)
WRITE !,"This patient has no prescriptions"
if '$DATA(DFN)
SET DFN=PSODFN
DO GMRA^PSODEM
GOTO PROFILEX
+3 SET (PSODRG,PSOX)=""
FOR
SET PSODRG=$ORDER(PSOSD(PSODRG))
if PSODRG=""
QUIT
FOR
SET PSOX=$ORDER(PSOSD(PSODRG,PSOX))
if PSOX=""
QUIT
if $PIECE(PSOSD(PSODRG,PSOX),"^",3)=""
SET PSORX("RENEW")=1
if $PIECE(PSOSD(PSODRG,PSOX),"^",4)=""
SET PSORX("REFILL")=1
+4 KILL PSOX
PROFILEX QUIT
+1 ;
MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
+1 ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
IF $PIECE($GET(^PS(59,PSOSITE,"STALK")),"^")=""
QUIT
+2 NEW MAIL
+3 SET MAIL=$GET(^PS(55,PSODFN,0))
IF $PIECE(MAIL,"^",3)>1
QUIT
MAILP WRITE !!,"REMINDER: CMOP does not fill ScripTalk prescriptions. Please select mail"
+1 WRITE !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
+2 READ !,"MAIL: ",MAIL:120
+3 IF MAIL?1"^".E
QUIT
+4 IF MAIL<2!(MAIL>4)
WRITE !,"INVALID MAIL SETTING - ENTER 2,3, OR 4"
GOTO MAILP
+5 WRITE " ",$SELECT(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
+6 SET $PIECE(^PS(55,PSODFN,0),"^",3)=MAIL
+7 QUIT
REMOTE ;
+1 IF $TEXT(HAVEHDR^ORRDI1)']""
QUIT
+2 IF '$$HAVEHDR^ORRDI1
QUIT
+3 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+4 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
WRITE !!,"Remote data not available - Only local order checks processed.",!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
QUIT
+5 QUIT
PAUSE ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
+1 NEW DA,PSOSTA
+2 IF '$GET(PSODFN)
QUIT
+3 SET DA=PSODFN
SET PSOSTA=$GET(^PS(55,PSODFN,"PS"))
+4 IF $GET(XQY0)["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS")
IF PSOSTA]""
Begin DoDot:1
+5 DO ELIG^VADPT
WRITE !,"Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
+6 SET N=0
FOR
SET N=$ORDER(VAEL(1,N))
if 'N
QUIT
WRITE !,?10,$PIECE(VAEL(1,N),"^",2)
+7 SET DIC("A")="RX PATIENT STATUS: "
SET DIC("B")=PSOSTA
SET DIC(0)="QEAMZ"
SET DIC=53
DO ^DIC
KILL DIC
+8 IF +Y>0
IF +Y'=PSOSTA
SET DIE="^PS(55,"
SET DR="3////"_+Y
DO ^DIE
End DoDot:1
+9 QUIT
