- 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 Feb 18, 2025@23:56:45 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