PSSDEE ;BIR/WRT-MASTER DRUG ENTER/EDIT ROUTINE ;25-Mar-2016 12:59;DU
;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61,1013,82,90,110,1015,1016,1017,1021**;9/30/97;Build 14
;
;Reference to ^PS(59 supported by DBIA #1976
;Reference to REACT1^PSNOUT supported by DBIA #2080
;Reference to $$UP^XLFSTR(X) supported by DBIA #10104
;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
;
; Modified - IHS/MSC/MGH - 02/08/2012 - Line DONE+1
; IHS/MSC/WPB - 03/20/2012 - Line ASK+3, CHOOSE+7, CHECK+12,BRANCH+2,COMPD
; IHS/MSC/PB - 10/02/2012 - Line tag COMPND changed to also mark the drug as compounded
; IHS/MSC/MGH - 10/24/2012 - Line tag VANDC added
; IHS/MSC/MGH - 08/05/2013 - Line tag RXNORM added
; Line ONE+2
; IHS/MSC/PLS - 03/25/2016 - Line ASK+7
BEGIN S PSSFLAG=0 D ^PSSDEE2 S PSSZ=1 F PSSXX=1:1 K DA D ASK Q:PSSFLAG
DONE D ^PSSDEE2 K PSSFLAG Q
;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
ASK ;FIND DRUG
;W ! S DIC="^PSDRUG(",DIC(0)="QEALMNTV",DLAYGO=50,DIC("T")="" D ^DIC K DIC I Y<0 S PSSFLAG=1 Q
W ! S DIC="^PSDRUG(",DIC(0)="QEALMNTV",D="BCAP",DLAYGO=50,DIC("T")="" D IX^DIC K DIC,D I Y<0 S PSSFLAG=1 Q
;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
;S (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI)=0 K ^TMP($J,"ADD"),^TMP($J,"SOL")
S (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLG8,FLAG,FLGKY,FLGOI)=0 K ^TMP($J,"ADD"),^TMP($J,"SOL")
S DA=+Y,DISPDRG=DA L +^PSDRUG(DISPDRG):0 I '$T W !,$C(7),"Another person is editing this one." Q
;IHS/MSC/PLS - 03/25/2016
;S PSSHUIDG=1,PSSNEW=$P(Y,"^",3) D USE,NOPE,COMMON,DEA,MF K PSSHUIDG
S PSSHUIDG=1,PSSNEW=$P(Y,"^",3) D LONG,USE,NOPE,COMMON,DEA,MF K PSSHUIDG
; if any outpatient site has a dispense machine running HL7 V.2.4, then
; run the new routine and create message
N XX,DNSNAM,DNSPORT,DVER,DMFU S XX=""
F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D
.S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2)
.S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007)
.D:DVER="2.4"&(DNSNAM'="")&(DMFU="YES") DRG^PSSDGUPD(DISPDRG,PSSNEW,DNSNAM,DNSPORT)
D DRG^PSSHUIDG(DISPDRG,PSSNEW) L -^PSDRUG(DISPDRG) K FLG3,PSSNEW
Q
LONG ;EP -
S:PSSNEW=1 $P(^PSDRUG(DA,999999935),U,2)=$P(^PSDRUG(DA,0),U)
Q
COMMON S DIE="^PSDRUG(",DR="[PSSCOMMON]" D ^DIE Q:$D(Y)!($D(DTOUT)) W:'$D(Y) !,"PRICE PER DISPENSE UNIT: " S:'$D(^PSDRUG(DA,660)) $P(^PSDRUG(DA,660),"^",6)="" W:'$D(Y) $P(^PSDRUG(DA,660),"^",6)
D DEA,CK,ASKND,OIKILL^PSSDEE1,COMMON1
Q
COMMON1 W !,"Just a reminder...you are editing ",$P(^PSDRUG(DISPDRG,0),"^"),"." S (PSSVVDA,DA)=DISPDRG D DOSN^PSSDOS S DA=PSSVVDA K PSSVVDA D USE,APP,ORDITM^PSSDEE1
Q
CK D DSPY^PSSDEE1 S FLGNDF=0
Q
ASKND S %=-1 I $D(^XUSEC("PSNMGR",DUZ)) D MESSAGE^PSSDEE1 W !!,"Do you wish to match/rematch to NATIONAL DRUG file" S %=1 S:FLGMTH=1 %=2 D YN^DICN
I %=0 W !,"If you answer ""yes"", you will attempt to match to NDF." G ASKND
I %=2 K X,Y Q
I %<0 K X,Y Q
I %=1 D RSET^PSSDEE1,EN1^PSSUTIL(DISPDRG,1) S X="PSNOUT" X ^%ZOSF("TEST") I D REACT1^PSNOUT S DA=DISPDRG I $D(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)]"" D ONE
Q
ONE S PSNP=$G(^PSDRUG(DA,"I")) I PSNP,PSNP<DT Q
W !,"You have just VERIFIED this match and MERGED the entry." D CKDF D EN2^PSSUTIL(DISPDRG,1) S:'$D(OLDDF) OLDDF="" I OLDDF'=NEWDF S FLGNDF=1 D WR
;IHS/MSC/MGH Patch 1017
D SQUERY^APSPRCUI(DA)
Q
CKDF S NWND=^PSDRUG(DA,"ND"),NWPC1=$P(NWND,"^",1),NWPC3=$P(NWND,"^",3),DA=NWPC1,K=NWPC3 S X=$$PSJDF^PSNAPIS(DA,K) S NEWDF=$P(X,"^",2),DA=DISPDRG
N PSSK D PKIND^PSSDDUT2
Q
NOPE S ZAPFLG=0 I '$D(^PSDRUG(DA,"ND")),$D(^PSDRUG(DA,2)),$P(^PSDRUG(DA,2),"^",1)']"" D DFNULL
I '$D(^PSDRUG(DA,"ND")),'$D(^PSDRUG(DA,2)) D DFNULL
I $D(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)']"",$D(^PSDRUG(DA,2)),$P(^PSDRUG(DA,2),"^",1)']"" D DFNULL
Q
DFNULL S OLDDF="",ZAPFLG=1
Q
ZAPIT I $D(ZAPFLG),ZAPFLG=1,FLGNDF=1,OLDDF'=NEWDF D CKIV^PSSDEE1
Q
APP W !!,"MARK THIS DRUG AND EDIT IT FOR: " D CHOOSE
Q
CHOOSE I $D(^XUSEC("PSORPH",DUZ))!($D(^XUSEC("PSXCMOPMGR",DUZ))) W !,"O - Outpatient" S FLG1=1
I $D(^XUSEC("PSJU MGR",DUZ)) W !,"U - Unit Dose" S FLG2=1
I $D(^XUSEC("PSJI MGR",DUZ)) W !,"I - IV" S FLG3=1
I $D(^XUSEC("PSGWMGR",DUZ)) W !,"W - Ward Stock" S FLG4=1
I $D(^XUSEC("PSAMGR",DUZ))!($D(^XUSEC("PSA ORDERS",DUZ))) W !,"D - Drug Accountability" S FLG5=1
I $D(^XUSEC("PSDMGR",DUZ)) W !,"C - Controlled Substances" S FLG6=1
I $D(^XUSEC("PSORPH",DUZ)) W !,"X - Non-VA Med" S FLG7=1
;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
S FLG8=1 W !,"Z - Compounding"
I FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG8 S FLAG=1
I FLAG W !,"A - ALL"
W !
I 'FLG1,'FLG2,'FLG3,'FLG4,'FLG5,'FLG6,'FLG7 W !,"You do not have the proper keys to continue. Sorry, this concludes your editing session.",! S FLGKY=1 K DIRUT,X Q
I FLGKY'=1 D
. K DIR S DIR(0)="FO^1:30"
. S DIR("A")="Enter your choice(s) separated by commas "
. F D ^DIR Q:$$CHECK($$UP^XLFSTR(X))
. S PSSANS=X,PSSANS=$$UP^XLFSTR(PSSANS) D BRANCH,BRANCH1
Q
;
CHECK(X) ; Validates Application Use response
N CHECK,I,C
S CHECK=1 I X=""!(Y["^")!($D(DIRUT)) Q CHECK
F I=1:1:$L(X,",") D
. S C=$P(X,",",I) W !?43,C," - "
. I C="O",FLG1 W "Outpatient" Q
. I C="U",FLG2 W "Unit Dose" Q
. I C="I",FLG3 W "IV" Q
. I C="W",FLG4 W "Ward Stock" Q
. I C="D",FLG5 W "Drug Accountability" Q
. I C="C",FLG6 W "Controlled Substances" Q
. I C="X",FLG7 W "Non-VA Med" Q
.;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
. I C="Z",FLG8 W "Compounding" Q
. W "Invalid Entry",$C(7) S CHECK=0
Q CHECK
BRANCH D:PSSANS["O" OP D:PSSANS["U" UD D:PSSANS["I" IV D:PSSANS["W" WS
D:PSSANS["D" DACCT D:PSSANS["C" CS D:PSSANS["X" NVM
;IHS/MSC/WPB next line added to direct processing to mark a compounded product 3/8/2012
D:PSSANS["Z" COMPND
Q
BRANCH1 I FLAG,PSSANS["A" D OP,UD,IV,WS,DACCT,CS,NVM
Q
OP I FLG1 D
. W !,"** You are NOW editing OUTPATIENT fields. **"
. S PSIUDA=DA,PSIUX="O^Outpatient Pharmacy" D ^PSSGIU
. I %=1 D
. . S DIE="^PSDRUG(",DR="[PSSOP]" D ^DIE K DIR D OPEI,ASKCMOP
. . S X="PSOCLO1" X ^%ZOSF("TEST") I D ASKCLOZ S FLGOI=1
I FLG1 D CKCMOP
Q
CKCMOP I $P($G(^PSDRUG(DISPDRG,2)),"^",3)'["O" S:$D(^PSDRUG(DISPDRG,3)) $P(^PSDRUG(DISPDRG,3),"^",1)=0 K:$D(^PSDRUG("AQ",DISPDRG)) ^PSDRUG("AQ",DISPDRG) S DA=DISPDRG D ^PSSREF
Q
UD I FLG2 W !,"** You are NOW editing UNIT DOSE fields. **" S PSIUDA=DA,PSIUX="U^Unit Dose" D ^PSSGIU I %=1 S DIE="^PSDRUG(",DR="62.05;212.2" D ^DIE S DIE="^PSDRUG(",DR="212",DR(2,50.0212)=".01;1" D ^DIE S FLGOI=1
Q
IV I FLG3 W !,"** You are NOW editing IV fields. **" S (PSIUDA,PSSDA)=DA,PSIUX="I^IV" D ^PSSGIU I %=1 D IV1 S FLGOI=1
Q
IV1 K PSSIVOUT ;This variable controls the selection process loop.
W !,"Edit Additives or Solutions: " K DIR S DIR(0)="SO^A:ADDITIVES;S:SOLUTIONS;" D ^DIR Q:$D(DIRUT) S PSSASK=Y(0) D:PSSASK="ADDITIVES" ENA^PSSVIDRG D:PSSASK="SOLUTIONS" ENS^PSSVIDRG I '$D(PSSIVOUT) G IV1
K PSSIVOUT
Q
WS I FLG4 W !,"** You are NOW editing WARD STOCK fields. **" S DIE="^PSDRUG(",DR="300;301;302" D ^DIE
Q
DACCT I FLG5 W !,"** You are NOW editing DRUG ACCOUNTABILITY fields. **" S DIE="^PSDRUG(",DR="441" D ^DIE S DIE="^PSDRUG(",DR="9",DR(2,50.1)="1;2;400;401;402;403;404;405" D ^DIE
Q
CS I FLG6 W !,"** You are NOW Marking/Unmarking for CONTROLLED SUBS. **" S PSIUDA=DA,PSIUX="N^Controlled Substances" D ^PSSGIU
Q
NVM I FLG7 W !,"** You are NOW Marking/Unmarking for NON-VA MEDS. **" S PSIUDA=DA,PSIUX="X^Non-VA Med" D ^PSSGIU
Q
;IHS/MSC/WPB Line tag COMPND added to mark an entry as compounded and to add the compounding ingredients 3/8/2012
;IHS/MSC/PB - Line tag COMPND changed to call PSSGIU to mark the drug as a compounded drug 10/3/12
;COMPND I FLG8 W !,"** You are NOW adding ingredients to this product for compounding. **",! S PSIUDA=DA D COMPND^PSSGIU
COMPND I FLG8 W !,"** You are NOW adding ingredients to this product for compounding. **",! S (SPSIUDA,PSIUDA)=DA,PSIUX="Z^Compounded Drug" D:$P($G(^PSDRUG(5182,2)),"^",3)'["Z" ^PSSGIU S PSIUDA=SPSIUDA D COMPND^PSSGIU
Q
ASKCMOP I $D(^XUSEC("PSXCMOPMGR",DUZ)) W !!,"Do you wish to mark to transmit to CMOP? " K DIR S DIR(0)="Y",DIR("?")="If you answer ""yes"", you will attempt to mark this drug to transmit to CMOP."
D ^DIR I "Nn"[X K X,Y,DIRUT Q
I "Yy"[X S PSXFL=0 D TEXT^PSSMARK H 7 N PSXUDA S (PSXUM,PSXUDA)=DA,PSXLOC=$P(^PSDRUG(DA,0),"^"),PSXGOOD=0,PSXF=0,PSXBT=0 D BLD^PSSMARK,PICK2^PSSMARK S DA=PSXUDA
Q
ASKCLOZ W !!,"Do you wish to mark/unmark as a LAB MONITOR or CLOZAPINE DRUG? " K DIR S DIR(0)="Y",DIR("?")="If you answer ""yes"", you will have the opportunity to edit LAB MONITOR or CLOZAPINE fields."
D ^DIR I "Nn"[X K X,Y,DIRUT Q
I "Yy"[X S NFLAG=0 D MONCLOZ
Q
MONCLOZ K PSSAST D FLASH W !,"Mark/Unmark for Lab Monitor or Clozapine: " K DIR S DIR(0)="S^L:LAB MONITOR;C:CLOZAPINE;" D ^DIR Q:$D(DIRUT) S PSSAST=Y(0) D:PSSAST="LAB MONITOR" ^PSSLAB D:PSSAST="CLOZAPINE" CLOZ
Q
FLASH K LMFLAG,CLFALG,WHICH S WHICH=$P($G(^PSDRUG(DISPDRG,"CLOZ1")),"^"),LMFLAG=0,CLFLAG=0
I WHICH="PSOCLO1" S CLFLAG=1
I WHICH'="PSOCLO1" S:WHICH'="" LMFLAG=1
Q
CLOZ Q:NFLAG Q:$D(DTOUT) Q:$D(DIRUT) Q:$D(DUOUT) W !,"** You are NOW editing CLOZAPINE fields. **" D ^PSSCLDRG
Q
USE K PACK S PACK="" S:$P($G(^PSDRUG(DISPDRG,"PSG")),"^",2)]"" PACK="W" I $D(^PSDRUG(DISPDRG,2)) S PACK=PACK_$P(^PSDRUG(DISPDRG,2),"^",3)
I PACK'="" D
.W $C(7) N XX W !! F XX=1:1:79 W "*"
.W !,"This entry is marked for the following PHARMACY packages: "
.D USE1
Q
USE1 W:PACK["O" !," Outpatient" W:PACK["U" !," Unit Dose" W:PACK["I" !," IV"
W:PACK["W" !," Ward Stock" W:PACK["D" !," Drug Accountability"
W:PACK["N" !," Controlled Substances" W:PACK["X" !," Non-VA Med"
;IHS/MSC/PB - modified to show the drug is marked as a compounded drug 9/3/12
W:PACK["Z" !," Compounded Drug"
W:'$D(PACK) !," NONE"
I PACK'["O",PACK'["U",PACK'["I",PACK'["W",PACK'["D",PACK'["N",PACK'["X" W !," NONE"
Q
WR I ^XMB("NETNAME")'["CMOP-" W:OLDDF'="" !,"The dosage form has changed from "_OLDDF_" to "_NEWDF_" due to",!,"matching/rematching to NDF.",!,"You will need to rematch to Orderable Item.",!
Q
PRIMDRG I $D(^PS(59.7,1,20)),$P(^PS(59.7,1,20),"^",1)=4!($P(^PS(59.7,1,20),"^",1)=4.5) I $D(^PSDRUG(DISPDRG,2)) S VAR=$P(^PSDRUG(DISPDRG,2),"^",3) I VAR["U"!(VAR["I") D PRIM1
Q
PRIM1 W !!,"You need to match this drug to ""PRIMARY DRUG"" file as well.",! S DIE="^PSDRUG(",DR="64",DA=DISPDRG D ^DIE K VAR
Q
MF I $P($G(^PS(59.7,1,80)),"^",2)>1 I $D(^PSDRUG(DISPDRG,2)) S PSSOR=$P(^PSDRUG(DISPDRG,2),"^",1) I PSSOR]"" D EN^PSSPOIDT(PSSOR),EN2^PSSHL1(PSSOR,"MUP")
Q
MFA I $P($G(^PS(59.7,1,80)),"^",2)>1 S PSSOR=$P(^PS(52.6,ENTRY,0),"^",11),PSSDD=$P(^PS(52.6,ENTRY,0),"^",2) I PSSOR]"" D EN^PSSPOIDT(PSSOR),EN2^PSSHL1(PSSOR,"MUP") D MFDD
Q
MFS I $P($G(^PS(59.7,1,80)),"^",2)>1 S PSSOR=$P(^PS(52.7,ENTRY,0),"^",11),PSSDD=$P(^PS(52.7,ENTRY,0),"^",2) I PSSOR]"" D EN^PSSPOIDT(PSSOR),EN2^PSSHL1(PSSOR,"MUP") D MFDD
Q
MFDD I $D(^PSDRUG(PSSDD,2)) S PSSOR=$P(^PSDRUG(PSSDD,2),"^",1) I PSSOR]"" D EN^PSSPOIDT(PSSOR),EN2^PSSHL1(PSSOR,"MUP")
Q
OPEI N PSDRUGND
S PSDRUGND=$G(^PSDRUG(DISPDRG,"ND"))
I PSDRUGND']"" Q
I $P(PSDRUGND,"^",3)']"",$P(PSDRUGND,"^",10)']"" Q
I $P(PSDRUGND,"^",10)]"" G OPEI1
I $P($G(^PSNDF(50.68,$P(PSDRUGND,"^",3),1)),"^",2)]"" G OPEI1
Q
OPEI1 ;
S DIE="^PSDRUG(",DR="28",DA=DISPDRG
D ^DIE
Q
DEA ;
I $P($G(^PSDRUG(DISPDRG,3)),"^")=1,($P(^PSDRUG(DISPDRG,0),"^",3)[1!($P(^(0),"^",3)[2)) D DSH
Q
DSH W !!,"****************************************************************************"
W !,"This entry contains a ""1"" or a ""2"" in the ""DEA, SPECIAL HDLG""",!,"field, therefore this item has been UNMARKED for CMOP transmission."
W !,"****************************************************************************",! S $P(^PSDRUG(DISPDRG,3),"^")=0 K ^PSDRUG("AQ",DISPDRG) S DA=DISPDRG N % D ^PSSREF
Q
;IHS/MSC/MGH Patch 1017 Display the RxNorm code
NORM(DA) Q $$GET1^DIQ(50,DA,9999999.27)
;
VANDC(DA) ;Find product NDC code
N ND,NDC
S NDC=""
S ND=$G(^PSDRUG(DA,"ND"))
I +ND,+$P(ND,"^",3),+$P($G(^PSNDF(50.68,+$P(ND,"^",3),1)),"^",7) D
.S NDC=$P($G(^PSNDF(50.68,+$P(ND,"^",3),1)),"^",7)
.I $L(NDC)=12 S NDC=$E(NDC,2,12)
Q NDC
PSSDEE ;BIR/WRT-MASTER DRUG ENTER/EDIT ROUTINE ;25-Mar-2016 12:59;DU
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61,1013,82,90,110,1015,1016,1017,1021**;9/30/97;Build 14
+2 ;
+3 ;Reference to ^PS(59 supported by DBIA #1976
+4 ;Reference to REACT1^PSNOUT supported by DBIA #2080
+5 ;Reference to $$UP^XLFSTR(X) supported by DBIA #10104
+6 ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
+7 ;
+8 ; Modified - IHS/MSC/MGH - 02/08/2012 - Line DONE+1
+9 ; IHS/MSC/WPB - 03/20/2012 - Line ASK+3, CHOOSE+7, CHECK+12,BRANCH+2,COMPD
+10 ; IHS/MSC/PB - 10/02/2012 - Line tag COMPND changed to also mark the drug as compounded
+11 ; IHS/MSC/MGH - 10/24/2012 - Line tag VANDC added
+12 ; IHS/MSC/MGH - 08/05/2013 - Line tag RXNORM added
+13 ; Line ONE+2
+14 ; IHS/MSC/PLS - 03/25/2016 - Line ASK+7
BEGIN SET PSSFLAG=0
DO ^PSSDEE2
SET PSSZ=1
FOR PSSXX=1:1
KILL DA
DO ASK
IF PSSFLAG
QUIT
DONE DO ^PSSDEE2
KILL PSSFLAG
QUIT
+1 ;IHS/MSC/MGH changed for mixed case lookup, uses new cross-reference
ASK ;FIND DRUG
+1 ;W ! S DIC="^PSDRUG(",DIC(0)="QEALMNTV",DLAYGO=50,DIC("T")="" D ^DIC K DIC I Y<0 S PSSFLAG=1 Q
+2 WRITE !
SET DIC="^PSDRUG("
SET DIC(0)="QEALMNTV"
SET D="BCAP"
SET DLAYGO=50
SET DIC("T")=""
DO IX^DIC
KILL DIC,D
IF Y<0
SET PSSFLAG=1
QUIT
+3 ;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
+4 ;S (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI)=0 K ^TMP($J,"ADD"),^TMP($J,"SOL")
+5 SET (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLG8,FLAG,FLGKY,FLGOI)=0
KILL ^TMP($JOB,"ADD"),^TMP($JOB,"SOL")
+6 SET DA=+Y
SET DISPDRG=DA
LOCK +^PSDRUG(DISPDRG):0
IF '$TEST
WRITE !,$CHAR(7),"Another person is editing this one."
QUIT
+7 ;IHS/MSC/PLS - 03/25/2016
+8 ;S PSSHUIDG=1,PSSNEW=$P(Y,"^",3) D USE,NOPE,COMMON,DEA,MF K PSSHUIDG
+9 SET PSSHUIDG=1
SET PSSNEW=$PIECE(Y,"^",3)
DO LONG
DO USE
DO NOPE
DO COMMON
DO DEA
DO MF
KILL PSSHUIDG
+10 ; if any outpatient site has a dispense machine running HL7 V.2.4, then
+11 ; run the new routine and create message
+12 NEW XX,DNSNAM,DNSPORT,DVER,DMFU
SET XX=""
+13 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
IF 'XX
QUIT
Begin DoDot:1
+14 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+15 SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
+16 IF DVER="2.4"&(DNSNAM'="")&(DMFU="YES")
DO DRG^PSSDGUPD(DISPDRG,PSSNEW,DNSNAM,DNSPORT)
End DoDot:1
+17 DO DRG^PSSHUIDG(DISPDRG,PSSNEW)
LOCK -^PSDRUG(DISPDRG)
KILL FLG3,PSSNEW
+18 QUIT
LONG ;EP -
+1 IF PSSNEW=1
SET $PIECE(^PSDRUG(DA,999999935),U,2)=$PIECE(^PSDRUG(DA,0),U)
+2 QUIT
COMMON SET DIE="^PSDRUG("
SET DR="[PSSCOMMON]"
DO ^DIE
IF $DATA(Y)!($DATA(DTOUT))
QUIT
IF '$DATA(Y)
WRITE !,"PRICE PER DISPENSE UNIT: "
IF '$DATA(^PSDRUG(DA,660))
SET $PIECE(^PSDRUG(DA,660),"^",6)=""
IF '$DATA(Y)
WRITE $PIECE(^PSDRUG(DA,660),"^",6)
+1 DO DEA
DO CK
DO ASKND
DO OIKILL^PSSDEE1
DO COMMON1
+2 QUIT
COMMON1 WRITE !,"Just a reminder...you are editing ",$PIECE(^PSDRUG(DISPDRG,0),"^"),"."
SET (PSSVVDA,DA)=DISPDRG
DO DOSN^PSSDOS
SET DA=PSSVVDA
KILL PSSVVDA
DO USE
DO APP
DO ORDITM^PSSDEE1
+1 QUIT
CK DO DSPY^PSSDEE1
SET FLGNDF=0
+1 QUIT
ASKND SET %=-1
IF $DATA(^XUSEC("PSNMGR",DUZ))
DO MESSAGE^PSSDEE1
WRITE !!,"Do you wish to match/rematch to NATIONAL DRUG file"
SET %=1
IF FLGMTH=1
SET %=2
DO YN^DICN
+1 IF %=0
WRITE !,"If you answer ""yes"", you will attempt to match to NDF."
GOTO ASKND
+2 IF %=2
KILL X,Y
QUIT
+3 IF %<0
KILL X,Y
QUIT
+4 IF %=1
DO RSET^PSSDEE1
DO EN1^PSSUTIL(DISPDRG,1)
SET X="PSNOUT"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO REACT1^PSNOUT
SET DA=DISPDRG
IF $DATA(^PSDRUG(DA,"ND"))
IF $PIECE(^PSDRUG(DA,"ND"),"^",2)]""
DO ONE
+5 QUIT
ONE SET PSNP=$GET(^PSDRUG(DA,"I"))
IF PSNP
IF PSNP<DT
QUIT
+1 WRITE !,"You have just VERIFIED this match and MERGED the entry."
DO CKDF
DO EN2^PSSUTIL(DISPDRG,1)
IF '$DATA(OLDDF)
SET OLDDF=""
IF OLDDF'=NEWDF
SET FLGNDF=1
DO WR
+2 ;IHS/MSC/MGH Patch 1017
+3 DO SQUERY^APSPRCUI(DA)
+4 QUIT
CKDF SET NWND=^PSDRUG(DA,"ND")
SET NWPC1=$PIECE(NWND,"^",1)
SET NWPC3=$PIECE(NWND,"^",3)
SET DA=NWPC1
SET K=NWPC3
SET X=$$PSJDF^PSNAPIS(DA,K)
SET NEWDF=$PIECE(X,"^",2)
SET DA=DISPDRG
+1 NEW PSSK
DO PKIND^PSSDDUT2
+2 QUIT
NOPE SET ZAPFLG=0
IF '$DATA(^PSDRUG(DA,"ND"))
IF $DATA(^PSDRUG(DA,2))
IF $PIECE(^PSDRUG(DA,2),"^",1)']""
DO DFNULL
+1 IF '$DATA(^PSDRUG(DA,"ND"))
IF '$DATA(^PSDRUG(DA,2))
DO DFNULL
+2 IF $DATA(^PSDRUG(DA,"ND"))
IF $PIECE(^PSDRUG(DA,"ND"),"^",2)']""
IF $DATA(^PSDRUG(DA,2))
IF $PIECE(^PSDRUG(DA,2),"^",1)']""
DO DFNULL
+3 QUIT
DFNULL SET OLDDF=""
SET ZAPFLG=1
+1 QUIT
ZAPIT IF $DATA(ZAPFLG)
IF ZAPFLG=1
IF FLGNDF=1
IF OLDDF'=NEWDF
DO CKIV^PSSDEE1
+1 QUIT
APP WRITE !!,"MARK THIS DRUG AND EDIT IT FOR: "
DO CHOOSE
+1 QUIT
CHOOSE IF $DATA(^XUSEC("PSORPH",DUZ))!($DATA(^XUSEC("PSXCMOPMGR",DUZ)))
WRITE !,"O - Outpatient"
SET FLG1=1
+1 IF $DATA(^XUSEC("PSJU MGR",DUZ))
WRITE !,"U - Unit Dose"
SET FLG2=1
+2 IF $DATA(^XUSEC("PSJI MGR",DUZ))
WRITE !,"I - IV"
SET FLG3=1
+3 IF $DATA(^XUSEC("PSGWMGR",DUZ))
WRITE !,"W - Ward Stock"
SET FLG4=1
+4 IF $DATA(^XUSEC("PSAMGR",DUZ))!($DATA(^XUSEC("PSA ORDERS",DUZ)))
WRITE !,"D - Drug Accountability"
SET FLG5=1
+5 IF $DATA(^XUSEC("PSDMGR",DUZ))
WRITE !,"C - Controlled Substances"
SET FLG6=1
+6 IF $DATA(^XUSEC("PSORPH",DUZ))
WRITE !,"X - Non-VA Med"
SET FLG7=1
+7 ;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
+8 SET FLG8=1
WRITE !,"Z - Compounding"
+9 IF FLG1
IF FLG2
IF FLG3
IF FLG4
IF FLG5
IF FLG6
IF FLG8
SET FLAG=1
+10 IF FLAG
WRITE !,"A - ALL"
+11 WRITE !
+12 IF 'FLG1
IF 'FLG2
IF 'FLG3
IF 'FLG4
IF 'FLG5
IF 'FLG6
IF 'FLG7
WRITE !,"You do not have the proper keys to continue. Sorry, this concludes your editing session.",!
SET FLGKY=1
KILL DIRUT,X
QUIT
+13 IF FLGKY'=1
Begin DoDot:1
+14 KILL DIR
SET DIR(0)="FO^1:30"
+15 SET DIR("A")="Enter your choice(s) separated by commas "
+16 FOR
DO ^DIR
IF $$CHECK($$UP^XLFSTR(X))
QUIT
+17 SET PSSANS=X
SET PSSANS=$$UP^XLFSTR(PSSANS)
DO BRANCH
DO BRANCH1
End DoDot:1
+18 QUIT
+19 ;
CHECK(X) ; Validates Application Use response
+1 NEW CHECK,I,C
+2 SET CHECK=1
IF X=""!(Y["^")!($DATA(DIRUT))
QUIT CHECK
+3 FOR I=1:1:$LENGTH(X,",")
Begin DoDot:1
+4 SET C=$PIECE(X,",",I)
WRITE !?43,C," - "
+5 IF C="O"
IF FLG1
WRITE "Outpatient"
QUIT
+6 IF C="U"
IF FLG2
WRITE "Unit Dose"
QUIT
+7 IF C="I"
IF FLG3
WRITE "IV"
QUIT
+8 IF C="W"
IF FLG4
WRITE "Ward Stock"
QUIT
+9 IF C="D"
IF FLG5
WRITE "Drug Accountability"
QUIT
+10 IF C="C"
IF FLG6
WRITE "Controlled Substances"
QUIT
+11 IF C="X"
IF FLG7
WRITE "Non-VA Med"
QUIT
+12 ;IHS/MSC/WPB changed to include a flag (FLG8) to designate adding or editing for a compounded product 3/8/2012
+13 IF C="Z"
IF FLG8
WRITE "Compounding"
QUIT
+14 WRITE "Invalid Entry",$CHAR(7)
SET CHECK=0
End DoDot:1
+15 QUIT CHECK
BRANCH IF PSSANS["O"
DO OP
IF PSSANS["U"
DO UD
IF PSSANS["I"
DO IV
IF PSSANS["W"
DO WS
+1 IF PSSANS["D"
DO DACCT
IF PSSANS["C"
DO CS
IF PSSANS["X"
DO NVM
+2 ;IHS/MSC/WPB next line added to direct processing to mark a compounded product 3/8/2012
+3 IF PSSANS["Z"
DO COMPND
+4 QUIT
BRANCH1 IF FLAG
IF PSSANS["A"
DO OP
DO UD
DO IV
DO WS
DO DACCT
DO CS
DO NVM
+1 QUIT
OP IF FLG1
Begin DoDot:1
+1 WRITE !,"** You are NOW editing OUTPATIENT fields. **"
+2 SET PSIUDA=DA
SET PSIUX="O^Outpatient Pharmacy"
DO ^PSSGIU
+3 IF %=1
Begin DoDot:2
+4 SET DIE="^PSDRUG("
SET DR="[PSSOP]"
DO ^DIE
KILL DIR
DO OPEI
DO ASKCMOP
+5 SET X="PSOCLO1"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO ASKCLOZ
SET FLGOI=1
End DoDot:2
End DoDot:1
+6 IF FLG1
DO CKCMOP
+7 QUIT
CKCMOP IF $PIECE($GET(^PSDRUG(DISPDRG,2)),"^",3)'["O"
IF $DATA(^PSDRUG(DISPDRG,3))
SET $PIECE(^PSDRUG(DISPDRG,3),"^",1)=0
IF $DATA(^PSDRUG("AQ",DISPDRG))
KILL ^PSDRUG("AQ",DISPDRG)
SET DA=DISPDRG
DO ^PSSREF
+1 QUIT
UD IF FLG2
WRITE !,"** You are NOW editing UNIT DOSE fields. **"
SET PSIUDA=DA
SET PSIUX="U^Unit Dose"
DO ^PSSGIU
IF %=1
SET DIE="^PSDRUG("
SET DR="62.05;212.2"
DO ^DIE
SET DIE="^PSDRUG("
SET DR="212"
SET DR(2,50.0212)=".01;1"
DO ^DIE
SET FLGOI=1
+1 QUIT
IV IF FLG3
WRITE !,"** You are NOW editing IV fields. **"
SET (PSIUDA,PSSDA)=DA
SET PSIUX="I^IV"
DO ^PSSGIU
IF %=1
DO IV1
SET FLGOI=1
+1 QUIT
IV1 ;This variable controls the selection process loop.
KILL PSSIVOUT
+1 WRITE !,"Edit Additives or Solutions: "
KILL DIR
SET DIR(0)="SO^A:ADDITIVES;S:SOLUTIONS;"
DO ^DIR
IF $DATA(DIRUT)
QUIT
SET PSSASK=Y(0)
IF PSSASK="ADDITIVES"
DO ENA^PSSVIDRG
IF PSSASK="SOLUTIONS"
DO ENS^PSSVIDRG
IF '$DATA(PSSIVOUT)
GOTO IV1
+2 KILL PSSIVOUT
+3 QUIT
WS IF FLG4
WRITE !,"** You are NOW editing WARD STOCK fields. **"
SET DIE="^PSDRUG("
SET DR="300;301;302"
DO ^DIE
+1 QUIT
DACCT IF FLG5
WRITE !,"** You are NOW editing DRUG ACCOUNTABILITY fields. **"
SET DIE="^PSDRUG("
SET DR="441"
DO ^DIE
SET DIE="^PSDRUG("
SET DR="9"
SET DR(2,50.1)="1;2;400;401;402;403;404;405"
DO ^DIE
+1 QUIT
CS IF FLG6
WRITE !,"** You are NOW Marking/Unmarking for CONTROLLED SUBS. **"
SET PSIUDA=DA
SET PSIUX="N^Controlled Substances"
DO ^PSSGIU
+1 QUIT
NVM IF FLG7
WRITE !,"** You are NOW Marking/Unmarking for NON-VA MEDS. **"
SET PSIUDA=DA
SET PSIUX="X^Non-VA Med"
DO ^PSSGIU
+1 QUIT
+2 ;IHS/MSC/WPB Line tag COMPND added to mark an entry as compounded and to add the compounding ingredients 3/8/2012
+3 ;IHS/MSC/PB - Line tag COMPND changed to call PSSGIU to mark the drug as a compounded drug 10/3/12
+4 ;COMPND I FLG8 W !,"** You are NOW adding ingredients to this product for compounding. **",! S PSIUDA=DA D COMPND^PSSGIU
COMPND IF FLG8
WRITE !,"** You are NOW adding ingredients to this product for compounding. **",!
SET (SPSIUDA,PSIUDA)=DA
SET PSIUX="Z^Compounded Drug"
IF $PIECE($GET(^PSDRUG(5182,2)),"^",3)'["Z"
DO ^PSSGIU
SET PSIUDA=SPSIUDA
DO COMPND^PSSGIU
+1 QUIT
ASKCMOP IF $DATA(^XUSEC("PSXCMOPMGR",DUZ))
WRITE !!,"Do you wish to mark to transmit to CMOP? "
KILL DIR
SET DIR(0)="Y"
SET DIR("?")="If you answer ""yes"", you will attempt to mark this drug to transmit to CMOP."
+1 DO ^DIR
IF "Nn"[X
KILL X,Y,DIRUT
QUIT
+2 IF "Yy"[X
SET PSXFL=0
DO TEXT^PSSMARK
HANG 7
NEW PSXUDA
SET (PSXUM,PSXUDA)=DA
SET PSXLOC=$PIECE(^PSDRUG(DA,0),"^")
SET PSXGOOD=0
SET PSXF=0
SET PSXBT=0
DO BLD^PSSMARK
DO PICK2^PSSMARK
SET DA=PSXUDA
+3 QUIT
ASKCLOZ WRITE !!,"Do you wish to mark/unmark as a LAB MONITOR or CLOZAPINE DRUG? "
KILL DIR
SET DIR(0)="Y"
SET DIR("?")="If you answer ""yes"", you will have the opportunity to edit LAB MONITOR or CLOZAPINE fields."
+1 DO ^DIR
IF "Nn"[X
KILL X,Y,DIRUT
QUIT
+2 IF "Yy"[X
SET NFLAG=0
DO MONCLOZ
+3 QUIT
MONCLOZ KILL PSSAST
DO FLASH
WRITE !,"Mark/Unmark for Lab Monitor or Clozapine: "
KILL DIR
SET DIR(0)="S^L:LAB MONITOR;C:CLOZAPINE;"
DO ^DIR
IF $DATA(DIRUT)
QUIT
SET PSSAST=Y(0)
IF PSSAST="LAB MONITOR"
DO ^PSSLAB
IF PSSAST="CLOZAPINE"
DO CLOZ
+1 QUIT
FLASH KILL LMFLAG,CLFALG,WHICH
SET WHICH=$PIECE($GET(^PSDRUG(DISPDRG,"CLOZ1")),"^")
SET LMFLAG=0
SET CLFLAG=0
+1 IF WHICH="PSOCLO1"
SET CLFLAG=1
+2 IF WHICH'="PSOCLO1"
IF WHICH'=""
SET LMFLAG=1
+3 QUIT
CLOZ IF NFLAG
QUIT
IF $DATA(DTOUT)
QUIT
IF $DATA(DIRUT)
QUIT
IF $DATA(DUOUT)
QUIT
WRITE !,"** You are NOW editing CLOZAPINE fields. **"
DO ^PSSCLDRG
+1 QUIT
USE KILL PACK
SET PACK=""
IF $PIECE($GET(^PSDRUG(DISPDRG,"PSG")),"^",2)]""
SET PACK="W"
IF $DATA(^PSDRUG(DISPDRG,2))
SET PACK=PACK_$PIECE(^PSDRUG(DISPDRG,2),"^",3)
+1 IF PACK'=""
Begin DoDot:1
+2 WRITE $CHAR(7)
NEW XX
WRITE !!
FOR XX=1:1:79
WRITE "*"
+3 WRITE !,"This entry is marked for the following PHARMACY packages: "
+4 DO USE1
End DoDot:1
+5 QUIT
USE1 IF PACK["O"
WRITE !," Outpatient"
IF PACK["U"
WRITE !," Unit Dose"
IF PACK["I"
WRITE !," IV"
+1 IF PACK["W"
WRITE !," Ward Stock"
IF PACK["D"
WRITE !," Drug Accountability"
+2 IF PACK["N"
WRITE !," Controlled Substances"
IF PACK["X"
WRITE !," Non-VA Med"
+3 ;IHS/MSC/PB - modified to show the drug is marked as a compounded drug 9/3/12
+4 IF PACK["Z"
WRITE !," Compounded Drug"
+5 IF '$DATA(PACK)
WRITE !," NONE"
+6 IF PACK'["O"
IF PACK'["U"
IF PACK'["I"
IF PACK'["W"
IF PACK'["D"
IF PACK'["N"
IF PACK'["X"
WRITE !," NONE"
+7 QUIT
WR IF ^XMB("NETNAME")'["CMOP-"
IF OLDDF'=""
WRITE !,"The dosage form has changed from "_OLDDF_" to "_NEWDF_" due to",!,"matching/rematching to NDF.",!,"You will need to rematch to Orderable Item.",!
+1 QUIT
PRIMDRG IF $DATA(^PS(59.7,1,20))
IF $PIECE(^PS(59.7,1,20),"^",1)=4!($PIECE(^PS(59.7,1,20),"^",1)=4.5)
IF $DATA(^PSDRUG(DISPDRG,2))
SET VAR=$PIECE(^PSDRUG(DISPDRG,2),"^",3)
IF VAR["U"!(VAR["I")
DO PRIM1
+1 QUIT
PRIM1 WRITE !!,"You need to match this drug to ""PRIMARY DRUG"" file as well.",!
SET DIE="^PSDRUG("
SET DR="64"
SET DA=DISPDRG
DO ^DIE
KILL VAR
+1 QUIT
MF IF $PIECE($GET(^PS(59.7,1,80)),"^",2)>1
IF $DATA(^PSDRUG(DISPDRG,2))
SET PSSOR=$PIECE(^PSDRUG(DISPDRG,2),"^",1)
IF PSSOR]""
DO EN^PSSPOIDT(PSSOR)
DO EN2^PSSHL1(PSSOR,"MUP")
+1 QUIT
MFA IF $PIECE($GET(^PS(59.7,1,80)),"^",2)>1
SET PSSOR=$PIECE(^PS(52.6,ENTRY,0),"^",11)
SET PSSDD=$PIECE(^PS(52.6,ENTRY,0),"^",2)
IF PSSOR]""
DO EN^PSSPOIDT(PSSOR)
DO EN2^PSSHL1(PSSOR,"MUP")
DO MFDD
+1 QUIT
MFS IF $PIECE($GET(^PS(59.7,1,80)),"^",2)>1
SET PSSOR=$PIECE(^PS(52.7,ENTRY,0),"^",11)
SET PSSDD=$PIECE(^PS(52.7,ENTRY,0),"^",2)
IF PSSOR]""
DO EN^PSSPOIDT(PSSOR)
DO EN2^PSSHL1(PSSOR,"MUP")
DO MFDD
+1 QUIT
MFDD IF $DATA(^PSDRUG(PSSDD,2))
SET PSSOR=$PIECE(^PSDRUG(PSSDD,2),"^",1)
IF PSSOR]""
DO EN^PSSPOIDT(PSSOR)
DO EN2^PSSHL1(PSSOR,"MUP")
+1 QUIT
OPEI NEW PSDRUGND
+1 SET PSDRUGND=$GET(^PSDRUG(DISPDRG,"ND"))
+2 IF PSDRUGND']""
QUIT
+3 IF $PIECE(PSDRUGND,"^",3)']""
IF $PIECE(PSDRUGND,"^",10)']""
QUIT
+4 IF $PIECE(PSDRUGND,"^",10)]""
GOTO OPEI1
+5 IF $PIECE($GET(^PSNDF(50.68,$PIECE(PSDRUGND,"^",3),1)),"^",2)]""
GOTO OPEI1
+6 QUIT
OPEI1 ;
+1 SET DIE="^PSDRUG("
SET DR="28"
SET DA=DISPDRG
+2 DO ^DIE
+3 QUIT
DEA ;
+1 IF $PIECE($GET(^PSDRUG(DISPDRG,3)),"^")=1
IF ($PIECE(^PSDRUG(DISPDRG,0),"^",3)[1!($PIECE(^(0),"^",3)[2))
DO DSH
+2 QUIT
DSH WRITE !!,"****************************************************************************"
+1 WRITE !,"This entry contains a ""1"" or a ""2"" in the ""DEA, SPECIAL HDLG""",!,"field, therefore this item has been UNMARKED for CMOP transmission."
+2 WRITE !,"****************************************************************************",!
SET $PIECE(^PSDRUG(DISPDRG,3),"^")=0
KILL ^PSDRUG("AQ",DISPDRG)
SET DA=DISPDRG
NEW %
DO ^PSSREF
+3 QUIT
+4 ;IHS/MSC/MGH Patch 1017 Display the RxNorm code
NORM(DA) QUIT $$GET1^DIQ(50,DA,9999999.27)
+1 ;
VANDC(DA) ;Find product NDC code
+1 NEW ND,NDC
+2 SET NDC=""
+3 SET ND=$GET(^PSDRUG(DA,"ND"))
+4 IF +ND
IF +$PIECE(ND,"^",3)
IF +$PIECE($GET(^PSNDF(50.68,+$PIECE(ND,"^",3),1)),"^",7)
Begin DoDot:1
+5 SET NDC=$PIECE($GET(^PSNDF(50.68,+$PIECE(ND,"^",3),1)),"^",7)
+6 IF $LENGTH(NDC)=12
SET NDC=$EXTRACT(NDC,2,12)
End DoDot:1
+7 QUIT NDC
