- PSSLOOK ;BIR/WRT - Drug file lookup ;Nov 27, 2018@10:04
- ;;1.0;PHARMACY DATA MANAGEMENT;**3,7,15,16,20,24,29,38,68,61,87,90,127,147,170,189,192,200,195,213,227,220,214,233,239,253**;9/30/97;Build 7
- ;
- ; Reference to ^PS(50.605 in ICR #2138
- ; Reference to ^PS(50.608 in ICR #2136
- ; Reference to ^PS(50.609 in ICR #2137
- ; Reference to ^PS(50.607 in ICR #2221
- ; Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) in ICR #2574
- ; Reference to $$FORMI^PSNAPIS(P1,P3) in ICR #2574
- ; Reference to $$PSJDF^PSNAPIS(P1,P3) in ICR #2531
- ; Reference to $$PSJST^PSNAPIS(P1,P3) in ICR #2531
- ; Reference to $$PROD2^PSNAPIS(P1,P3) in ICR #2531
- ; Reference to $$CPTIER^PSNAPIS(P1,P3) in ICR #2531
- ; Reference to $$VAGN^PSNAPIS(P1) in ICR #2531
- ; Reference to ^PSNDF(50.68 in ICR #3735
- ; Reference to DATA^PSN50P68 in ICR #4545
- ; Reference to FD^PSNACT, FDT^PSNACT in ICR #6754
- ;
- START S QUIT=0,PSSFG=0 D KILL F PSSXX=1:1 D PICK Q:PSSFG
- DONE D KILL K PSSFG,PSSXX,QUIT,FM,FMS,Y2K
- Q
- PICK W ! K DIC S DIC="^PSDRUG(",DIC(0)="AEQMVTN",DIC("T")="",DIC("W")="S PSSTDRUG=Y D GETTIER^PSSDEE(PSSTDRUG)" D ^DIC K DIC I Y<0 S PSSFG=1 Q
- S IFN=+Y D NDDATA,GETDATA,INACT,NOD66,FORMAT,KILL
- Q
- NDDATA I $D(^PSDRUG(IFN,"ND")) S CLPTR=$P(^PSDRUG(IFN,"ND"),"^",6) I $P(^PSDRUG(IFN,"ND"),"^",2)]"" S NDNODE=^PSDRUG(IFN,"ND"),VAGNPTR=$P(NDNODE,"^",1),VAPN=$P(NDNODE,"^",2),SZPTR=$P(NDNODE,"^",4),TYPTR=$P(NDNODE,"^",5) D NDF,NDF1
- Q
- NDF S DA=VAGNPTR,X=$$VAGN^PSNAPIS(DA),VAGN=X,PS=$P(^PS(50.609,SZPTR,0),"^",1),PT=$P(^PS(50.608,TYPTR,0),"^",1),P3=$P(NDNODE,"^",3)
- K X S DA=VAGNPTR,K=P3,X=$$PROD2^PSNAPIS(DA,K) I X]"",$P(X,"^")]"" S VAPRN=$P(X,"^"),VADU=$P(X,"^",4),CMOPID=$P(X,"^",2)
- S CSF="" I $P(NDNODE,"^",3) S CSF=$$GET1^DIQ(50.68,$P(NDNODE,"^",3),19,"I")
- ;
- S (PSSNIEN,CSF)="",PSSNIEN=$P(NDNODE,"^",3)
- K ^TMP($J,"PSNVAPR"),PSSHTH,PSSHTD,PSSPEPAC,PSSDOTSN
- I PSSNIEN'="" D DATA^PSN50P68(PSSNIEN,"","PSNVAPR") ;using the PRE encapuslation API instead
- I $D(^TMP($J,"PSNVAPR",PSSNIEN)) D
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,19))'="" CSF=$P(^TMP($J,"PSNVAPR",PSSNIEN,19),"^")
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,5))'="" VAPRN=^TMP($J,"PSNVAPR",PSSNIEN,5)
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,6))'="" CMOPID=^TMP($J,"PSNVAPR",PSSNIEN,6)
- .; Hazardous Waste fields
- .S (PSSHTH,PSSHTD,PSSPEPAC,PSSWSC,PSSDOTSN)=""
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,101))'="" PSSHTH=^TMP($J,"PSNVAPR",PSSNIEN,101)
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,102))'="" PSSHTD=^TMP($J,"PSNVAPR",PSSNIEN,102)
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,103))'="" PSSPEPAC=^TMP($J,"PSNVAPR",PSSNIEN,103)
- .S:$G(^TMP($J,"PSNVAPR",PSSNIEN,104))'="" PSSWSC=^TMP($J,"PSNVAPR",PSSNIEN,104)
- .S HAZWCNT2=1,HAZWCNT=0,DIWL=1,DIWR=50
- .F S HAZWCNT=$O(^TMP($J,"PSNVAPR",PSSNIEN,105,HAZWCNT)) Q:'HAZWCNT D
- .. S X="",X=^TMP($J,"PSNVAPR",PSSNIEN,105,HAZWCNT) S PSSDOTSN(HAZWCNT)=X
- Q
- IT S CMOPID=$P(X,"^",2)
- Q
- NDF1 S X=$$PSJDF^PSNAPIS(DA,K),VADF=$P(X,"^",2)
- Q
- INACT S ACT="" I $D(^PSDRUG(IFN,"I")) S Y=$P(^PSDRUG(IFN,"I"),"^",1) X ^DD("DD") S ACT=Y
- Q
- GETDATA S NODE0=^PSDRUG(IFN,0),GN=$P(NODE0,"^",1),CL=$P(NODE0,"^",2),DEA=$P(NODE0,"^",3),WRN=$P(NODE0,"^",8),NF=$P(NODE0,"^",9),MESS=$P(NODE0,"^",10),VNF=$P(NODE0,"^",11),CLASS="",WARN="" S:NF=1 NF="N/F" S:VNF=1 VNF="V-N/F"
- S PSSNODE=$G(^PSDRUG(IFN,"DOS"))
- I CL'="",$G(CLPTR)'="" S CLASS=CL_" "_$P(^PS(50.605,CLPTR,0),"^",2)
- S PSSX=$Q(^PSDRUG(IFN,950)),PSSMAX=$P(@PSSX,"^",3)
- D GETS^DIQ(50.095,PSSMAX_","_IFN_",","*","E","PSSDAT","PSSERR")
- S PSSDT=$G(PSSDAT(50.095,PSSMAX_","_IFN_",",.01,"E"))
- S PSSUSR=$G(PSSDAT(50.095,PSSMAX_","_IFN_",",1,"E"))
- S PSSVAL=$G(PSSDAT(50.095,PSSMAX_","_IFN_",",3,"E"))
- I $D(^PSDRUG(IFN,3)) S:$P(^PSDRUG(IFN,3),"^")=0 CMOP="NO" S:$P(^PSDRUG(IFN,3),"^")=1 CMOP="YES"
- I $D(^PSDRUG(IFN,5)) S QDM=^PSDRUG(IFN,5)
- S OINM="" S NDC="" I $D(^PSDRUG(IFN,2)) S NODE2=^PSDRUG(IFN,2) S:$P(NODE2,"^",1)]"" OIPTR=$P(NODE2,"^",1) S NDC=$P(NODE2,"^",4) S:$P(NODE2,"^",6)]"" PDPTR=$P(NODE2,"^",6) S APP=$P(NODE2,"^",3),FM="" D TWOA
- Q
- TWOA I $D(OIPTR) S OI=$P(^PS(50.7,OIPTR,0),"^",1),DFPTR=$P(^PS(50.7,OIPTR,0),"^",2),DF=$P(^PS(50.606,DFPTR,0),"^",1),FMS=$P(^PS(50.7,OIPTR,0),"^",12) S:FMS]"" FM=" (N/F)" S OINM=OI_" "_DF_FM
- ;I $D(PDPTR) S PD=$P(^PS(50.3,PDPTR,0),"^",1)
- Q
- NOD66 S (DUPOU,PPDU,PPOU,DU,SS)="" I $D(^PSDRUG(IFN,660)) S NDE=^PSDRUG(IFN,660),OUPTR=$P(NDE,"^",2),PPOU=$P(NDE,"^",3),DUPOU=$P(NDE,"^",5),PPDU=$P(NDE,"^",6),SS=$P(NDE,"^",7),DU=$P(NDE,"^",8) I OUPTR]"" S OU=$P(^DIC(51.5,OUPTR,0),"^")
- Q
- SYN I $D(^PSDRUG(IFN,1,0)) F ZZZ=0:0 S ZZZ=$O(^PSDRUG(IFN,1,ZZZ)) Q:'ZZZ S SYNM=$P(^PSDRUG(IFN,1,ZZZ,0),"^",1),INT=$P(^PSDRUG(IFN,1,ZZZ,0),"^",3) D SYN1
- Q
- SYN1 S INT=$S(INT=0:"Trade Name",INT=1:"Quick Code",INT="C":"Ctrl Substances",INT="D":"Drug Accountability",1:"") D FULL Q:$G(QUIT) W ?14,SYNM,?55,INT,!
- Q
- SYN2 S:INT=0 INT="Trade" S:INT=1 INT="Quick" S:INT="C" INT="Ctrl Subs" S:INT="D" INT="Drug Acct" W ?16,SYNM,?57,INT,!
- Q
- IFCAP I $D(^PSDRUG(IFN,441,0)) F QQQ=0:0 S QQQ=$O(^PSDRUG(IFN,441,QQQ)) Q:'QQQ S IFCAPNM=$P(^PSDRUG(IFN,441,QQQ,0),"^",1)
- Q
- FORMAT ; BEGIN WRITING
- N DAW,NOONEVA
- W @IOF,"DRUG NAME: ",GN," (IEN: ",IFN,")",!
- F XX=1:1:77 W "="
- W !
- W:$D(VAPRN) "VA PRINT NAME: ",?17,VAPRN W:$D(CMOPID) ?60,"CMOP ID#: ",CMOPID W:$D(VAPN) !,"VA PRODUCT NAME: ",?17,VAPN
- I $L($G(VAPN))>42 W !
- W:$D(CMOP) ?60,"CMOP DISPENSE: ",CMOP
- W:$D(OINM) !,"ORDERABLE ITEM: ",?17,OINM
- I $L($G(OINM))>42 W !
- W:$D(VAPN) ?60,"NDF DF: ",VADF
- I $D(OIPTR),OIPTR]"" W !,"ORDERABLE ITEM TEXT: ",! D OITXT
- W:$D(PD) !,"PRIMARY DRUG: ",?17,PD
- W !,"SYNONYM(S): " D SYN D FULL Q:$G(QUIT) W !,"MESSAGE: ",MESS,!
- D FULL Q:$G(QUIT) F XX=1:1:77 W "-"
- W !
- D FULL Q:$G(QUIT) W "DEA, SPECIAL HDLG: ",DEA,?48,"NDC: ",?63,NDC
- S DAW=$$GET1^DIQ(50,IFN,81)
- I DAW="" S DAW=0
- D FULL Q:$G(QUIT) W !,"DAW CODE: ",DAW," - ",$$DAWEXT^PSSDAWUT(DAW)
- D FULL Q:$G(QUIT) W !,"CS FEDERAL SCHEDULE: ",$G(CSF),?39
- S NOONEVA=$$GET1^DIQ(50,IFN,907)
- I NOONEVA'="" W ?39,"RESTRICT FOR ONEVA PHARMACY: ",NOONEVA
- ;
- ;Hazardous Waste
- W !
- S PSSHTDX=0
- I $G(PSSHTD)=1 S PSSHTDX=1
- D FULL Q:$G(QUIT) W:$G(PSSHTH)'="" !,"Hazardous to Handle: ",$S(PSSHTH=1:"YES",PSSHTH=0:"NO",1:"")
- D FULL Q:$G(QUIT) W:$G(PSSHTD)'="" !,"Hazardous to Dispose: ",$S(PSSHTD=1:"YES",PSSHTD=0:"NO",1:"")
- I $G(PSSPEPAC)'=""&(PSSHTDX) D FULL Q:$G(QUIT) W !," Primary EPA Code: ",PSSPEPAC
- I $G(PSSWSC)'=""&(PSSHTDX) D FULL Q:$G(QUIT) W !," Waste Sort Code: ",PSSWSC
- ;
- N HAZWCNT,HAZWCNT2,X,DIWL,DIWR,DIWF
- K ^UTILITY($J,"W")
- S HAZWCNT=0,HAZWCNT2=1,HAZWCNT=0,DIWL=1,DIWR=50
- F S HAZWCNT=$O(PSSDOTSN(HAZWCNT)) Q:HAZWCNT="" S X=PSSDOTSN(HAZWCNT) D ^DIWP
- S HAZWCNT=0 F S HAZWCNT=$O(^UTILITY($J,"W",DIWL,HAZWCNT)) Q:'HAZWCNT D
- .D FULL Q:$G(QUIT)
- .I HAZWCNT2=1 W !," DOT Shipping Name: "
- .I HAZWCNT2>1 W !," "
- .W $G(^UTILITY($J,"W",DIWL,HAZWCNT,0)) S HAZWCNT2=2
- K ^UTILITY($J,"W")
- ;I $G(PSSDOTSN)'=""&(PSSHTDX) D FULL Q:$G(QUIT) W !," DOT Shipping Name: ",PSSDOTSN
- W !
- ;
- D FULL Q:$G(QUIT) W !,"INACTIVE DATE: ",ACT
- D FULL Q:$G(QUIT) W:$D(QDM) !,"QUANTITY DISPENSE MESSAGE: ",QDM,!
- D FULL Q:$G(QUIT) I WRN]"" W !,"WARNING LABEL: " S X=WRN F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) W:$D(^PS(54,Z1,0)) ?19,$P(^(0),"^",1),! I '$D(^(0)) W ?19,"NO SUCH WARNING LABEL" K X Q
- D FULL Q:$G(QUIT) S PSSLOOK=1 D
- .N DRUG,PSSWSITE
- .I $P($G(^PSDRUG(IFN,0)),"^")="" K PSSLOOK Q
- .S PSSWSITE=+$O(^PS(59.7,0)) W !,"WARNING LABEL SOURCE is " D
- ..I $P($G(^PS(59.7,PSSWSITE,10)),"^",9)="N" W "set to 'NEW'" Q
- ..W "not set to 'NEW'"
- .K PSSWRN
- .D FULL Q:$G(QUIT) W !,"NEW WARNING LABEL:"
- .S ^TMP("PSSWRNB",$J,$P(^PSDRUG(IFN,0),"^"))="" D EN^PSSWRNE(.QUIT)
- .K PSSLOOK,^TMP("PSSWRNB",$J),PSSWRN
- D FULL Q:$G(QUIT) W:'$D(QDM) !
- W ! F XX=1:1:77 W "-"
- D FULL Q:$G(QUIT) W !
- W "ORDER UNIT: ",?27 W:$D(OU) OU W ?40,"PRICE/ORDER UNIT: ",?67,PPOU
- D FULL Q:$G(QUIT) W !,"DISPENSE UNIT: ",?27,DU W:$D(VADU) ?40,"VA DISPENSE UNIT: ",?67,VADU
- D FULL Q:$G(QUIT) W !,"DISPENSE UNITS/ORDER UNIT: ",?21,DUPOU,?40,"PRICE/DISPENSE UNIT: ",?67,PPDU
- D:$G(PSSVAL)]""
- . D FULL Q:$G(QUIT) W !,"DATE PRICE/DISPENSE UNIT LAST CHANGED: ",?27,PSSDT
- . D FULL Q:$G(QUIT) W !,"BY: ",PSSUSR,?27,"VALUE: ",PSSVAL
- D FULL Q:$G(QUIT) W !,"NCPDP DISPENSE UNIT: ",$$GET1^DIQ(50,IFN,82),?40,"NCPDP QUANTITY MULTIPLIER: ",?67,$J($$GET1^DIQ(50,IFN,83),10,5)
- D FULL Q:$G(QUIT) W !,"MAXIMUM DAYS SUPPLY: ",$$GET1^DIQ(50,IFN,66)
- D FULL Q:$G(QUIT) W !,"ePharmacy Billable: ",$$GET1^DIQ(50,IFN,84)
- D FULL Q:$G(QUIT) W !?2,"ePharmacy Billable (TRICARE): ",$$GET1^DIQ(50,IFN,85) W ?40,"ePharmacy Billable (CHAMPVA): ",$$GET1^DIQ(50,IFN,86)
- D FULL Q:$G(QUIT) W !,"Sensitive Diagnosis Drug: ",$$GET1^DIQ(50,IFN,87) W !
- D FULL Q:$G(QUIT) W !,"APPL PKG USE:" S APPL="" S:'$D(APP) APPL=" NONE"
- I $D(APP) D
- . S:APP["O" APPL=APPL_" Outpatient" S:APP["U" APPL=APPL_" Unit Dose"
- . S:APP["I" APPL=APPL_" IV" S:APP["W" APPL=APPL_" Ward Stock"
- . S:APP["N" APPL=APPL_" Control Subs" S:APP["X" APPL=APPL_" Non-VA Med"
- . S:APPL="" APPL=" NONE"
- W ?13,APPL
- I $P(PSSNODE,"^",2) S (PSSCALC,PSSUNIT)=$P($G(^PS(50.607,+$P(PSSNODE,U,2),0)),U),PSSSTR=$P(PSSNODE,"^")
- I $G(PSSUNIT)'="",$G(PSSUNIT)["/" D UNCALC
- D FULL Q:$G(QUIT) W !,"STRENGTH: ",$S($E($P(PSSNODE,U),1)=".":"0",1:"")_$P(PSSNODE,U),?35,"UNIT: ",$G(PSSCALC)
- D FULL Q:$G(QUIT) W !,"POSSIBLE DOSAGES:"
- I $D(^PSDRUG(IFN,"DOS1",0)) F PDS=0:0 S PDS=$O(^PSDRUG(IFN,"DOS1",PDS)) Q:'PDS D
- .S POSDOS=^PSDRUG(IFN,"DOS1",PDS,0)
- .D FULL Q:$G(QUIT) W !," DISPENSE UNITS PER DOSE: ",$S($E($P(POSDOS,U),1)=".":"0",1:"")_$P(POSDOS,U),?40,"DOSE: ",$S($E($P(POSDOS,U,2),1)=".":"0",1:"")_$P(POSDOS,U,2),?55,"PACKAGE: ",$P(POSDOS,U,3)
- .D FULL Q:$G(QUIT) W !," BCMA UNITS PER DOSE: ",$P(POSDOS,U,4)
- D FULL Q:$G(QUIT) W !,"LOCAL POSSIBLE DOSAGES:"
- I $D(^PSDRUG(IFN,"DOS2",0)) F PDS=0:0 S PDS=$O(^PSDRUG(IFN,"DOS2",PDS)) Q:'PDS D
- .S LPDOS=^PSDRUG(IFN,"DOS2",PDS,0)
- .D FULL Q:$G(QUIT) W !," LOCAL POSSIBLE DOSAGE: " D
- ..I $L($P(LPDOS,U))'>27 W $P(LPDOS,U),?55,"PACKAGE: ",$P(LPDOS,U,2)
- ..E W !,?10,$P(LPDOS,U),!,?55,"PACKAGE: ",$P(LPDOS,U,2)
- ..D FULL Q:$G(QUIT) W !," BCMA UNITS PER DOSE: ",$P(LPDOS,U,3) D FULL Q:$G(QUIT) D LPDNW
- D FULL Q:$G(QUIT) W ! F XX=1:1:77 W "-"
- D FULL Q:$G(QUIT) W !,"VA CLASS: ",$G(CLASS)
- D FULL Q:$G(QUIT) W !,"LOCAL NON-FORMULARY: ",$G(NF)," ","VISN NON-FORMULARY: ",$G(VNF)
- N DA,K,LIST,PSXDN,PSXGN,X,XX1,XX2
- K PSXGN,PSXVP I $D(^PSDRUG(IFN,"ND")) S PSXDN=$G(^PSDRUG(IFN,"ND")),PSXGN=$P(PSXDN,"^"),PSXVP=$P(PSXDN,"^",3)
- I $G(PSXGN),$G(PSXVP) S X=$$PROD2^PSNAPIS(PSXGN,PSXVP),XX1=$$FORMI^PSNAPIS(PSXGN,PSXVP)
- D FULL Q:$G(QUIT) W !,"National Formulary Indicator: "_$S($G(XX1)=1:"YES",$G(XX1)=0:"NO",1:"Not Matched to NDF")
- I $G(PSXVP) D FD^PSNACT(PSXVP) ;PPSN
- I $D(^PSDRUG(IFN,65,0)) D FULL Q:$G(QUIT) W !,"FORMULARY ALTERNATIVES: ",! F FA=0:0 S FA=$O(^PSDRUG(IFN,65,FA)) Q:'FA S LDFPTR=$P($G(^PSDRUG(IFN,65,FA,0)),"^") I LDFPTR D FULL Q:$G(QUIT) W ?26,$P($G(^PSDRUG(LDFPTR,0)),"^"),!
- N CPDATE,PSSTIER D NOW^%DTC S CPDATE=$P(%,".") S PSSTIER=$$CPTIER^PSNAPIS($P($G(^PSDRUG(IFN,"ND")),"^",3),CPDATE,IFN,1) K CPDATE,%
- ; PSSTIER = Copay Tier^Effective Date^End Date
- W !,"Copay Tier: ",$P(PSSTIER,"^",1)
- W !,"Copay Effective Date: " S Y=$P(PSSTIER,"^",2) D DD^%DT W Y K Y
- D FULL Q:$G(QUIT) I $G(PSXGN),$G(PSXVP) W !,"National Restriction: " S XX2=$$FORMRX^PSNAPIS(PSXGN,PSXVP,.LIST) I $G(XX2)=1,$D(LIST) F XX2=0:0 S XX2=$O(LIST(XX2)) Q:'XX2 D FULL Q:$G(QUIT) W !,LIST(XX2,0)
- I $G(PSXVP) D FDT^PSNACT(PSXVP) ;PPSN
- W !,"Local Drug Text: ",! I $D(^PSDRUG(IFN,9,0)) D LDT
- Q
- LDT F TXT1=0:0 S TXT1=$O(^PSDRUG(IFN,9,TXT1)) Q:'TXT1 S TEXPTR=^PSDRUG(IFN,9,TXT1,0) F PPP=0:0 S PPP=$O(^PS(51.7,TEXPTR,2,PPP)) Q:'PPP S PST=$P($G(^PS(51.7,TEXPTR,0)),"^",2) I 'PST S WPT=^PS(51.7,TEXPTR,2,PPP,0) D FULL Q:$G(QUIT) W WPT,!
- ;
- ;
- KILL K IFN,APP,INT,VADU,VAGN,VAPN,VAPRN,P3,VAGNPTR,MESS,CLASS,DEA,ACT,CL,CLPTR,CMOP,DF,DFPTR,DU,DUPOUGN,IFCAPNM,NDC,NDE,NDNODE,NF,NODE0,NODE2,OI,OINM,OIPTR,OU,PD,PDPTR,PPDU,PPOU,PS,PT,NOD66,SYNM,SZPTR,TYPTR,WARN,WRN,XX,ZZZ,SS,OUPTR,CMOPID
- K DUPOU,QQQ,GN,QDM,APPL,VADF,DFP,DFRM,Y,Z0,Z1,DDD,PPP,TEXT,TXTPTR,TXT,TXT1,TEXPTR,VNF,WPT,FA,LDFPTR,TEXTPTR,QUIT,PST,D0,DA,K,DIR
- K PSSNODE,PSDOSUN,PDS,POSDOS,LPDOS,CSF,PSSSTR,PSSUNIT,PSSCALC,PSSTIER
- K ^TMP($J,"PSNVAPR")
- K PSSWSC,PSSNIEN,PSSHTH,PSSHTD,PSSPEPAC,PSSDOTSN,PSSCLEF,PSSPKG,PSSOMIT,PSSEXLMT,PSSHTDX,PSSII,PSSIII
- Q
- OITXT I $D(^PS(50.7,OIPTR,1,0)) F TXT=0:0 S TXT=$O(^PS(50.7,OIPTR,1,TXT)) Q:'TXT S TEXTPTR=^PS(50.7,OIPTR,1,TXT,0) F DDD=0:0 S DDD=$O(^PS(51.7,TEXTPTR,2,DDD)) Q:'DDD D IDATE I 'Y2K S TEXT=^PS(51.7,TEXTPTR,2,DDD,0) D FULL Q:$G(QUIT) W TEXT,!
- Q
- FULL D:($Y+5)>IOSL&('$G(QUIT)) FSCRN
- Q
- FSCRN Q:$G(QUIT) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit" D ^DIR W @IOF S:Y'=1 QUIT=1
- Q
- IDATE S Y2K=$P($G(^PS(51.7,TEXTPTR,0)),"^",2)
- Q
- UNCALC ;
- N PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH5 K PSSCALC
- S PSSDASH=0 S PSSNDFS=$$PSJST^PSNAPIS(+$P($G(^PSDRUG(IFN,"ND")),"^"),+$P($G(^PSDRUG(IFN,"ND")),"^",3)) S PSSNDFS=+$P($G(PSSNDFS),"^",2)
- I $G(PSSNDFS),$G(PSSSTR),+$G(PSSSTR)'=+$G(PSSNDFS) S PSSDASH=1
- S PSSVA=$P(PSSUNIT,"/"),PSSVB=$P(PSSUNIT,"/",2),PSSVA1=+$G(PSSVA),PSSVB1=+$G(PSSVB)
- I $G(PSSDASH) S PSSDASH2=PSSSTR/PSSNDFS,PSSDASH3=PSSDASH2*$S($G(PSSVB1):PSSVB1,1:1) S PSSDASH5=$S('$G(PSSVB1):PSSDASH3_$G(PSSVB),1:PSSDASH3_$P(PSSVB,PSSVB1,2))
- S PSSCALC=$S($G(PSSDASH):$S('$G(PSSVA1):PSSVA,1:$P(PSSVA1,PSSVA1,2))_"/"_$G(PSSDASH5),1:PSSUNIT)
- Q
- ;
- LPDNW ;Display Dose Unit and Numeric Dose fields, added with patch PSS*1*147
- N PSSLKL1,PSSLKL2,PSSLKL3,PSSLKL4
- S PSSLKL4=""
- S PSSLKL1=$P(LPDOS,"^",5),PSSLKL2=$P(LPDOS,"^",6)
- I PSSLKL1 S PSSLKL4=$P($G(^PS(51.24,+PSSLKL1,0)),"^")
- S PSSLKL3=$S($E(PSSLKL2)=".":"0",1:"")_PSSLKL2
- I $L(PSSLKL3)<18 D FULL Q:$G(QUIT) W !?5,"NUMERIC DOSE: "_PSSLKL3,?38,"DOSE UNIT: "_PSSLKL4 Q
- D FULL Q:$G(QUIT) W !?5,"NUMERIC DOSE: "_PSSLKL3
- D FULL Q:$G(QUIT) W !?38,"DOSE UNIT: "_PSSLKL4
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSLOOK 14122 printed Jan 18, 2025@03:33:40 Page 2
- PSSLOOK ;BIR/WRT - Drug file lookup ;Nov 27, 2018@10:04
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**3,7,15,16,20,24,29,38,68,61,87,90,127,147,170,189,192,200,195,213,227,220,214,233,239,253**;9/30/97;Build 7
- +2 ;
- +3 ; Reference to ^PS(50.605 in ICR #2138
- +4 ; Reference to ^PS(50.608 in ICR #2136
- +5 ; Reference to ^PS(50.609 in ICR #2137
- +6 ; Reference to ^PS(50.607 in ICR #2221
- +7 ; Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) in ICR #2574
- +8 ; Reference to $$FORMI^PSNAPIS(P1,P3) in ICR #2574
- +9 ; Reference to $$PSJDF^PSNAPIS(P1,P3) in ICR #2531
- +10 ; Reference to $$PSJST^PSNAPIS(P1,P3) in ICR #2531
- +11 ; Reference to $$PROD2^PSNAPIS(P1,P3) in ICR #2531
- +12 ; Reference to $$CPTIER^PSNAPIS(P1,P3) in ICR #2531
- +13 ; Reference to $$VAGN^PSNAPIS(P1) in ICR #2531
- +14 ; Reference to ^PSNDF(50.68 in ICR #3735
- +15 ; Reference to DATA^PSN50P68 in ICR #4545
- +16 ; Reference to FD^PSNACT, FDT^PSNACT in ICR #6754
- +17 ;
- START SET QUIT=0
- SET PSSFG=0
- DO KILL
- FOR PSSXX=1:1
- DO PICK
- if PSSFG
- QUIT
- DONE DO KILL
- KILL PSSFG,PSSXX,QUIT,FM,FMS,Y2K
- +1 QUIT
- PICK WRITE !
- KILL DIC
- SET DIC="^PSDRUG("
- SET DIC(0)="AEQMVTN"
- SET DIC("T")=""
- SET DIC("W")="S PSSTDRUG=Y D GETTIER^PSSDEE(PSSTDRUG)"
- DO ^DIC
- KILL DIC
- IF Y<0
- SET PSSFG=1
- QUIT
- +1 SET IFN=+Y
- DO NDDATA
- DO GETDATA
- DO INACT
- DO NOD66
- DO FORMAT
- DO KILL
- +2 QUIT
- NDDATA IF $DATA(^PSDRUG(IFN,"ND"))
- SET CLPTR=$PIECE(^PSDRUG(IFN,"ND"),"^",6)
- IF $PIECE(^PSDRUG(IFN,"ND"),"^",2)]""
- SET NDNODE=^PSDRUG(IFN,"ND")
- SET VAGNPTR=$PIECE(NDNODE,"^",1)
- SET VAPN=$PIECE(NDNODE,"^",2)
- SET SZPTR=$PIECE(NDNODE,"^",4)
- SET TYPTR=$PIECE(NDNODE,"^",5)
- DO NDF
- DO NDF1
- +1 QUIT
- NDF SET DA=VAGNPTR
- SET X=$$VAGN^PSNAPIS(DA)
- SET VAGN=X
- SET PS=$PIECE(^PS(50.609,SZPTR,0),"^",1)
- SET PT=$PIECE(^PS(50.608,TYPTR,0),"^",1)
- SET P3=$PIECE(NDNODE,"^",3)
- +1 KILL X
- SET DA=VAGNPTR
- SET K=P3
- SET X=$$PROD2^PSNAPIS(DA,K)
- IF X]""
- IF $PIECE(X,"^")]""
- SET VAPRN=$PIECE(X,"^")
- SET VADU=$PIECE(X,"^",4)
- SET CMOPID=$PIECE(X,"^",2)
- +2 SET CSF=""
- IF $PIECE(NDNODE,"^",3)
- SET CSF=$$GET1^DIQ(50.68,$PIECE(NDNODE,"^",3),19,"I")
- +3 ;
- +4 SET (PSSNIEN,CSF)=""
- SET PSSNIEN=$PIECE(NDNODE,"^",3)
- +5 KILL ^TMP($JOB,"PSNVAPR"),PSSHTH,PSSHTD,PSSPEPAC,PSSDOTSN
- +6 ;using the PRE encapuslation API instead
- IF PSSNIEN'=""
- DO DATA^PSN50P68(PSSNIEN,"","PSNVAPR")
- +7 IF $DATA(^TMP($JOB,"PSNVAPR",PSSNIEN))
- Begin DoDot:1
- +8 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,19))'=""
- SET CSF=$PIECE(^TMP($JOB,"PSNVAPR",PSSNIEN,19),"^")
- +9 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,5))'=""
- SET VAPRN=^TMP($JOB,"PSNVAPR",PSSNIEN,5)
- +10 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,6))'=""
- SET CMOPID=^TMP($JOB,"PSNVAPR",PSSNIEN,6)
- +11 ; Hazardous Waste fields
- +12 SET (PSSHTH,PSSHTD,PSSPEPAC,PSSWSC,PSSDOTSN)=""
- +13 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,101))'=""
- SET PSSHTH=^TMP($JOB,"PSNVAPR",PSSNIEN,101)
- +14 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,102))'=""
- SET PSSHTD=^TMP($JOB,"PSNVAPR",PSSNIEN,102)
- +15 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,103))'=""
- SET PSSPEPAC=^TMP($JOB,"PSNVAPR",PSSNIEN,103)
- +16 if $GET(^TMP($JOB,"PSNVAPR",PSSNIEN,104))'=""
- SET PSSWSC=^TMP($JOB,"PSNVAPR",PSSNIEN,104)
- +17 SET HAZWCNT2=1
- SET HAZWCNT=0
- SET DIWL=1
- SET DIWR=50
- +18 FOR
- SET HAZWCNT=$ORDER(^TMP($JOB,"PSNVAPR",PSSNIEN,105,HAZWCNT))
- if 'HAZWCNT
- QUIT
- Begin DoDot:2
- +19 SET X=""
- SET X=^TMP($JOB,"PSNVAPR",PSSNIEN,105,HAZWCNT)
- SET PSSDOTSN(HAZWCNT)=X
- End DoDot:2
- End DoDot:1
- +20 QUIT
- IT SET CMOPID=$PIECE(X,"^",2)
- +1 QUIT
- NDF1 SET X=$$PSJDF^PSNAPIS(DA,K)
- SET VADF=$PIECE(X,"^",2)
- +1 QUIT
- INACT SET ACT=""
- IF $DATA(^PSDRUG(IFN,"I"))
- SET Y=$PIECE(^PSDRUG(IFN,"I"),"^",1)
- XECUTE ^DD("DD")
- SET ACT=Y
- +1 QUIT
- GETDATA SET NODE0=^PSDRUG(IFN,0)
- SET GN=$PIECE(NODE0,"^",1)
- SET CL=$PIECE(NODE0,"^",2)
- SET DEA=$PIECE(NODE0,"^",3)
- SET WRN=$PIECE(NODE0,"^",8)
- SET NF=$PIECE(NODE0,"^",9)
- SET MESS=$PIECE(NODE0,"^",10)
- SET VNF=$PIECE(NODE0,"^",11)
- SET CLASS=""
- SET WARN=""
- if NF=1
- SET NF="N/F"
- if VNF=1
- SET VNF="V-N/F"
- +1 SET PSSNODE=$GET(^PSDRUG(IFN,"DOS"))
- +2 IF CL'=""
- IF $GET(CLPTR)'=""
- SET CLASS=CL_" "_$PIECE(^PS(50.605,CLPTR,0),"^",2)
- +3 SET PSSX=$QUERY(^PSDRUG(IFN,950))
- SET PSSMAX=$PIECE(@PSSX,"^",3)
- +4 DO GETS^DIQ(50.095,PSSMAX_","_IFN_",","*","E","PSSDAT","PSSERR")
- +5 SET PSSDT=$GET(PSSDAT(50.095,PSSMAX_","_IFN_",",.01,"E"))
- +6 SET PSSUSR=$GET(PSSDAT(50.095,PSSMAX_","_IFN_",",1,"E"))
- +7 SET PSSVAL=$GET(PSSDAT(50.095,PSSMAX_","_IFN_",",3,"E"))
- +8 IF $DATA(^PSDRUG(IFN,3))
- if $PIECE(^PSDRUG(IFN,3),"^")=0
- SET CMOP="NO"
- if $PIECE(^PSDRUG(IFN,3),"^")=1
- SET CMOP="YES"
- +9 IF $DATA(^PSDRUG(IFN,5))
- SET QDM=^PSDRUG(IFN,5)
- +10 SET OINM=""
- SET NDC=""
- IF $DATA(^PSDRUG(IFN,2))
- SET NODE2=^PSDRUG(IFN,2)
- if $PIECE(NODE2,"^",1)]""
- SET OIPTR=$PIECE(NODE2,"^",1)
- SET NDC=$PIECE(NODE2,"^",4)
- if $PIECE(NODE2,"^",6)]""
- SET PDPTR=$PIECE(NODE2,"^",6)
- SET APP=$PIECE(NODE2,"^",3)
- SET FM=""
- DO TWOA
- +11 QUIT
- TWOA IF $DATA(OIPTR)
- SET OI=$PIECE(^PS(50.7,OIPTR,0),"^",1)
- SET DFPTR=$PIECE(^PS(50.7,OIPTR,0),"^",2)
- SET DF=$PIECE(^PS(50.606,DFPTR,0),"^",1)
- SET FMS=$PIECE(^PS(50.7,OIPTR,0),"^",12)
- if FMS]""
- SET FM=" (N/F)"
- SET OINM=OI_" "_DF_FM
- +1 ;I $D(PDPTR) S PD=$P(^PS(50.3,PDPTR,0),"^",1)
- +2 QUIT
- NOD66 SET (DUPOU,PPDU,PPOU,DU,SS)=""
- IF $DATA(^PSDRUG(IFN,660))
- SET NDE=^PSDRUG(IFN,660)
- SET OUPTR=$PIECE(NDE,"^",2)
- SET PPOU=$PIECE(NDE,"^",3)
- SET DUPOU=$PIECE(NDE,"^",5)
- SET PPDU=$PIECE(NDE,"^",6)
- SET SS=$PIECE(NDE,"^",7)
- SET DU=$PIECE(NDE,"^",8)
- IF OUPTR]""
- SET OU=$PIECE(^DIC(51.5,OUPTR,0),"^")
- +1 QUIT
- SYN IF $DATA(^PSDRUG(IFN,1,0))
- FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PSDRUG(IFN,1,ZZZ))
- if 'ZZZ
- QUIT
- SET SYNM=$PIECE(^PSDRUG(IFN,1,ZZZ,0),"^",1)
- SET INT=$PIECE(^PSDRUG(IFN,1,ZZZ,0),"^",3)
- DO SYN1
- +1 QUIT
- SYN1 SET INT=$SELECT(INT=0:"Trade Name",INT=1:"Quick Code",INT="C":"Ctrl Substances",INT="D":"Drug Accountability",1:"")
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE ?14,SYNM,?55,INT,!
- +1 QUIT
- SYN2 if INT=0
- SET INT="Trade"
- if INT=1
- SET INT="Quick"
- if INT="C"
- SET INT="Ctrl Subs"
- if INT="D"
- SET INT="Drug Acct"
- WRITE ?16,SYNM,?57,INT,!
- +1 QUIT
- IFCAP IF $DATA(^PSDRUG(IFN,441,0))
- FOR QQQ=0:0
- SET QQQ=$ORDER(^PSDRUG(IFN,441,QQQ))
- if 'QQQ
- QUIT
- SET IFCAPNM=$PIECE(^PSDRUG(IFN,441,QQQ,0),"^",1)
- +1 QUIT
- FORMAT ; BEGIN WRITING
- +1 NEW DAW,NOONEVA
- +2 WRITE @IOF,"DRUG NAME: ",GN," (IEN: ",IFN,")",!
- +3 FOR XX=1:1:77
- WRITE "="
- +4 WRITE !
- +5 if $DATA(VAPRN)
- WRITE "VA PRINT NAME: ",?17,VAPRN
- if $DATA(CMOPID)
- WRITE ?60,"CMOP ID#: ",CMOPID
- if $DATA(VAPN)
- WRITE !,"VA PRODUCT NAME: ",?17,VAPN
- +6 IF $LENGTH($GET(VAPN))>42
- WRITE !
- +7 if $DATA(CMOP)
- WRITE ?60,"CMOP DISPENSE: ",CMOP
- +8 if $DATA(OINM)
- WRITE !,"ORDERABLE ITEM: ",?17,OINM
- +9 IF $LENGTH($GET(OINM))>42
- WRITE !
- +10 if $DATA(VAPN)
- WRITE ?60,"NDF DF: ",VADF
- +11 IF $DATA(OIPTR)
- IF OIPTR]""
- WRITE !,"ORDERABLE ITEM TEXT: ",!
- DO OITXT
- +12 if $DATA(PD)
- WRITE !,"PRIMARY DRUG: ",?17,PD
- +13 WRITE !,"SYNONYM(S): "
- DO SYN
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"MESSAGE: ",MESS,!
- +14 DO FULL
- if $GET(QUIT)
- QUIT
- FOR XX=1:1:77
- WRITE "-"
- +15 WRITE !
- +16 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE "DEA, SPECIAL HDLG: ",DEA,?48,"NDC: ",?63,NDC
- +17 SET DAW=$$GET1^DIQ(50,IFN,81)
- +18 IF DAW=""
- SET DAW=0
- +19 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"DAW CODE: ",DAW," - ",$$DAWEXT^PSSDAWUT(DAW)
- +20 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"CS FEDERAL SCHEDULE: ",$GET(CSF),?39
- +21 SET NOONEVA=$$GET1^DIQ(50,IFN,907)
- +22 IF NOONEVA'=""
- WRITE ?39,"RESTRICT FOR ONEVA PHARMACY: ",NOONEVA
- +23 ;
- +24 ;Hazardous Waste
- +25 WRITE !
- +26 SET PSSHTDX=0
- +27 IF $GET(PSSHTD)=1
- SET PSSHTDX=1
- +28 DO FULL
- if $GET(QUIT)
- QUIT
- if $GET(PSSHTH)'=""
- WRITE !,"Hazardous to Handle: ",$SELECT(PSSHTH=1:"YES",PSSHTH=0:"NO",1:"")
- +29 DO FULL
- if $GET(QUIT)
- QUIT
- if $GET(PSSHTD)'=""
- WRITE !,"Hazardous to Dispose: ",$SELECT(PSSHTD=1:"YES",PSSHTD=0:"NO",1:"")
- +30 IF $GET(PSSPEPAC)'=""&(PSSHTDX)
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," Primary EPA Code: ",PSSPEPAC
- +31 IF $GET(PSSWSC)'=""&(PSSHTDX)
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," Waste Sort Code: ",PSSWSC
- +32 ;
- +33 NEW HAZWCNT,HAZWCNT2,X,DIWL,DIWR,DIWF
- +34 KILL ^UTILITY($JOB,"W")
- +35 SET HAZWCNT=0
- SET HAZWCNT2=1
- SET HAZWCNT=0
- SET DIWL=1
- SET DIWR=50
- +36 FOR
- SET HAZWCNT=$ORDER(PSSDOTSN(HAZWCNT))
- if HAZWCNT=""
- QUIT
- SET X=PSSDOTSN(HAZWCNT)
- DO ^DIWP
- +37 SET HAZWCNT=0
- FOR
- SET HAZWCNT=$ORDER(^UTILITY($JOB,"W",DIWL,HAZWCNT))
- if 'HAZWCNT
- QUIT
- Begin DoDot:1
- +38 DO FULL
- if $GET(QUIT)
- QUIT
- +39 IF HAZWCNT2=1
- WRITE !," DOT Shipping Name: "
- +40 IF HAZWCNT2>1
- WRITE !," "
- +41 WRITE $GET(^UTILITY($JOB,"W",DIWL,HAZWCNT,0))
- SET HAZWCNT2=2
- End DoDot:1
- +42 KILL ^UTILITY($JOB,"W")
- +43 ;I $G(PSSDOTSN)'=""&(PSSHTDX) D FULL Q:$G(QUIT) W !," DOT Shipping Name: ",PSSDOTSN
- +44 WRITE !
- +45 ;
- +46 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"INACTIVE DATE: ",ACT
- +47 DO FULL
- if $GET(QUIT)
- QUIT
- if $DATA(QDM)
- WRITE !,"QUANTITY DISPENSE MESSAGE: ",QDM,!
- +48 DO FULL
- if $GET(QUIT)
- QUIT
- IF WRN]""
- WRITE !,"WARNING LABEL: "
- SET X=WRN
- FOR Z0=1:1
- if $PIECE(X,",",Z0,99)=""
- QUIT
- SET Z1=$PIECE(X,",",Z0)
- if $DATA(^PS(54,Z1,0))
- WRITE ?19,$PIECE(^(0),"^",1),!
- IF '$DATA(^(0))
- WRITE ?19,"NO SUCH WARNING LABEL"
- KILL X
- QUIT
- +49 DO FULL
- if $GET(QUIT)
- QUIT
- SET PSSLOOK=1
- Begin DoDot:1
- +50 NEW DRUG,PSSWSITE
- +51 IF $PIECE($GET(^PSDRUG(IFN,0)),"^")=""
- KILL PSSLOOK
- QUIT
- +52 SET PSSWSITE=+$ORDER(^PS(59.7,0))
- WRITE !,"WARNING LABEL SOURCE is "
- Begin DoDot:2
- +53 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",9)="N"
- WRITE "set to 'NEW'"
- QUIT
- +54 WRITE "not set to 'NEW'"
- End DoDot:2
- +55 KILL PSSWRN
- +56 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"NEW WARNING LABEL:"
- +57 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(IFN,0),"^"))=""
- DO EN^PSSWRNE(.QUIT)
- +58 KILL PSSLOOK,^TMP("PSSWRNB",$JOB),PSSWRN
- End DoDot:1
- +59 DO FULL
- if $GET(QUIT)
- QUIT
- if '$DATA(QDM)
- WRITE !
- +60 WRITE !
- FOR XX=1:1:77
- WRITE "-"
- +61 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !
- +62 WRITE "ORDER UNIT: ",?27
- if $DATA(OU)
- WRITE OU
- WRITE ?40,"PRICE/ORDER UNIT: ",?67,PPOU
- +63 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"DISPENSE UNIT: ",?27,DU
- if $DATA(VADU)
- WRITE ?40,"VA DISPENSE UNIT: ",?67,VADU
- +64 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"DISPENSE UNITS/ORDER UNIT: ",?21,DUPOU,?40,"PRICE/DISPENSE UNIT: ",?67,PPDU
- +65 if $GET(PSSVAL)]""
- Begin DoDot:1
- +66 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"DATE PRICE/DISPENSE UNIT LAST CHANGED: ",?27,PSSDT
- +67 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"BY: ",PSSUSR,?27,"VALUE: ",PSSVAL
- End DoDot:1
- +68 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"NCPDP DISPENSE UNIT: ",$$GET1^DIQ(50,IFN,82),?40,"NCPDP QUANTITY MULTIPLIER: ",?67,$JUSTIFY($$GET1^DIQ(50,IFN,83),10,5)
- +69 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"MAXIMUM DAYS SUPPLY: ",$$GET1^DIQ(50,IFN,66)
- +70 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"ePharmacy Billable: ",$$GET1^DIQ(50,IFN,84)
- +71 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !?2,"ePharmacy Billable (TRICARE): ",$$GET1^DIQ(50,IFN,85)
- WRITE ?40,"ePharmacy Billable (CHAMPVA): ",$$GET1^DIQ(50,IFN,86)
- +72 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"Sensitive Diagnosis Drug: ",$$GET1^DIQ(50,IFN,87)
- WRITE !
- +73 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"APPL PKG USE:"
- SET APPL=""
- if '$DATA(APP)
- SET APPL=" NONE"
- +74 IF $DATA(APP)
- Begin DoDot:1
- +75 if APP["O"
- SET APPL=APPL_" Outpatient"
- if APP["U"
- SET APPL=APPL_" Unit Dose"
- +76 if APP["I"
- SET APPL=APPL_" IV"
- if APP["W"
- SET APPL=APPL_" Ward Stock"
- +77 if APP["N"
- SET APPL=APPL_" Control Subs"
- if APP["X"
- SET APPL=APPL_" Non-VA Med"
- +78 if APPL=""
- SET APPL=" NONE"
- End DoDot:1
- +79 WRITE ?13,APPL
- +80 IF $PIECE(PSSNODE,"^",2)
- SET (PSSCALC,PSSUNIT)=$PIECE($GET(^PS(50.607,+$PIECE(PSSNODE,U,2),0)),U)
- SET PSSSTR=$PIECE(PSSNODE,"^")
- +81 IF $GET(PSSUNIT)'=""
- IF $GET(PSSUNIT)["/"
- DO UNCALC
- +82 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"STRENGTH: ",$SELECT($EXTRACT($PIECE(PSSNODE,U),1)=".":"0",1:"")_$PIECE(PSSNODE,U),?35,"UNIT: ",$GET(PSSCALC)
- +83 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"POSSIBLE DOSAGES:"
- +84 IF $DATA(^PSDRUG(IFN,"DOS1",0))
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(IFN,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:1
- +85 SET POSDOS=^PSDRUG(IFN,"DOS1",PDS,0)
- +86 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," DISPENSE UNITS PER DOSE: ",$SELECT($EXTRACT($PIECE(POSDOS,U),1)=".":"0",1:"")_$PIECE(POSDOS,U),?40,"DOSE: ",$SELECT($EXTRACT($PIECE(POSDOS,U,2),1)=".":"0",1:"")_$PIECE(POSDOS,U,2),?55,"PACKAGE: ",$PIECE(POSDOS,U,3)
- +87 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," BCMA UNITS PER DOSE: ",$PIECE(POSDOS,U,4)
- End DoDot:1
- +88 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"LOCAL POSSIBLE DOSAGES:"
- +89 IF $DATA(^PSDRUG(IFN,"DOS2",0))
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(IFN,"DOS2",PDS))
- if 'PDS
- QUIT
- Begin DoDot:1
- +90 SET LPDOS=^PSDRUG(IFN,"DOS2",PDS,0)
- +91 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," LOCAL POSSIBLE DOSAGE: "
- Begin DoDot:2
- +92 IF $LENGTH($PIECE(LPDOS,U))'>27
- WRITE $PIECE(LPDOS,U),?55,"PACKAGE: ",$PIECE(LPDOS,U,2)
- +93 IF '$TEST
- WRITE !,?10,$PIECE(LPDOS,U),!,?55,"PACKAGE: ",$PIECE(LPDOS,U,2)
- +94 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !," BCMA UNITS PER DOSE: ",$PIECE(LPDOS,U,3)
- DO FULL
- if $GET(QUIT)
- QUIT
- DO LPDNW
- End DoDot:2
- End DoDot:1
- +95 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !
- FOR XX=1:1:77
- WRITE "-"
- +96 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"VA CLASS: ",$GET(CLASS)
- +97 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"LOCAL NON-FORMULARY: ",$GET(NF)," ","VISN NON-FORMULARY: ",$GET(VNF)
- +98 NEW DA,K,LIST,PSXDN,PSXGN,X,XX1,XX2
- +99 KILL PSXGN,PSXVP
- IF $DATA(^PSDRUG(IFN,"ND"))
- SET PSXDN=$GET(^PSDRUG(IFN,"ND"))
- SET PSXGN=$PIECE(PSXDN,"^")
- SET PSXVP=$PIECE(PSXDN,"^",3)
- +100 IF $GET(PSXGN)
- IF $GET(PSXVP)
- SET X=$$PROD2^PSNAPIS(PSXGN,PSXVP)
- SET XX1=$$FORMI^PSNAPIS(PSXGN,PSXVP)
- +101 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"National Formulary Indicator: "_$SELECT($GET(XX1)=1:"YES",$GET(XX1)=0:"NO",1:"Not Matched to NDF")
- +102 ;PPSN
- IF $GET(PSXVP)
- DO FD^PSNACT(PSXVP)
- +103 IF $DATA(^PSDRUG(IFN,65,0))
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,"FORMULARY ALTERNATIVES: ",!
- FOR FA=0:0
- SET FA=$ORDER(^PSDRUG(IFN,65,FA))
- if 'FA
- QUIT
- SET LDFPTR=$PIECE($GET(^PSDRUG(IFN,65,FA,0)),"^")
- IF LDFPTR
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE ?26,$PIECE($GET(^PSDRUG(LDFPTR,0)),"^"),!
- +104 NEW CPDATE,PSSTIER
- DO NOW^%DTC
- SET CPDATE=$PIECE(%,".")
- SET PSSTIER=$$CPTIER^PSNAPIS($PIECE($GET(^PSDRUG(IFN,"ND")),"^",3),CPDATE,IFN,1)
- KILL CPDATE,%
- +105 ; PSSTIER = Copay Tier^Effective Date^End Date
- +106 WRITE !,"Copay Tier: ",$PIECE(PSSTIER,"^",1)
- +107 WRITE !,"Copay Effective Date: "
- SET Y=$PIECE(PSSTIER,"^",2)
- DO DD^%DT
- WRITE Y
- KILL Y
- +108 DO FULL
- if $GET(QUIT)
- QUIT
- IF $GET(PSXGN)
- IF $GET(PSXVP)
- WRITE !,"National Restriction: "
- SET XX2=$$FORMRX^PSNAPIS(PSXGN,PSXVP,.LIST)
- IF $GET(XX2)=1
- IF $DATA(LIST)
- FOR XX2=0:0
- SET XX2=$ORDER(LIST(XX2))
- if 'XX2
- QUIT
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !,LIST(XX2,0)
- +109 ;PPSN
- IF $GET(PSXVP)
- DO FDT^PSNACT(PSXVP)
- +110 WRITE !,"Local Drug Text: ",!
- IF $DATA(^PSDRUG(IFN,9,0))
- DO LDT
- +111 QUIT
- LDT FOR TXT1=0:0
- SET TXT1=$ORDER(^PSDRUG(IFN,9,TXT1))
- if 'TXT1
- QUIT
- SET TEXPTR=^PSDRUG(IFN,9,TXT1,0)
- FOR PPP=0:0
- SET PPP=$ORDER(^PS(51.7,TEXPTR,2,PPP))
- if 'PPP
- QUIT
- SET PST=$PIECE($GET(^PS(51.7,TEXPTR,0)),"^",2)
- IF 'PST
- SET WPT=^PS(51.7,TEXPTR,2,PPP,0)
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE WPT,!
- +1 ;
- +2 ;
- KILL KILL IFN,APP,INT,VADU,VAGN,VAPN,VAPRN,P3,VAGNPTR,MESS,CLASS,DEA,ACT,CL,CLPTR,CMOP,DF,DFPTR,DU,DUPOUGN,IFCAPNM,NDC,NDE,NDNODE,NF,NODE0,NODE2,OI,OINM,OIPTR,OU,PD,PDPTR,PPDU,PPOU,PS,PT,NOD66,SYNM,SZPTR,TYPTR,WARN,WRN,XX,ZZZ,SS,OUPTR,CMOPID
- +1 KILL DUPOU,QQQ,GN,QDM,APPL,VADF,DFP,DFRM,Y,Z0,Z1,DDD,PPP,TEXT,TXTPTR,TXT,TXT1,TEXPTR,VNF,WPT,FA,LDFPTR,TEXTPTR,QUIT,PST,D0,DA,K,DIR
- +2 KILL PSSNODE,PSDOSUN,PDS,POSDOS,LPDOS,CSF,PSSSTR,PSSUNIT,PSSCALC,PSSTIER
- +3 KILL ^TMP($JOB,"PSNVAPR")
- +4 KILL PSSWSC,PSSNIEN,PSSHTH,PSSHTD,PSSPEPAC,PSSDOTSN,PSSCLEF,PSSPKG,PSSOMIT,PSSEXLMT,PSSHTDX,PSSII,PSSIII
- +5 QUIT
- OITXT IF $DATA(^PS(50.7,OIPTR,1,0))
- FOR TXT=0:0
- SET TXT=$ORDER(^PS(50.7,OIPTR,1,TXT))
- if 'TXT
- QUIT
- SET TEXTPTR=^PS(50.7,OIPTR,1,TXT,0)
- FOR DDD=0:0
- SET DDD=$ORDER(^PS(51.7,TEXTPTR,2,DDD))
- if 'DDD
- QUIT
- DO IDATE
- IF 'Y2K
- SET TEXT=^PS(51.7,TEXTPTR,2,DDD,0)
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE TEXT,!
- +1 QUIT
- FULL if ($Y+5)>IOSL&('$GET(QUIT))
- DO FSCRN
- +1 QUIT
- FSCRN if $GET(QUIT)
- QUIT
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue,'^' to exit"
- DO ^DIR
- WRITE @IOF
- if Y'=1
- SET QUIT=1
- +1 QUIT
- IDATE SET Y2K=$PIECE($GET(^PS(51.7,TEXTPTR,0)),"^",2)
- +1 QUIT
- UNCALC ;
- +1 NEW PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH5
- KILL PSSCALC
- +2 SET PSSDASH=0
- SET PSSNDFS=$$PSJST^PSNAPIS(+$PIECE($GET(^PSDRUG(IFN,"ND")),"^"),+$PIECE($GET(^PSDRUG(IFN,"ND")),"^",3))
- SET PSSNDFS=+$PIECE($GET(PSSNDFS),"^",2)
- +3 IF $GET(PSSNDFS)
- IF $GET(PSSSTR)
- IF +$GET(PSSSTR)'=+$GET(PSSNDFS)
- SET PSSDASH=1
- +4 SET PSSVA=$PIECE(PSSUNIT,"/")
- SET PSSVB=$PIECE(PSSUNIT,"/",2)
- SET PSSVA1=+$GET(PSSVA)
- SET PSSVB1=+$GET(PSSVB)
- +5 IF $GET(PSSDASH)
- SET PSSDASH2=PSSSTR/PSSNDFS
- SET PSSDASH3=PSSDASH2*$SELECT($GET(PSSVB1):PSSVB1,1:1)
- SET PSSDASH5=$SELECT('$GET(PSSVB1):PSSDASH3_$GET(PSSVB),1:PSSDASH3_$PIECE(PSSVB,PSSVB1,2))
- +6 SET PSSCALC=$SELECT($GET(PSSDASH):$SELECT('$GET(PSSVA1):PSSVA,1:$PIECE(PSSVA1,PSSVA1,2))_"/"_$GET(PSSDASH5),1:PSSUNIT)
- +7 QUIT
- +8 ;
- LPDNW ;Display Dose Unit and Numeric Dose fields, added with patch PSS*1*147
- +1 NEW PSSLKL1,PSSLKL2,PSSLKL3,PSSLKL4
- +2 SET PSSLKL4=""
- +3 SET PSSLKL1=$PIECE(LPDOS,"^",5)
- SET PSSLKL2=$PIECE(LPDOS,"^",6)
- +4 IF PSSLKL1
- SET PSSLKL4=$PIECE($GET(^PS(51.24,+PSSLKL1,0)),"^")
- +5 SET PSSLKL3=$SELECT($EXTRACT(PSSLKL2)=".":"0",1:"")_PSSLKL2
- +6 IF $LENGTH(PSSLKL3)<18
- DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !?5,"NUMERIC DOSE: "_PSSLKL3,?38,"DOSE UNIT: "_PSSLKL4
- QUIT
- +7 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !?5,"NUMERIC DOSE: "_PSSLKL3
- +8 DO FULL
- if $GET(QUIT)
- QUIT
- WRITE !?38,"DOSE UNIT: "_PSSLKL4
- +9 QUIT