PSSDEE ;BIR/WRT - MASTER DRUG ENTER/EDIT ROUTINE ;Nov 27, 2018@10:03
;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61,82,90,110,155,156,180,193,200,207,195,227,220,214**;9/30/97;Build 43
;
;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
;Reference to PSNAPIS supported by DBIA #2531
;Reference to ^XMB("NETNAME" supported by DBIA #1131
;Reference to ^XUSEC supported by DIBA #10076
;Reference to FDR & FDT^PSNACT supported by DBIA #6754
;
BEGIN N PSSUPRAF,PSSTDRUG
S PSSFLAG=0 D ^PSSDEE2 S PSSZ=1 F PSSXX=1:1 K DA D ASK Q:PSSFLAG
DONE D ^PSSDEE2 K PSSFLAGK,PSSXX,DIE,DIR,CLFLAG,CLFALG,DISPDRG,DLAYGO,DR,ENTRY,FLAG,FLG1,FLG2,FLG4,FLG5,FLG6,FLG7,FLGKY,FLGMTH,FLGNDF,FLGOI,K,NEWDF
K NFLAG,NWND,NWPC1,NWPC2,NWPC3OLDDF,PSIUDA,PSIUX,PSNP,PSSANS,PSSASK,PSSDA,PSSDD,PSSFLAG,PSSOR,PSSZ,PSXBT,PSXF,PSXFL,PSXUM,PSXGOOD,PSXLOC,ZAPFLG
Q
ASK ;
W ! S DIC="^PSDRUG(",DIC(0)="QEALMNTV",DLAYGO=50,DIC("T")="",DIC("W")="S PSSTDRUG=Y D GETTIER^PSSDEE(PSSTDRUG)" D ^DIC K DIC I Y<0 S PSSFLAG=1 Q
N PSINACT S (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI,PSINACT)=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
D BEFORE^PSSDEEA($T(+0)) ; drug enter/edit auditing
I $G(^PSDRUG(DA,"I")) S PSINACT=$G(^PSDRUG(DA,"I")) I PSINACT,PSINACT<DT S PSINACT=1 ;;<<*180 - RJS
S PSSHUIDG=1,PSSNEW=$P(Y,"^",3) D USE,NOPE,COMMON,DEA,MF K PSSHUIDG,PSSUPRAF
; 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,PSSUPRA 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)
D AFTER^PSSDEEA($T(+0)) ; drug enter/edit auditing
S XX=$P($G(^PSDRUG(DISPDRG,2)),"^",3) I XX["U"!(XX["I") D S XX=""
.S XX=$$SNDHL7^PSSMSTR() D:XX
..Q:PSSNEW&'((XX=2)!(XX=3)) ;U=1,N=2,B=3
..Q:'PSSNEW&(XX=2) ;U=1,N=2,B=3
..N VAR
..I PSSNEW&((XX=2)!(XX=3)) S VAR="Would you like to send this new drug to PADE"
..E S VAR="Would you like to send a drug file update to PADE"
..W !!,"This drug is marked for either UD or IV use, and you have at least"
..W !,"one active Pharmacy Automated Dispensing Equipment (PADE)."
..K DIR,DIRUT,DUOUT,DTOUT
..S DIR(0)="Y",DIR("A")=VAR
..S DIR("?")="Enter Y for Yes or N for No." D ^DIR K DIR
..Q:'Y
..N PSSPADE S PSSPADE=1 S XX=""
..D ENP^PSSHLDFS(DISPDRG,$S(PSSNEW:"MAD",1:"MUP"))
D EPHARM^PSSBPSUT(DISPDRG)
K FLG3,PSSNEW
Q
;
COMMON ;
S DIE="^PSDRUG(",DR="[PSSCOMMON]"
D ^DIE
I $D(Y)!($D(DTOUT)) Q
I '$D(^PSDRUG(DA,660)) S $P(^PSDRUG(DA,660),"^",6)=""
I '$D(Y) W !,"PRICE PER DISPENSE UNIT: ",$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
S PSSUPRAF=%
I %=2 K X,Y Q
I %<0 K X,Y Q
I %=1 D ;;<<*180 - RJS
.D RSET^PSSDEE1
.I 'PSINACT D 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 ;;<< *180 - RJS
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
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
I FLG1,FLG2,FLG3,FLG4,FLG5,FLG6 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
. 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
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
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"[$E(X) K X,Y,DIRUT Q
I "Yy"[$E(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"[$E(X) K X,Y,DIRUT Q
I "Yy"[$E(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:$G(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"
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 ;
S DIE="^PSDRUG(",DR="28",DA=DISPDRG
D ^DIE
Q:'+$P($G(^PSDRUG(DA,6)),"^")
OPEI2 ; get external dispensing devices associated with the drug
W !!,"Defining a dispensing device at the drug level for a division will override"
W !,"the dispensing device settings in the OUTPATIENT SITE File (#59). If populated,",!,"the drug will be sent to the dispensing device for that division.",!
S DR="906"
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
CPTIER(VAPID) ;Called from PSSCOMMON Input Template
; VAPID = IEN OF DRUG FILE #50
N CPDATE,X,PSSCP D NOW^%DTC S CPDATE=X S PSSCP=$$CPTIER^PSNAPIS("",CPDATE,VAPID,1) K CPDATE,X
; PSSCP = Copay Tier^Effective Date^End Date
W !,"Copay Tier: ",$P(PSSCP,"^",1)
W !,"Copay Effective Date: " S Y=$P(PSSCP,"^",2) D DD^%DT W Y K Y,PSSCP
Q
;
GETTIER(PSSTDRUG) ;called by DIC to get copay tier for today's date
N VAPID,CPDATE,X,PSSCP,VAPROD,PSSDRGCL,PSSCONVD,PSSINACT,PSSFSN,PSSNFORM,PSSMSG,PSSRESTR,PSSDRDAT,PSSFD D NOW^%DTC S CPDATE=X
D GETS^DIQ(50,PSSTDRUG,"2;22;51;6;100;101;102","IE","PSSDRDAT")
S (PSSDRGCL,PSSFSN,PSSNFORM,PSSINACT,PSSMSG,PSSRESTR,VAPROD)=""
S:$G(PSSDRDAT(50,PSSTDRUG_",",2,"E"))'="" PSSDRGCL=PSSDRDAT(50,PSSTDRUG_",",2,"E")
S:$G(PSSDRDAT(50,PSSTDRUG_",",6,"E"))'="" PSSFSN=PSSDRDAT(50,PSSTDRUG_",",6,"E")
S:$G(PSSDRDAT(50,PSSTDRUG_",",51,"E"))'="" PSSNFORM=PSSDRDAT(50,PSSTDRUG_",",51,"E")
S:$G(PSSDRDAT(50,PSSTDRUG_",",100,"I")) PSSINACT=PSSDRDAT(50,PSSTDRUG_",",100,"I")
S:$G(PSSDRDAT(50,PSSTDRUG_",",101,"E"))'="" PSSMSG=PSSDRDAT(50,PSSTDRUG_",",101,"E")
S:$G(PSSDRDAT(50,PSSTDRUG_",",102,"E"))'="" PSSRESTR=PSSDRDAT(50,PSSTDRUG_",",102,"E")
S:$G(PSSDRDAT(50,PSSTDRUG_",",22,"I")) VAPROD=PSSDRDAT(50,PSSTDRUG_",",22,"I")
W " "_$$GET1^DIQ(50,PSSTDRUG,2)
S PSSCP=$$CPTIER^PSNAPIS(VAPROD,CPDATE,"",1) K CPDATE,X
W:$G(PSSFSN)["" " "_PSSFSN W:$G(PSSNFORM)["" " ",PSSNFORM ;FSN; local non-formulary
S PSSFD=$$FDR^PSNACT(VAPROD) ;ppsn
W:PSSFD'="" " "_PSSFD
I $G(VAPROD),$P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
S:$G(PSSINACT) PSSCONVD=$$DATE(PSSINACT) ;inactive date
W:$G(PSSCONVD)'="" " "_PSSCONVD
W:$G(PSSMSG)'="" " "_PSSMSG
W:$G(PSSRESTR)'="" " "_PSSRESTR
Q
;
DATE(PSSCONVD) ;convert fileman date to mm/dd/yyyy
N DATE
S DATE="",DATE=$E(PSSCONVD,4,5)_"/"_$E(PSSCONVD,6,7)_"/"_(1700+$E(PSSCONVD,1,3))
Q DATE
;
FD(PSSTDRUG) ;
N VAPROD,PSSDRDAT
D GETS^DIQ(50,PSSTDRUG,22,"I","PSSDRDAT")
S VAPROD=PSSDRDAT(50,PSSTDRUG_",",22,"I")
Q:VAPROD=""
S PSSFD="",PSSFD=$$GET1^DIQ(50.68,VAPROD,109) ;ppsn
W:PSSFD'="" !,"Formulary Designator: "_PSSFD
I $D(^PSNDF(50.68,VAPROD,5.1,1,0)) D FDT^PSNACT(VAPROD) ;ppsn
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDEE 14027 printed Dec 13, 2024@02:30:43 Page 2
PSSDEE ;BIR/WRT - MASTER DRUG ENTER/EDIT ROUTINE ;Nov 27, 2018@10:03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61,82,90,110,155,156,180,193,200,207,195,227,220,214**;9/30/97;Build 43
+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 ;Reference to PSNAPIS supported by DBIA #2531
+8 ;Reference to ^XMB("NETNAME" supported by DBIA #1131
+9 ;Reference to ^XUSEC supported by DIBA #10076
+10 ;Reference to FDR & FDT^PSNACT supported by DBIA #6754
+11 ;
BEGIN NEW PSSUPRAF,PSSTDRUG
+1 SET PSSFLAG=0
DO ^PSSDEE2
SET PSSZ=1
FOR PSSXX=1:1
KILL DA
DO ASK
if PSSFLAG
QUIT
DONE DO ^PSSDEE2
KILL PSSFLAGK,PSSXX,DIE,DIR,CLFLAG,CLFALG,DISPDRG,DLAYGO,DR,ENTRY,FLAG,FLG1,FLG2,FLG4,FLG5,FLG6,FLG7,FLGKY,FLGMTH,FLGNDF,FLGOI,K,NEWDF
+1 KILL NFLAG,NWND,NWPC1,NWPC2,NWPC3OLDDF,PSIUDA,PSIUX,PSNP,PSSANS,PSSASK,PSSDA,PSSDD,PSSFLAG,PSSOR,PSSZ,PSXBT,PSXF,PSXFL,PSXUM,PSXGOOD,PSXLOC,ZAPFLG
+2 QUIT
ASK ;
+1 WRITE !
SET DIC="^PSDRUG("
SET DIC(0)="QEALMNTV"
SET DLAYGO=50
SET DIC("T")=""
SET DIC("W")="S PSSTDRUG=Y D GETTIER^PSSDEE(PSSTDRUG)"
DO ^DIC
KILL DIC
IF Y<0
SET PSSFLAG=1
QUIT
+2 NEW PSINACT
SET (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI,PSINACT)=0
KILL ^TMP($JOB,"ADD"),^TMP($JOB,"SOL")
+3 SET DA=+Y
SET DISPDRG=DA
LOCK +^PSDRUG(DISPDRG):0
IF '$TEST
WRITE !,$CHAR(7),"Another person is editing this one."
QUIT
+4 ; drug enter/edit auditing
DO BEFORE^PSSDEEA($TEXT(+0))
+5 ;;<<*180 - RJS
IF $GET(^PSDRUG(DA,"I"))
SET PSINACT=$GET(^PSDRUG(DA,"I"))
IF PSINACT
IF PSINACT<DT
SET PSINACT=1
+6 SET PSSHUIDG=1
SET PSSNEW=$PIECE(Y,"^",3)
DO USE
DO NOPE
DO COMMON
DO DEA
DO MF
KILL PSSHUIDG,PSSUPRAF
+7 ; if any outpatient site has a dispense machine running HL7 V.2.4, then
+8 ; run the new routine and create message
+9 NEW XX,DNSNAM,DNSPORT,DVER,DMFU,PSSUPRA
SET XX=""
+10 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:1
+11 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+12 SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
+13 if DVER="2.4"&(DNSNAM'="")&(DMFU="YES")
DO DRG^PSSDGUPD(DISPDRG,PSSNEW,DNSNAM,DNSPORT)
End DoDot:1
+14 DO DRG^PSSHUIDG(DISPDRG,PSSNEW)
LOCK -^PSDRUG(DISPDRG)
+15 ; drug enter/edit auditing
DO AFTER^PSSDEEA($TEXT(+0))
+16 SET XX=$PIECE($GET(^PSDRUG(DISPDRG,2)),"^",3)
IF XX["U"!(XX["I")
Begin DoDot:1
+17 SET XX=$$SNDHL7^PSSMSTR()
if XX
Begin DoDot:2
+18 ;U=1,N=2,B=3
if PSSNEW&'((XX=2)!(XX=3))
QUIT
+19 ;U=1,N=2,B=3
if 'PSSNEW&(XX=2)
QUIT
+20 NEW VAR
+21 IF PSSNEW&((XX=2)!(XX=3))
SET VAR="Would you like to send this new drug to PADE"
+22 IF '$TEST
SET VAR="Would you like to send a drug file update to PADE"
+23 WRITE !!,"This drug is marked for either UD or IV use, and you have at least"
+24 WRITE !,"one active Pharmacy Automated Dispensing Equipment (PADE)."
+25 KILL DIR,DIRUT,DUOUT,DTOUT
+26 SET DIR(0)="Y"
SET DIR("A")=VAR
+27 SET DIR("?")="Enter Y for Yes or N for No."
DO ^DIR
KILL DIR
+28 if 'Y
QUIT
+29 NEW PSSPADE
SET PSSPADE=1
SET XX=""
+30 DO ENP^PSSHLDFS(DISPDRG,$SELECT(PSSNEW:"MAD",1:"MUP"))
End DoDot:2
End DoDot:1
SET XX=""
+31 DO EPHARM^PSSBPSUT(DISPDRG)
+32 KILL FLG3,PSSNEW
+33 QUIT
+34 ;
COMMON ;
+1 SET DIE="^PSDRUG("
SET DR="[PSSCOMMON]"
+2 DO ^DIE
+3 IF $DATA(Y)!($DATA(DTOUT))
QUIT
+4 IF '$DATA(^PSDRUG(DA,660))
SET $PIECE(^PSDRUG(DA,660),"^",6)=""
+5 IF '$DATA(Y)
WRITE !,"PRICE PER DISPENSE UNIT: ",$PIECE(^PSDRUG(DA,660),"^",6)
+6 DO DEA
DO CK
DO ASKND
DO OIKILL^PSSDEE1
DO COMMON1
+7 QUIT
+8 ;
COMMON1 WRITE !,"Just a reminder...you are editing ",$PIECE(^PSDRUG(DISPDRG,0),"^"),"."
+1 SET (PSSVVDA,DA)=DISPDRG
DO DOSN^PSSDOS
SET DA=PSSVVDA
KILL PSSVVDA
DO USE
DO APP
DO ORDITM^PSSDEE1
+2 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 SET PSSUPRAF=%
+3 IF %=2
KILL X,Y
QUIT
+4 IF %<0
KILL X,Y
QUIT
+5 ;;<<*180 - RJS
IF %=1
Begin DoDot:1
+6 DO RSET^PSSDEE1
+7 IF 'PSINACT
DO EN1^PSSUTIL(DISPDRG,1)
+8 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
End DoDot:1
+9 ;;<< *180 - RJS
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 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 IF FLG1
IF FLG2
IF FLG3
IF FLG4
IF FLG5
IF FLG6
SET FLAG=1
+8 IF FLAG
WRITE !,"A - ALL"
+9 WRITE !
+10 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
+11 IF FLGKY'=1
Begin DoDot:1
+12 KILL DIR
SET DIR(0)="FO^1:30"
+13 SET DIR("A")="Enter your choice(s) separated by commas "
+14 FOR
DO ^DIR
if $$CHECK($$UP^XLFSTR(X))
QUIT
+15 SET PSSANS=X
SET PSSANS=$$UP^XLFSTR(PSSANS)
DO BRANCH
DO BRANCH1
End DoDot:1
+16 QUIT
+17 ;
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 WRITE "Invalid Entry",$CHAR(7)
SET CHECK=0
End DoDot:1
+13 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 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
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"[$EXTRACT(X)
KILL X,Y,DIRUT
QUIT
+2 IF "Yy"[$EXTRACT(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"[$EXTRACT(X)
KILL X,Y,DIRUT
QUIT
+2 IF "Yy"[$EXTRACT(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 $GET(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 if '$DATA(PACK)
WRITE !," NONE"
+4 IF PACK'["O"
IF PACK'["U"
IF PACK'["I"
IF PACK'["W"
IF PACK'["D"
IF PACK'["N"
IF PACK'["X"
WRITE !," NONE"
+5 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 ;
+1 SET DIE="^PSDRUG("
SET DR="28"
SET DA=DISPDRG
+2 DO ^DIE
+3 if '+$PIECE($GET(^PSDRUG(DA,6)),"^")
QUIT
OPEI2 ; get external dispensing devices associated with the drug
+1 WRITE !!,"Defining a dispensing device at the drug level for a division will override"
+2 WRITE !,"the dispensing device settings in the OUTPATIENT SITE File (#59). If populated,",!,"the drug will be sent to the dispensing device for that division.",!
+3 SET DR="906"
+4 DO ^DIE
+5 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
CPTIER(VAPID) ;Called from PSSCOMMON Input Template
+1 ; VAPID = IEN OF DRUG FILE #50
+2 NEW CPDATE,X,PSSCP
DO NOW^%DTC
SET CPDATE=X
SET PSSCP=$$CPTIER^PSNAPIS("",CPDATE,VAPID,1)
KILL CPDATE,X
+3 ; PSSCP = Copay Tier^Effective Date^End Date
+4 WRITE !,"Copay Tier: ",$PIECE(PSSCP,"^",1)
+5 WRITE !,"Copay Effective Date: "
SET Y=$PIECE(PSSCP,"^",2)
DO DD^%DT
WRITE Y
KILL Y,PSSCP
+6 QUIT
+7 ;
GETTIER(PSSTDRUG) ;called by DIC to get copay tier for today's date
+1 NEW VAPID,CPDATE,X,PSSCP,VAPROD,PSSDRGCL,PSSCONVD,PSSINACT,PSSFSN,PSSNFORM,PSSMSG,PSSRESTR,PSSDRDAT,PSSFD
DO NOW^%DTC
SET CPDATE=X
+2 DO GETS^DIQ(50,PSSTDRUG,"2;22;51;6;100;101;102","IE","PSSDRDAT")
+3 SET (PSSDRGCL,PSSFSN,PSSNFORM,PSSINACT,PSSMSG,PSSRESTR,VAPROD)=""
+4 if $GET(PSSDRDAT(50,PSSTDRUG_",",2,"E"))'=""
SET PSSDRGCL=PSSDRDAT(50,PSSTDRUG_",",2,"E")
+5 if $GET(PSSDRDAT(50,PSSTDRUG_",",6,"E"))'=""
SET PSSFSN=PSSDRDAT(50,PSSTDRUG_",",6,"E")
+6 if $GET(PSSDRDAT(50,PSSTDRUG_",",51,"E"))'=""
SET PSSNFORM=PSSDRDAT(50,PSSTDRUG_",",51,"E")
+7 if $GET(PSSDRDAT(50,PSSTDRUG_",",100,"I"))
SET PSSINACT=PSSDRDAT(50,PSSTDRUG_",",100,"I")
+8 if $GET(PSSDRDAT(50,PSSTDRUG_",",101,"E"))'=""
SET PSSMSG=PSSDRDAT(50,PSSTDRUG_",",101,"E")
+9 if $GET(PSSDRDAT(50,PSSTDRUG_",",102,"E"))'=""
SET PSSRESTR=PSSDRDAT(50,PSSTDRUG_",",102,"E")
+10 if $GET(PSSDRDAT(50,PSSTDRUG_",",22,"I"))
SET VAPROD=PSSDRDAT(50,PSSTDRUG_",",22,"I")
+11 WRITE " "_$$GET1^DIQ(50,PSSTDRUG,2)
+12 SET PSSCP=$$CPTIER^PSNAPIS(VAPROD,CPDATE,"",1)
KILL CPDATE,X
+13 ;FSN; local non-formulary
if $GET(PSSFSN)[""
WRITE " "_PSSFSN
if $GET(PSSNFORM)[""
WRITE " ",PSSNFORM
+14 ;ppsn
SET PSSFD=$$FDR^PSNACT(VAPROD)
+15 if PSSFD'=""
WRITE " "_PSSFD
+16 IF $GET(VAPROD)
IF $PIECE(PSSCP,"^")'=""
WRITE " Tier ",$PIECE(PSSCP,"^")
+17 ;inactive date
if $GET(PSSINACT)
SET PSSCONVD=$$DATE(PSSINACT)
+18 if $GET(PSSCONVD)'=""
WRITE " "_PSSCONVD
+19 if $GET(PSSMSG)'=""
WRITE " "_PSSMSG
+20 if $GET(PSSRESTR)'=""
WRITE " "_PSSRESTR
+21 QUIT
+22 ;
DATE(PSSCONVD) ;convert fileman date to mm/dd/yyyy
+1 NEW DATE
+2 SET DATE=""
SET DATE=$EXTRACT(PSSCONVD,4,5)_"/"_$EXTRACT(PSSCONVD,6,7)_"/"_(1700+$EXTRACT(PSSCONVD,1,3))
+3 QUIT DATE
+4 ;
FD(PSSTDRUG) ;
+1 NEW VAPROD,PSSDRDAT
+2 DO GETS^DIQ(50,PSSTDRUG,22,"I","PSSDRDAT")
+3 SET VAPROD=PSSDRDAT(50,PSSTDRUG_",",22,"I")
+4 if VAPROD=""
QUIT
+5 ;ppsn
SET PSSFD=""
SET PSSFD=$$GET1^DIQ(50.68,VAPROD,109)
+6 if PSSFD'=""
WRITE !,"Formulary Designator: "_PSSFD
+7 ;ppsn
IF $DATA(^PSNDF(50.68,VAPROD,5.1,1,0))
DO FDT^PSNACT(VAPROD)
+8 QUIT
