PSNLOOK ;BIR/WRT-Look up into drug file ; 06/19/03 15:00
;;4.0;NATIONAL DRUG FILE;**2,3,5,11,22,27,62,70,169,262,296,429,492,396**; 30 Oct 98;Build 190
;
; Reference to ^PSDRUG supported by DBIA# 2192
; Reference to ^PS(50.606 supported by DBIA# 2174
; Reference to ^PSNAPIS supported by DBIA #2531
;
;USE PSNLK*
BEGIN ;
D ASK
N PSNLKDA,PSNLKIND,PSNLKCL,PSNLKNOD,PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR,PSNLKDAV,PSNLKGK,PSNLKPMI,PSNLKQQ
N DIC,X,Y,DLAYGO,DTOUT,DUOUT,DIR,DIRUT,DIROUT,%DT,PSNLKMAP,PSNLKENG,PSNLKDF,PSNLKSTR,PSNLKUN,PSNLKFRM
N PSNLKUNT,PSNLKNFN,PSNLKBB,PSNLKAND,PSNLKGR,PSNLKIST,PSNLKIUT,PSNLKSEV,PSNLKCSF,PSNLKSP,PSNLKNND,PSNLKCC
N PSNLKSCL,PSNLKZ,PSNLKRE,PSNLKWRT,PSNZZFS,PSNLKL1,PSNLKL2,PSNLKIUN,PSNZZFSA,PSNLKCP,PSNTDRUG
SELD ;Select Drug
K PSNLKDA,PSNLKIND,PSNLKCL,PSNLKNOD,PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR,PSNLKDAV,PSNLKGK,PSNLKPMI,PSNLKQQ
K DIC,X,Y,DLAYGO,DTOUT,DUOUT,DIR,DIRUT,DIROUT,%DT,PSNLKMAP,PSNLKENG,PSNLKDF,PSNLKSTR,PSNLKUN,PSNLKFRM
K PSNLKUNT,PSNLKNFN,PSNLKBB,PSNLKAND,PSNLKGR,PSNLKIST,PSNLKIUT,PSNLKSEV,PSNLKCSF,PSNLKSP,PSNLKNND,PSNLKCC
K PSNLKSCL,PSNLKZ,PSNLKRE,PSNLKWRT,PSNZZFS,PSNLKL1,PSNLKL2,PSNLKIUN,PSNZZFSA,PSNLKCP,PSNFD,PSNFDT
W ! K DIC S DIC=50,DIC(0)="QEAM",DIC("W")="S PSNTDRUG=Y D GETTIER^PSNLOOK(PSNTDRUG)" D ^DIC I Y<0!($D(DTOUT))!($D(DUOUT)) Q
S PSNLKDA=+Y K Y
S PSNLKIND=$P($G(^PSDRUG(PSNLKDA,"I")),"^") I PSNLKIND,PSNLKIND<DT S Y=PSNLKIND D DD^%DT W !!,"This drug has an Inactive date of "_$G(Y),! D MESS G SELD
D DSPLY
D HG
G SELD
;
ASK W !!,"This option will allow you to look up entries in your local DRUG file. It will",!,"display National Drug File software match information.",!
Q
DSPLY W @IOF W !?14,"DRUG Generic Name: ",$P($G(^PSDRUG(PSNLKDA,0)),"^") I $D(^PSDRUG(PSNLKDA,"ND")) S PSNLKCL=$P(^("ND"),"^",6)
I $D(^PSDRUG(PSNLKDA,"ND")),$P(^PSDRUG(PSNLKDA,"ND"),"^",2)]"" S PSNLKNOD=^PSDRUG(PSNLKDA,"ND") D DSPLY1,DSPLY2,PRODF,DSP,ING,SV,DSP1,RESTN Q
W !?8,"*** NO NATIONAL DRUG FILE INFORMATION ***",!
Q
DSPLY1 W !?5,"VA Product Name: ",$P(PSNLKNOD,"^",2)
W !?5,"VA Generic Name: ",$P($G(^PSNDF(50.6,$P(PSNLKNOD,"^"),0)),"^")
Q
DSPLY2 ;
S (PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR)=""
K X S PSNLKDAV=$P(PSNLKNOD,"^"),PSNLKGK=$P(PSNLKNOD,"^",3),X=$$PROD2^PSNAPIS(PSNLKDAV,PSNLKGK) I $P(X,"^")]"" S PSNLKVPN=$P(X,"^"),PSNLKID=$P(X,"^",2),PSNLKTR=$P(X,"^",3),PSNLKVDU=$P(X,"^",4)
K PSNLKPMI I X]"" S PSNLKQQ=$P(^PSNDF(50.68,PSNLKGK,1),"^",5) D GCN
K X
Q
GCN I PSNLKQQ']"" S PSNLKPMI="None" Q
;
GCN1 ;
I $D(^PS(50.623,"B",PSNLKQQ)) S PSNLKMAP=$O(^PS(50.623,"B",PSNLKQQ,0)),PSNLKENG=$P(^PS(50.623,PSNLKMAP,0),"^",2),PSNLKPMI=$P(^PS(50.621,+PSNLKENG,0),"^") Q
S PSNLKPMI="None"
Q
DSPLY3 W ?50,"Transmit To CMOP: "
I PSNLKTR=1 W "YES"
I PSNLKTR=0 W "NO"
Q
PRODF ;
S X=$$PROD0^PSNAPIS(PSNLKDAV,PSNLKGK)
S PSNLKDF=+$P(X,"^",2),PSNLKSTR=$P(X,"^",3),PSNLKUN=+$P(X,"^",4),PSNLKFRM=$S($G(PSNLKDF):$P($G(^PS(50.606,PSNLKDF,0)),"^"),1:""),PSNLKUNT=$S($G(PSNLKUN):$P($G(^PS(50.607,PSNLKUN,0)),"^"),1:""),PSNLKNFN=$P(^PSNDF(50.68,PSNLKGK,0),"^",6)
K X
Q
ING F PSNLKBB=0:0 S PSNLKBB=$O(^PSNDF(50.68,PSNLKGK,2,PSNLKBB)) Q:'PSNLKBB D
.I $D(^PSNDF(50.68,PSNLKGK,2,PSNLKBB,0)) S PSNLKAND=$G(^PSNDF(50.68,PSNLKGK,2,PSNLKBB,0)),PSNLKGR=$P(^PS(50.416,$P(PSNLKAND,"^",1),0),"^"),PSNLKIST=$P(PSNLKAND,"^",2),PSNLKIUT=$P(PSNLKAND,"^",3) K PSNLKIUN D ING1,IN2
Q
IN2 W ?3,PSNLKGR,?50,"Str: ",PSNLKIST W:PSNLKIUT ?65,"Unt: ",$G(PSNLKIUN) W !
Q
ING1 S:$P(^PS(50.416,$P(PSNLKAND,"^"),0),"^",2) PSNLKGR=$P($G(^PS(50.416,$P(^PS(50.416,$P(PSNLKAND,"^"),0),"^",2),0)),"^") I PSNLKIUT S PSNLKIUN=$P(^PS(50.607,PSNLKIUT,0),"^")
Q
SC I $O(^PSNDF(50.68,PSNLKGK,4,0)) W !,"Secondary Class(es): ",! F PSNLKCC=0:0 S PSNLKCC=$O(^PSNDF(50.68,PSNLKGK,4,PSNLKCC)) Q:'PSNLKCC S PSNLKZ=$P($G(^PSNDF(50.68,PSNLKGK,4,PSNLKCC,0)),"^") I PSNLKZ D
.S PSNLKSCL=$P($G(^PS(50.605,PSNLKZ,0)),"^") D SC1
Q
SC1 W " ",PSNLKSCL
Q
SV S PSNLKSEV=$G(^PSNDF(50.68,PSNLKGK,7)) I PSNLKSEV]"" S PSNLKCSF=$P(PSNLKSEV,"^"),PSNLKSP=$P(PSNLKSEV,"^",2) S:PSNLKSP="M" PSNLKSP="Multi" S:PSNLKSP="S" PSNLKSP="Single" D SV1
Q
SV1 S PSNZZFSA=PSNLKGK_"," S PSNZZFS=$$GET1^DIQ(50.68,PSNZZFSA,19) I $G(PSNZZFS)="" S PSNZZFS="None"
S PSNLKNND=$P(^PSNDF(50.68,PSNLKGK,7),"^",3)
Q
DSP W !,"Dosage Form: ",PSNLKFRM_$S('$G(PSNLKDF):"",$P($G(^PS(50.606,PSNLKDF,1)),"^")=1:" (Exclude from Dosing Cks)",1:"")
S PSNLKL1=$L(PSNLKSTR),PSNLKL2=$S($G(PSNLKUN):$L(PSNLKUNT),1:0)
I (PSNLKL1+PSNLKL2)<62 W !,"Strength: ",PSNLKSTR W:$G(PSNLKUN) " Units: "_PSNLKUNT G PSDZZ
W !,"Strength: ",PSNLKSTR
I $G(PSNLKUN) D
.W !,"Units: " I PSNLKL2<72 W PSNLKUNT Q
.W !,PSNLKUNT
PSDZZ ;
W !,"National Formulary Name: ",PSNLKNFN,!,"VA Print Name: ",PSNLKVPN,!,"VA Product Identifier: ",PSNLKID D DSPLY3 W !,"VA Dispense Unit: ",PSNLKVDU I $D(PSNLKPMI) W !,"PMIS: ",PSNLKPMI
W !,"Active Ingredients: ",!
Q
DSP1 D HG W "Primary Drug Class: ",$P(^PS(50.605,PSNLKCL,0),"^") D SC W !,"CS Federal Schedule: ",$G(PSNLKCSF)_" "_$G(PSNZZFS),!,"Single/Multi Source Product: ",$G(PSNLKSP)
I $G(PSNLKNND)]"" W !,"Inactivation Date: " S Y=PSNLKNND D DD^%DT W Y K Y
W !,"Max Single Dose: ",$P(PSNLKSEV,"^",4),?45,"Min Single Dose: ",$P(PSNLKSEV,"^",5)
W !,"Max Daily Dose: ",$P(PSNLKSEV,"^",6),?45,"Min Daily Dose: ",$P(PSNLKSEV,"^",7),!,"Max Cumulative Dose: ",$P(PSNLKSEV,"^",8)
W !,"National Formulary Indicator: " I $D(^PSNDF(50.68,PSNLKGK,5)) W:$P(^PSNDF(50.68,PSNLKGK,5),"^")=0 "No" W:$P(^PSNDF(50.68,PSNLKGK,5),"^")=1 "Yes"
D FD^PSNACT(PSNLKGK),FDT^PSNACT(PSNLKGK) ;ppsn
N CPDATE,X D NOW^%DTC S CPDATE=X S PSNLKCP=$$CPTIER^PSNAPIS(PSNLKGK,CPDATE,"",1) K CPDATE,X
; PSNLKCP = Copay Tier^Effective Date^End Date
W !,"Copay Tier: ",$P(PSNLKCP,"^",1)
W !,"Copay Effective Date: " S Y=$P(PSNLKCP,"^",2) D DD^%DT W Y K Y
W !
I $G(^PSNDF(50.68,PSNLKGK,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"
D OVER
D:$Y>18 HG
;CLINICAL EFFECTS
W !
D CLEFF^PSNCLEHW(PSNLKGK) D:$Y>18 HG
W !
D POSDOS^PSNACT(PSNLKGK)
W !,"Maximum Days Supply: ",$$GET1^DIQ(50.68,PSNLKGK,32)
;HAZ WASTE
D:$Y>20 HG
D HAZWASTE^PSNCLEHW(PSNLKGK)
N I,J,PSNCODX,PSNCODJ,PSNRXCUI S PSNCODX=0
F I=1:1 S PSNCODX=$O(^PSNDF(50.68,PSNLKGK,11,PSNCODX)) Q:PSNCODX="B"!(PSNCODX="") D
. S PSNRXCUI=$G(^PSNDF(50.68,PSNLKGK,11,PSNCODX,0)) Q:PSNRXCUI'="RxNorm"
. W !!,"Coding System: ",$P(^PSNDF(50.68,PSNLKGK,11,PSNCODX,0),"^",1) S PSNCODJ=0
. F J=1:1 S PSNCODJ=$O(^PSNDF(50.68,PSNLKGK,11,PSNCODX,1,PSNCODJ)) Q:PSNCODJ="B"!(PSNCODJ="") D
.. W !,"Code: ",$P(^PSNDF(50.68,PSNLKGK,11,PSNCODX,1,PSNCODJ,0),"^",1)
W !
Q
RESTN I $O(^PSNDF(50.68,PSNLKGK,6,0)) W !,"Restriction: " F PSNLKRE=0:0 S PSNLKRE=$O(^PSNDF(50.68,PSNLKGK,6,PSNLKRE)) Q:'PSNLKRE S PSNLKWRT=$G(^PSNDF(50.68,PSNLKGK,6,PSNLKRE,0)) W !,PSNLKWRT
Q
HG ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
W @IOF
Q
MESS ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
Q
;
OVER ;
W !,"Override DF Exclude from Dosage Checks: "_$S($P($G(^PSNDF(50.68,PSNLKGK,9)),"^")=1:"Yes",$P($G(^PSNDF(50.68,PSNLKGK,9)),"^")=0:"No",1:"") I $P($G(^PSNDF(50.68,PSNLKGK,9)),"^")=1 D
.I '$G(PSNLKDF) Q
.I '$D(^PS(50.606,PSNLKDF,0)) Q
.I $P($G(^PS(50.606,PSNLKDF,1)),"^")=1 W " (Dosage Checks shall be performed)" Q
.I $P($G(^PS(50.606,PSNLKDF,1)),"^")=0 W " (No Dosage Checks performed)"
Q
;
GETTIER(PSNTDRUG) ;called by DIC; look up copay tier by file 50 ien for current date
N VAPID,CPDATE,X,PSSCP,VAPROD,PSNINACT,PSNCONVD,PSNFD
S VAPROD=$$GET1^DIQ(50,PSNTDRUG,22,"I")
S PSNFD=$$GET1^DIQ(50.68,VAPROD,109)
W:PSNFD'="" " "_PSNFD
Q:'$G(VAPROD)
D NOW^%DTC S CPDATE=$P(%,".")
S PSSCP=$$CPTIER^PSNAPIS(VAPROD,CPDATE,PSNTDRUG,1) K CPDATE,X
I $P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
S PSNINACT=$$GET1^DIQ(50,PSNTDRUG,100,"I") ;inactive date
S:$G(PSNINACT) PSNCONVD=$$DATE(PSNINACT)
W:$G(PSNCONVD)'="" " "_PSNCONVD
Q
;
DATE(PSNCONVD) ;convert fileman date to mm/dd/yyyy
N DATE
S DATE="",DATE=$E(PSNCONVD,4,5)_"/"_$E(PSNCONVD,6,7)_"/"_(1700+$E(PSNCONVD,1,3))
Q DATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNLOOK 8148 printed Apr 09, 2024@21:18:39 Page 2
PSNLOOK ;BIR/WRT-Look up into drug file ; 06/19/03 15:00
+1 ;;4.0;NATIONAL DRUG FILE;**2,3,5,11,22,27,62,70,169,262,296,429,492,396**; 30 Oct 98;Build 190
+2 ;
+3 ; Reference to ^PSDRUG supported by DBIA# 2192
+4 ; Reference to ^PS(50.606 supported by DBIA# 2174
+5 ; Reference to ^PSNAPIS supported by DBIA #2531
+6 ;
+7 ;USE PSNLK*
BEGIN ;
+1 DO ASK
+2 NEW PSNLKDA,PSNLKIND,PSNLKCL,PSNLKNOD,PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR,PSNLKDAV,PSNLKGK,PSNLKPMI,PSNLKQQ
+3 NEW DIC,X,Y,DLAYGO,DTOUT,DUOUT,DIR,DIRUT,DIROUT,%DT,PSNLKMAP,PSNLKENG,PSNLKDF,PSNLKSTR,PSNLKUN,PSNLKFRM
+4 NEW PSNLKUNT,PSNLKNFN,PSNLKBB,PSNLKAND,PSNLKGR,PSNLKIST,PSNLKIUT,PSNLKSEV,PSNLKCSF,PSNLKSP,PSNLKNND,PSNLKCC
+5 NEW PSNLKSCL,PSNLKZ,PSNLKRE,PSNLKWRT,PSNZZFS,PSNLKL1,PSNLKL2,PSNLKIUN,PSNZZFSA,PSNLKCP,PSNTDRUG
SELD ;Select Drug
+1 KILL PSNLKDA,PSNLKIND,PSNLKCL,PSNLKNOD,PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR,PSNLKDAV,PSNLKGK,PSNLKPMI,PSNLKQQ
+2 KILL DIC,X,Y,DLAYGO,DTOUT,DUOUT,DIR,DIRUT,DIROUT,%DT,PSNLKMAP,PSNLKENG,PSNLKDF,PSNLKSTR,PSNLKUN,PSNLKFRM
+3 KILL PSNLKUNT,PSNLKNFN,PSNLKBB,PSNLKAND,PSNLKGR,PSNLKIST,PSNLKIUT,PSNLKSEV,PSNLKCSF,PSNLKSP,PSNLKNND,PSNLKCC
+4 KILL PSNLKSCL,PSNLKZ,PSNLKRE,PSNLKWRT,PSNZZFS,PSNLKL1,PSNLKL2,PSNLKIUN,PSNZZFSA,PSNLKCP,PSNFD,PSNFDT
+5 WRITE !
KILL DIC
SET DIC=50
SET DIC(0)="QEAM"
SET DIC("W")="S PSNTDRUG=Y D GETTIER^PSNLOOK(PSNTDRUG)"
DO ^DIC
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+6 SET PSNLKDA=+Y
KILL Y
+7 SET PSNLKIND=$PIECE($GET(^PSDRUG(PSNLKDA,"I")),"^")
IF PSNLKIND
IF PSNLKIND<DT
SET Y=PSNLKIND
DO DD^%DT
WRITE !!,"This drug has an Inactive date of "_$GET(Y),!
DO MESS
GOTO SELD
+8 DO DSPLY
+9 DO HG
+10 GOTO SELD
+11 ;
ASK WRITE !!,"This option will allow you to look up entries in your local DRUG file. It will",!,"display National Drug File software match information.",!
+1 QUIT
DSPLY WRITE @IOF
WRITE !?14,"DRUG Generic Name: ",$PIECE($GET(^PSDRUG(PSNLKDA,0)),"^")
IF $DATA(^PSDRUG(PSNLKDA,"ND"))
SET PSNLKCL=$PIECE(^("ND"),"^",6)
+1 IF $DATA(^PSDRUG(PSNLKDA,"ND"))
IF $PIECE(^PSDRUG(PSNLKDA,"ND"),"^",2)]""
SET PSNLKNOD=^PSDRUG(PSNLKDA,"ND")
DO DSPLY1
DO DSPLY2
DO PRODF
DO DSP
DO ING
DO SV
DO DSP1
DO RESTN
QUIT
+2 WRITE !?8,"*** NO NATIONAL DRUG FILE INFORMATION ***",!
+3 QUIT
DSPLY1 WRITE !?5,"VA Product Name: ",$PIECE(PSNLKNOD,"^",2)
+1 WRITE !?5,"VA Generic Name: ",$PIECE($GET(^PSNDF(50.6,$PIECE(PSNLKNOD,"^"),0)),"^")
+2 QUIT
DSPLY2 ;
+1 SET (PSNLKVPN,PSNLKID,PSNLKVDU,PSNLKTR)=""
+2 KILL X
SET PSNLKDAV=$PIECE(PSNLKNOD,"^")
SET PSNLKGK=$PIECE(PSNLKNOD,"^",3)
SET X=$$PROD2^PSNAPIS(PSNLKDAV,PSNLKGK)
IF $PIECE(X,"^")]""
SET PSNLKVPN=$PIECE(X,"^")
SET PSNLKID=$PIECE(X,"^",2)
SET PSNLKTR=$PIECE(X,"^",3)
SET PSNLKVDU=$PIECE(X,"^",4)
+3 KILL PSNLKPMI
IF X]""
SET PSNLKQQ=$PIECE(^PSNDF(50.68,PSNLKGK,1),"^",5)
DO GCN
+4 KILL X
+5 QUIT
GCN IF PSNLKQQ']""
SET PSNLKPMI="None"
QUIT
+1 ;
GCN1 ;
+1 IF $DATA(^PS(50.623,"B",PSNLKQQ))
SET PSNLKMAP=$ORDER(^PS(50.623,"B",PSNLKQQ,0))
SET PSNLKENG=$PIECE(^PS(50.623,PSNLKMAP,0),"^",2)
SET PSNLKPMI=$PIECE(^PS(50.621,+PSNLKENG,0),"^")
QUIT
+2 SET PSNLKPMI="None"
+3 QUIT
DSPLY3 WRITE ?50,"Transmit To CMOP: "
+1 IF PSNLKTR=1
WRITE "YES"
+2 IF PSNLKTR=0
WRITE "NO"
+3 QUIT
PRODF ;
+1 SET X=$$PROD0^PSNAPIS(PSNLKDAV,PSNLKGK)
+2 SET PSNLKDF=+$PIECE(X,"^",2)
SET PSNLKSTR=$PIECE(X,"^",3)
SET PSNLKUN=+$PIECE(X,"^",4)
SET PSNLKFRM=$SELECT($GET(PSNLKDF):$PIECE($GET(^PS(50.606,PSNLKDF,0)),"^"),1:"")
SET PSNLKUNT=$SELECT($GET(PSNLKUN):$PIECE($GET(^PS(50.607,PSNLKUN,0)),"^"),1:"")
SET PSNLKNFN=$PIECE(^PSNDF(50.68,PSNLKGK,0),"^",6)
+3 KILL X
+4 QUIT
ING FOR PSNLKBB=0:0
SET PSNLKBB=$ORDER(^PSNDF(50.68,PSNLKGK,2,PSNLKBB))
if 'PSNLKBB
QUIT
Begin DoDot:1
+1 IF $DATA(^PSNDF(50.68,PSNLKGK,2,PSNLKBB,0))
SET PSNLKAND=$GET(^PSNDF(50.68,PSNLKGK,2,PSNLKBB,0))
SET PSNLKGR=$PIECE(^PS(50.416,$PIECE(PSNLKAND,"^",1),0),"^")
SET PSNLKIST=$PIECE(PSNLKAND,"^",2)
SET PSNLKIUT=$PIECE(PSNLKAND,"^",3)
KILL PSNLKIUN
DO ING1
DO IN2
End DoDot:1
+2 QUIT
IN2 WRITE ?3,PSNLKGR,?50,"Str: ",PSNLKIST
if PSNLKIUT
WRITE ?65,"Unt: ",$GET(PSNLKIUN)
WRITE !
+1 QUIT
ING1 if $PIECE(^PS(50.416,$PIECE(PSNLKAND,"^"),0),"^",2)
SET PSNLKGR=$PIECE($GET(^PS(50.416,$PIECE(^PS(50.416,$PIECE(PSNLKAND,"^"),0),"^",2),0)),"^")
IF PSNLKIUT
SET PSNLKIUN=$PIECE(^PS(50.607,PSNLKIUT,0),"^")
+1 QUIT
SC IF $ORDER(^PSNDF(50.68,PSNLKGK,4,0))
WRITE !,"Secondary Class(es): ",!
FOR PSNLKCC=0:0
SET PSNLKCC=$ORDER(^PSNDF(50.68,PSNLKGK,4,PSNLKCC))
if 'PSNLKCC
QUIT
SET PSNLKZ=$PIECE($GET(^PSNDF(50.68,PSNLKGK,4,PSNLKCC,0)),"^")
IF PSNLKZ
Begin DoDot:1
+1 SET PSNLKSCL=$PIECE($GET(^PS(50.605,PSNLKZ,0)),"^")
DO SC1
End DoDot:1
+2 QUIT
SC1 WRITE " ",PSNLKSCL
+1 QUIT
SV SET PSNLKSEV=$GET(^PSNDF(50.68,PSNLKGK,7))
IF PSNLKSEV]""
SET PSNLKCSF=$PIECE(PSNLKSEV,"^")
SET PSNLKSP=$PIECE(PSNLKSEV,"^",2)
if PSNLKSP="M"
SET PSNLKSP="Multi"
if PSNLKSP="S"
SET PSNLKSP="Single"
DO SV1
+1 QUIT
SV1 SET PSNZZFSA=PSNLKGK_","
SET PSNZZFS=$$GET1^DIQ(50.68,PSNZZFSA,19)
IF $GET(PSNZZFS)=""
SET PSNZZFS="None"
+1 SET PSNLKNND=$PIECE(^PSNDF(50.68,PSNLKGK,7),"^",3)
+2 QUIT
DSP WRITE !,"Dosage Form: ",PSNLKFRM_$SELECT('$GET(PSNLKDF):"",$PIECE($GET(^PS(50.606,PSNLKDF,1)),"^")=1:" (Exclude from Dosing Cks)",1:"")
+1 SET PSNLKL1=$LENGTH(PSNLKSTR)
SET PSNLKL2=$SELECT($GET(PSNLKUN):$LENGTH(PSNLKUNT),1:0)
+2 IF (PSNLKL1+PSNLKL2)<62
WRITE !,"Strength: ",PSNLKSTR
if $GET(PSNLKUN)
WRITE " Units: "_PSNLKUNT
GOTO PSDZZ
+3 WRITE !,"Strength: ",PSNLKSTR
+4 IF $GET(PSNLKUN)
Begin DoDot:1
+5 WRITE !,"Units: "
IF PSNLKL2<72
WRITE PSNLKUNT
QUIT
+6 WRITE !,PSNLKUNT
End DoDot:1
PSDZZ ;
+1 WRITE !,"National Formulary Name: ",PSNLKNFN,!,"VA Print Name: ",PSNLKVPN,!,"VA Product Identifier: ",PSNLKID
DO DSPLY3
WRITE !,"VA Dispense Unit: ",PSNLKVDU
IF $DATA(PSNLKPMI)
WRITE !,"PMIS: ",PSNLKPMI
+2 WRITE !,"Active Ingredients: ",!
+3 QUIT
DSP1 DO HG
WRITE "Primary Drug Class: ",$PIECE(^PS(50.605,PSNLKCL,0),"^")
DO SC
WRITE !,"CS Federal Schedule: ",$GET(PSNLKCSF)_" "_$GET(PSNZZFS),!,"Single/Multi Source Product: ",$GET(PSNLKSP)
+1 IF $GET(PSNLKNND)]""
WRITE !,"Inactivation Date: "
SET Y=PSNLKNND
DO DD^%DT
WRITE Y
KILL Y
+2 WRITE !,"Max Single Dose: ",$PIECE(PSNLKSEV,"^",4),?45,"Min Single Dose: ",$PIECE(PSNLKSEV,"^",5)
+3 WRITE !,"Max Daily Dose: ",$PIECE(PSNLKSEV,"^",6),?45,"Min Daily Dose: ",$PIECE(PSNLKSEV,"^",7),!,"Max Cumulative Dose: ",$PIECE(PSNLKSEV,"^",8)
+4 WRITE !,"National Formulary Indicator: "
IF $DATA(^PSNDF(50.68,PSNLKGK,5))
if $PIECE(^PSNDF(50.68,PSNLKGK,5),"^")=0
WRITE "No"
if $PIECE(^PSNDF(50.68,PSNLKGK,5),"^")=1
WRITE "Yes"
+5 ;ppsn
DO FD^PSNACT(PSNLKGK)
DO FDT^PSNACT(PSNLKGK)
+6 NEW CPDATE,X
DO NOW^%DTC
SET CPDATE=X
SET PSNLKCP=$$CPTIER^PSNAPIS(PSNLKGK,CPDATE,"",1)
KILL CPDATE,X
+7 ; PSNLKCP = Copay Tier^Effective Date^End Date
+8 WRITE !,"Copay Tier: ",$PIECE(PSNLKCP,"^",1)
+9 WRITE !,"Copay Effective Date: "
SET Y=$PIECE(PSNLKCP,"^",2)
DO DD^%DT
WRITE Y
KILL Y
+10 WRITE !
+11 IF $GET(^PSNDF(50.68,PSNLKGK,8))
WRITE !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"
+12 DO OVER
+13 if $Y>18
DO HG
+14 ;CLINICAL EFFECTS
+15 WRITE !
+16 DO CLEFF^PSNCLEHW(PSNLKGK)
if $Y>18
DO HG
+17 WRITE !
+18 DO POSDOS^PSNACT(PSNLKGK)
+19 WRITE !,"Maximum Days Supply: ",$$GET1^DIQ(50.68,PSNLKGK,32)
+20 ;HAZ WASTE
+21 if $Y>20
DO HG
+22 DO HAZWASTE^PSNCLEHW(PSNLKGK)
+23 NEW I,J,PSNCODX,PSNCODJ,PSNRXCUI
SET PSNCODX=0
+24 FOR I=1:1
SET PSNCODX=$ORDER(^PSNDF(50.68,PSNLKGK,11,PSNCODX))
if PSNCODX="B"!(PSNCODX="")
QUIT
Begin DoDot:1
+25 SET PSNRXCUI=$GET(^PSNDF(50.68,PSNLKGK,11,PSNCODX,0))
if PSNRXCUI'="RxNorm"
QUIT
+26 WRITE !!,"Coding System: ",$PIECE(^PSNDF(50.68,PSNLKGK,11,PSNCODX,0),"^",1)
SET PSNCODJ=0
+27 FOR J=1:1
SET PSNCODJ=$ORDER(^PSNDF(50.68,PSNLKGK,11,PSNCODX,1,PSNCODJ))
if PSNCODJ="B"!(PSNCODJ="")
QUIT
Begin DoDot:2
+28 WRITE !,"Code: ",$PIECE(^PSNDF(50.68,PSNLKGK,11,PSNCODX,1,PSNCODJ,0),"^",1)
End DoDot:2
End DoDot:1
+29 WRITE !
+30 QUIT
RESTN IF $ORDER(^PSNDF(50.68,PSNLKGK,6,0))
WRITE !,"Restriction: "
FOR PSNLKRE=0:0
SET PSNLKRE=$ORDER(^PSNDF(50.68,PSNLKGK,6,PSNLKRE))
if 'PSNLKRE
QUIT
SET PSNLKWRT=$GET(^PSNDF(50.68,PSNLKGK,6,PSNLKRE,0))
WRITE !,PSNLKWRT
+1 QUIT
HG ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+2 WRITE @IOF
+3 QUIT
MESS ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
OVER ;
+1 WRITE !,"Override DF Exclude from Dosage Checks: "_$SELECT($PIECE($GET(^PSNDF(50.68,PSNLKGK,9)),"^")=1:"Yes",$PIECE($GET(^PSNDF(50.68,PSNLKGK,9)),"^")=0:"No",1:"")
IF $PIECE($GET(^PSNDF(50.68,PSNLKGK,9)),"^")=1
Begin DoDot:1
+2 IF '$GET(PSNLKDF)
QUIT
+3 IF '$DATA(^PS(50.606,PSNLKDF,0))
QUIT
+4 IF $PIECE($GET(^PS(50.606,PSNLKDF,1)),"^")=1
WRITE " (Dosage Checks shall be performed)"
QUIT
+5 IF $PIECE($GET(^PS(50.606,PSNLKDF,1)),"^")=0
WRITE " (No Dosage Checks performed)"
End DoDot:1
+6 QUIT
+7 ;
GETTIER(PSNTDRUG) ;called by DIC; look up copay tier by file 50 ien for current date
+1 NEW VAPID,CPDATE,X,PSSCP,VAPROD,PSNINACT,PSNCONVD,PSNFD
+2 SET VAPROD=$$GET1^DIQ(50,PSNTDRUG,22,"I")
+3 SET PSNFD=$$GET1^DIQ(50.68,VAPROD,109)
+4 if PSNFD'=""
WRITE " "_PSNFD
+5 if '$GET(VAPROD)
QUIT
+6 DO NOW^%DTC
SET CPDATE=$PIECE(%,".")
+7 SET PSSCP=$$CPTIER^PSNAPIS(VAPROD,CPDATE,PSNTDRUG,1)
KILL CPDATE,X
+8 IF $PIECE(PSSCP,"^")'=""
WRITE " Tier ",$PIECE(PSSCP,"^")
+9 ;inactive date
SET PSNINACT=$$GET1^DIQ(50,PSNTDRUG,100,"I")
+10 if $GET(PSNINACT)
SET PSNCONVD=$$DATE(PSNINACT)
+11 if $GET(PSNCONVD)'=""
WRITE " "_PSNCONVD
+12 QUIT
+13 ;
DATE(PSNCONVD) ;convert fileman date to mm/dd/yyyy
+1 NEW DATE
+2 SET DATE=""
SET DATE=$EXTRACT(PSNCONVD,4,5)_"/"_$EXTRACT(PSNCONVD,6,7)_"/"_(1700+$EXTRACT(PSNCONVD,1,3))
+3 QUIT DATE
