Routine: PSSDEE

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

LONG ;EP -

 S:PSSNEW=1 $P(^PSDRUG(DA,999999935),U,2)=$P(^PSDRUG(DA,0),U)

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

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

CK D DSPY^PSSDEE1 S FLGNDF=0

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

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)

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

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

DFNULL S OLDDF="",ZAPFLG=1

ZAPIT I $D(ZAPFLG),ZAPFLG=1,FLGNDF=1,OLDDF'=NEWDF D CKIV^PSSDEE1

APP W !!,"MARK THIS DRUG AND EDIT IT FOR: " D CHOOSE

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

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

BRANCH1 I FLAG,PSSANS["A" D OP,UD,IV,WS,DACCT,CS,NVM

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

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

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

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

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

WS I FLG4 W !,"** You are NOW editing WARD STOCK fields. **" S DIE="^PSDRUG(",DR="300;301;302" D ^DIE

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

CS I FLG6 W !,"** You are NOW Marking/Unmarking for CONTROLLED SUBS. **" S PSIUDA=DA,PSIUX="N^Controlled Substances" D ^PSSGIU

NVM I FLG7 W !,"** You are NOW Marking/Unmarking for NON-VA MEDS. **" S PSIUDA=DA,PSIUX="X^Non-VA Med" D ^PSSGIU

 ;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

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

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

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

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

CLOZ Q:NFLAG  Q:$D(DTOUT)  Q:$D(DIRUT)  Q:$D(DUOUT)  W !,"** You are NOW editing CLOZAPINE fields. **" D ^PSSCLDRG

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

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"

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.",!

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

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

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")

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

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

MFDD I $D(^PSDRUG(PSSDD,2)) S PSSOR=$P(^PSDRUG(PSSDD,2),"^",1) I PSSOR]"" D EN^PSSPOIDT(PSSOR),EN2^PSSHL1(PSSOR,"MUP")

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

OPEI1 ;

 S DIE="^PSDRUG(",DR="28",DA=DISPDRG

 D ^DIE

DEA ;

 I $P($G(^PSDRUG(DISPDRG,3)),"^")=1,($P(^PSDRUG(DISPDRG,0),"^",3)[1!($P(^(0),"^",3)[2)) D DSH

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

 ;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

PSSDEE.m