PSSLOOK ;BIR/WRT-Drug file lookup ;02/03/00
;;1.0;PHARMACY DATA MANAGEMENT;**3,7,15,16,20,24,29,38,68,61,87,90,127,147**;9/30/97;Build 16
;
;Reference to ^PS(50.605 supported by DBIA #2138
;Reference to ^PS(50.608 supported by DBIA #2136
;Reference to ^PS(50.609 supported by DBIA #2137
;Reference to ^PS(50.607 supported by DBIA #2221
;Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) supported by DBIA #2574
;Reference to $$FORMI^PSNAPIS(P1,P3) supported by DBIA #2574
;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$PSJST^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$VAGN^PSNAPIS(P1) supported by DBIA #2531
;Reference to ^PSNDF(50.68 supported by DBIA 3735
;
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)="QEAMN" 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")
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]"" S CLASS=CL_" "_$P(^PS(50.605,CLPTR,0),"^",2)
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
W @IOF,?21,GN,!
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 W:$D(CMOP) ?60,"CMOP DISPENSE: ",CMOP
W:$D(OINM) !,"ORDERABLE ITEM: ",?17,OINM 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)
D FULL Q:$G(QUIT) W !,"DAW CODE: ",DAW," - ",$$DAWEXT^PSSDAWUT(DAW)
D FULL Q:$G(QUIT) W !,"CS FEDERAL SCHEDULE: ",$G(CSF)
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
.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 ^PSSWRNE
.K PSSLOOK,^TMP("PSSWRNB",$J),PSSWRN
D FULL Q:$G(QUIT) W:'$D(QDM) ! 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 FULL Q:$G(QUIT) W !,"NCPDP DISPENSE UNIT: ",$$GET1^DIQ(50,IFN,82),?40,"NCPDP QUANTITY MULTIPLIER: ",?67,$J($$GET1^DIQ(50,IFN,83),8,3)
D FULL Q:$G(QUIT) W !,"APPL PKG USE:" D PACK
Q
PACK 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,PSXVP,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 $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)),"^"),!
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)
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
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
PSSLOOK ;BIR/WRT-Drug file lookup ;02/03/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**3,7,15,16,20,24,29,38,68,61,87,90,127,147**;9/30/97;Build 16
+2 ;
+3 ;Reference to ^PS(50.605 supported by DBIA #2138
+4 ;Reference to ^PS(50.608 supported by DBIA #2136
+5 ;Reference to ^PS(50.609 supported by DBIA #2137
+6 ;Reference to ^PS(50.607 supported by DBIA #2221
+7 ;Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) supported by DBIA #2574
+8 ;Reference to $$FORMI^PSNAPIS(P1,P3) supported by DBIA #2574
+9 ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
+10 ;Reference to $$PSJST^PSNAPIS(P1,P3) supported by DBIA #2531
+11 ;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
+12 ;Reference to $$VAGN^PSNAPIS(P1) supported by DBIA #2531
+13 ;Reference to ^PSNDF(50.68 supported by DBIA 3735
+14 ;
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)="QEAMN"
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 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]""
SET CLASS=CL_" "_$PIECE(^PS(50.605,CLPTR,0),"^",2)
+3 IF $DATA(^PSDRUG(IFN,3))
IF $PIECE(^PSDRUG(IFN,3),"^")=0
SET CMOP="NO"
IF $PIECE(^PSDRUG(IFN,3),"^")=1
SET CMOP="YES"
+4 IF $DATA(^PSDRUG(IFN,5))
SET QDM=^PSDRUG(IFN,5)
+5 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
+6 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
+2 WRITE @IOF,?21,GN,!
+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
IF $DATA(CMOP)
WRITE ?60,"CMOP DISPENSE: ",CMOP
+6 IF $DATA(OINM)
WRITE !,"ORDERABLE ITEM: ",?17,OINM
IF $DATA(VAPN)
WRITE ?60,"NDF DF: ",VADF
+7 IF $DATA(OIPTR)
IF OIPTR]""
WRITE !,"ORDERABLE ITEM TEXT: ",!
DO OITXT
+8 IF $DATA(PD)
WRITE !,"PRIMARY DRUG: ",?17,PD
+9 WRITE !,"SYNONYM(S): "
DO SYN
DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"MESSAGE: ",MESS,!
+10 DO FULL
IF $GET(QUIT)
QUIT
FOR XX=1:1:77
WRITE "-"
+11 WRITE !
+12 DO FULL
IF $GET(QUIT)
QUIT
WRITE "DEA, SPECIAL HDLG: ",DEA,?48,"NDC: ",?63,NDC
+13 SET DAW=+$$GET1^DIQ(50,IFN,81)
+14 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"DAW CODE: ",DAW," - ",$$DAWEXT^PSSDAWUT(DAW)
+15 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"CS FEDERAL SCHEDULE: ",$GET(CSF)
+16 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"INACTIVE DATE: ",ACT
+17 DO FULL
IF $GET(QUIT)
QUIT
IF $DATA(QDM)
WRITE !,"QUANTITY DISPENSE MESSAGE: ",QDM,!
+18 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
+19 DO FULL
IF $GET(QUIT)
QUIT
SET PSSLOOK=1
Begin DoDot:1
+20 NEW DRUG
+21 IF $PIECE($GET(^PSDRUG(IFN,0)),"^")=""
KILL PSSLOOK
QUIT
+22 SET PSSWSITE=+$ORDER(^PS(59.7,0))
WRITE !,"WARNING LABEL SOURCE is "
Begin DoDot:2
+23 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",9)="N"
WRITE "set to 'NEW'"
QUIT
+24 WRITE "not set to 'NEW'"
End DoDot:2
+25 KILL PSSWRN
+26 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"NEW WARNING LABEL:"
+27 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(IFN,0),"^"))=""
DO ^PSSWRNE
+28 KILL PSSLOOK,^TMP("PSSWRNB",$JOB),PSSWRN
End DoDot:1
+29 DO FULL
IF $GET(QUIT)
QUIT
IF '$DATA(QDM)
WRITE !
FOR XX=1:1:77
WRITE "-"
+30 DO FULL
IF $GET(QUIT)
QUIT
WRITE !
+31 WRITE "ORDER UNIT: ",?27
IF $DATA(OU)
WRITE OU
WRITE ?40,"PRICE/ORDER UNIT: ",?67,PPOU
+32 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"DISPENSE UNIT: ",?27,DU
IF $DATA(VADU)
WRITE ?40,"VA DISPENSE UNIT: ",?67,VADU
+33 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"DISPENSE UNITS/ORDER UNIT: ",?21,DUPOU,?40,"PRICE/DISPENSE UNIT: ",?67,PPDU
+34 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),8,3)
+35 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"APPL PKG USE:"
DO PACK
+36 QUIT
PACK SET APPL=""
IF '$DATA(APP)
SET APPL=" NONE"
+1 IF $DATA(APP)
Begin DoDot:1
+2 IF APP["O"
SET APPL=APPL_" Outpatient"
IF APP["U"
SET APPL=APPL_" Unit Dose"
+3 IF APP["I"
SET APPL=APPL_" IV"
IF APP["W"
SET APPL=APPL_" Ward Stock"
+4 IF APP["N"
SET APPL=APPL_" Control Subs"
IF APP["X"
SET APPL=APPL_" Non-VA Med"
+5 IF APPL=""
SET APPL=" NONE"
End DoDot:1
+6 WRITE ?13,APPL
+7 IF $PIECE(PSSNODE,"^",2)
SET (PSSCALC,PSSUNIT)=$PIECE($GET(^PS(50.607,+$PIECE(PSSNODE,U,2),0)),U)
SET PSSSTR=$PIECE(PSSNODE,"^")
+8 IF $GET(PSSUNIT)'=""
IF $GET(PSSUNIT)["/"
DO UNCALC
+9 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"STRENGTH: ",$SELECT($EXTRACT($PIECE(PSSNODE,U),1)=".":"0",1:"")_$PIECE(PSSNODE,U),?35,"UNIT: ",$GET(PSSCALC)
+10 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"POSSIBLE DOSAGES:"
+11 IF $DATA(^PSDRUG(IFN,"DOS1",0))
FOR PDS=0:0
SET PDS=$ORDER(^PSDRUG(IFN,"DOS1",PDS))
IF 'PDS
QUIT
Begin DoDot:1
+12 SET POSDOS=^PSDRUG(IFN,"DOS1",PDS,0)
+13 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)
+14 DO FULL
IF $GET(QUIT)
QUIT
WRITE !," BCMA UNITS PER DOSE: ",$PIECE(POSDOS,U,4)
End DoDot:1
+15 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"LOCAL POSSIBLE DOSAGES:"
+16 IF $DATA(^PSDRUG(IFN,"DOS2",0))
FOR PDS=0:0
SET PDS=$ORDER(^PSDRUG(IFN,"DOS2",PDS))
IF 'PDS
QUIT
Begin DoDot:1
+17 SET LPDOS=^PSDRUG(IFN,"DOS2",PDS,0)
+18 DO FULL
IF $GET(QUIT)
QUIT
WRITE !," LOCAL POSSIBLE DOSAGE: "
Begin DoDot:2
+19 IF $LENGTH($PIECE(LPDOS,U))'>27
WRITE $PIECE(LPDOS,U),?55,"PACKAGE: ",$PIECE(LPDOS,U,2)
+20 IF '$TEST
WRITE !,?10,$PIECE(LPDOS,U),!,?55,"PACKAGE: ",$PIECE(LPDOS,U,2)
+21 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
+22 DO FULL
IF $GET(QUIT)
QUIT
WRITE !
FOR XX=1:1:77
WRITE "-"
+23 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"VA CLASS: ",$GET(CLASS)
+24 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"LOCAL NON-FORMULARY: ",$GET(NF)," ","VISN NON-FORMULARY: ",$GET(VNF)
+25 NEW DA,K,LIST,PSXDN,PSXGN,PSXVP,X,XX1,XX2
+26 KILL PSXGN,PSXVP
IF $DATA(^PSDRUG(IFN,"ND"))
SET PSXDN=$GET(^PSDRUG(IFN,"ND"))
SET PSXGN=$PIECE(PSXDN,"^")
SET PSXVP=$PIECE(PSXDN,"^",3)
+27 IF $GET(PSXGN)
IF $GET(PSXVP)
SET X=$$PROD2^PSNAPIS(PSXGN,PSXVP)
SET XX1=$$FORMI^PSNAPIS(PSXGN,PSXVP)
+28 DO FULL
IF $GET(QUIT)
QUIT
WRITE !,"National Formulary Indicator: "_$SELECT($GET(XX1)=1:"YES",$GET(XX1)=0:"NO",1:"Not Matched to NDF")
+29 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)),"^"),!
+30 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)
+31 WRITE !,"Local Drug Text: ",!
IF $DATA(^PSDRUG(IFN,9,0))
DO LDT
+32 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
+3 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
