PSSOPKI ;BHAM ISC/MHA-New API's to CPRS for DEA/PKI Pilot Project ;03/11/02
;;1.0;PHARMACY DATA MANAGEMENT;**61,69,166,183,209,219,246,247,261**;9/30/97;Build 3
;Reference to ^PSNDF(50.68 supported by DBIA 3735
;
OIDEA(PSSXOI,PSSXOIP) ; CPRS Orderable Item call
;returns the CS Federal Schedule code in the VA PRODUCT file (#50.68)
;or the DEA Special Hndl code depending on the "ND" node of the
;drugs associated to the Orderable Item, and Usage passed in
;1 Sch. I Nar.
;2 II
;2n II Non-Nar.
;3 III
;3n III Non-Nar.
;4 IV
;5 V
;0 there are other active drugs
;"" no active drugs
;
N PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX,PSSI,PSSK,PSSJ,PSSGD
S (PSSXOLPD,PSSXNODD)=0 I PSSXOIP="X" G OIQ
I '$G(PSSXOI)!($G(PSSXOIP)="") G OIQ
S PSSPKLX=$S(PSSXOIP="I":1,PSSXOIP="U":1,1:0)
F PSSXOLP=0:0 S PSSXOLP=$O(^PSDRUG("ASP",PSSXOI,PSSXOLP)) Q:'PSSXOLP D
.I $P($G(^PSDRUG(PSSXOLP,"I")),"^"),$P($G(^("I")),"^")<DT Q
.I 'PSSPKLX,$P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["O" Q
.I PSSPKLX I $P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["U",$P($G(^(2)),"^",3)'["I" Q
.S PSSXNODD=1,PSSJ=($P($G(^PSDRUG(PSSXOLP,0)),"^",3)) S:PSSJ]"" PSSGD(PSSJ)=""
.I +$P($G(^PSDRUG(PSSXOLP,"ND")),"^",3) S PSSK=$P(^("ND"),"^",3) D
..I +$P($G(^PSNDF(50.68,PSSK,7)),"^") S PSSK=$P(^(7),"^"),PSSI($S($E(PSSK,2)="n":$E(PSSK)_".5",1:PSSK))=""
G:$O(PSSI(""))]"" CSS
S PSSXOLPX="" F S PSSXOLPX=$O(PSSGD(PSSXOLPX)) Q:PSSXOLPX="" D
.I PSSXOLPX[1 S PSSI(1)="" Q
.I PSSXOLPX[2,PSSXOLPX'["C" S PSSI(2)="" Q
.I PSSXOLPX[2,PSSXOLPX["C" S PSSI(2.5)="" Q
.I PSSXOLPX[3,PSSXOLPX'["C" S PSSI(3)="" Q
.I PSSXOLPX[3,PSSXOLPX["C" S PSSI(3.5)="" Q
.I PSSXOLPX[4 S PSSI(4)="" Q
.I PSSXOLPX[5 S PSSI(5)=""
CSS S PSSK=0 S PSSK=$O(PSSI(PSSK)) I PSSK S PSSXOLPD=$E(PSSK)_$S($L(PSSK)>1:"n",1:"")
OIQ I PSSXOLPD=0 S:'PSSXNODD PSSXOLPD=""
I +PSSXOLPD=1!(+PSSXOLPD=2) S PSSXOLPD=1_";"_PSSXOLPD
I +PSSXOLPD=3!(+PSSXOLPD=4)!(+PSSXOLPD=5) S PSSXOLPD=2_";"_PSSXOLPD
Q PSSXOLPD
;
DEAPKI(PSSDIENM) ;Return CS Federal Sch or the DEA Special Hndl for CPRS Dose Call - PKI Project
Q:'$G(PSSDIENM)
N PSSDEAX,PSSDEAXV,PSSJ
I +$P($G(^PSDRUG(PSSDIENM,"ND")),"^",3) S PSSDEAX=$P(^("ND"),"^",3) D
.I +$P($G(^PSNDF(50.68,PSSDEAX,7)),"^") S PSSDEAXV=$P(^(7),"^"),PSSJ=1
G:$G(PSSJ) DSET
S PSSDEAX=$P($G(^PSDRUG(PSSDIENM,0)),"^",3)
I PSSDEAX[1 S PSSDEAXV=1 G DSET
I PSSDEAX[2,PSSDEAX'["C" S PSSDEAXV=2 G DSET
I PSSDEAX[2,PSSDEAX["C" S PSSDEAXV="2n" G DSET
I PSSDEAX[3,PSSDEAX'["C" S PSSDEAXV=3 G DSET
I PSSDEAX[3,PSSDEAX["C" S PSSDEAXV="3n" G DSET
I PSSDEAX[4 S PSSDEAXV=4 G DSET
I PSSDEAX[5 S PSSDEAXV=5 G DSET
S PSSDEAXV=0
DSET ;
I +PSSDEAXV=1!(+PSSDEAXV=2) S PSSDEAXV=1_";"_PSSDEAXV
I +PSSDEAXV=3!(+PSSDEAXV=4)!(+PSSDEAXV=5) S PSSDEAXV=2_";"_PSSDEAXV
S PSSX("DD",PSSDIENM)=PSSX("DD",PSSDIENM)_"^"_PSSDEAXV_"^"_$S($D(PSSHLF(PSSDIENM)):1,1:0)
Q
;
DETOX(PSSDIEN) ; BUPREN drug check to determine if drug is a detox medication
; Input - PSSDIEN - Drug IEN
; Output - returns 1 if the drugs is a Detox medication, otherwise it returns 0
;
Q 0 ;P261 detox/x-waiver removal
Q:'$G(PSSDIEN) 0
Q:$P($G(^PSDRUG(PSSDIEN,0)),"^")'["BUPREN" 0
N PSSJ,PSSY,PSSNDF,PKGLIST,SYSLIST
S PSSJ=1
D GETLST^XPAR(.PKGLIST,"PKG","PSS BUPRENORPHINE PAIN VAPRODS","N") D DETINDEX(.PKGLIST)
D GETLST^XPAR(.SYSLIST,"SYS","PSS BUPRENORPHINE PAIN VAPRODS","N") D DETINDEX(.SYSLIST)
I +$P($G(^PSDRUG(PSSDIEN,"ND")),"^",3) S PSSNDF=$P(^("ND"),"^",3) D Q PSSJ
.S PSSY=$$GET1^DIQ(50.68,PSSNDF,4) I PSSY'="",($D(PKGLIST("B",PSSY))!$D(SYSLIST("B",PSSY))) S PSSJ=0
Q PSSJ
;
DETINDEX(LIST) ;
N I,IEN
S I=0 F S I=$O(LIST(I)) Q:'I D
.S IEN=$P(LIST(I),U) S LIST("B",$$GET1^DIQ(50.68,IEN,4))=""
Q
;
OIDETOX(PSSXOI,PSSXOIP) ; CPRS Orderable Item to check a drug is a DETOX or not
;Input - PSSXOI - Orderable Item IEN
; - PSSXOIP - Package
;Output - returns 1 if the drugs associated to the Orderable Item contains the text "BUPREN" as part of the name
; otherwise it returns 0
Q 0 ;P261 detox/x-waiver removal
N PSSDTOX,PSSLP,PSSDPK
I '$G(PSSXOI)!($G(PSSXOIP)="")!(PSSXOIP'="O") Q 0
S (PSSLP,PSSDTOX)=0
F S PSSLP=$O(^PSDRUG("ASP",PSSXOI,PSSLP)) Q:'PSSLP!PSSDTOX D
.I $P($G(^PSDRUG(PSSLP,"I")),"^"),$P($G(^("I")),"^")<DT Q
.S PSSDPK=$P($G(^PSDRUG(PSSLP,2)),"^",3)
.Q:PSSDPK=""!(PSSDPK'["O")
.I $$DETOX(PSSLP) S PSSDTOX=1 Q
Q PSSDTOX
;
BUPARED ; Manage Buprenorphine Tx of Pain using VA Product file (#50.68)
D EDITPAR^XPAREDIT("PSS BUPRENORPHINE PAIN VAPRODS")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSOPKI 4550 printed Dec 13, 2024@02:33:24 Page 2
PSSOPKI ;BHAM ISC/MHA-New API's to CPRS for DEA/PKI Pilot Project ;03/11/02
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**61,69,166,183,209,219,246,247,261**;9/30/97;Build 3
+2 ;Reference to ^PSNDF(50.68 supported by DBIA 3735
+3 ;
OIDEA(PSSXOI,PSSXOIP) ; CPRS Orderable Item call
+1 ;returns the CS Federal Schedule code in the VA PRODUCT file (#50.68)
+2 ;or the DEA Special Hndl code depending on the "ND" node of the
+3 ;drugs associated to the Orderable Item, and Usage passed in
+4 ;1 Sch. I Nar.
+5 ;2 II
+6 ;2n II Non-Nar.
+7 ;3 III
+8 ;3n III Non-Nar.
+9 ;4 IV
+10 ;5 V
+11 ;0 there are other active drugs
+12 ;"" no active drugs
+13 ;
+14 NEW PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX,PSSI,PSSK,PSSJ,PSSGD
+15 SET (PSSXOLPD,PSSXNODD)=0
IF PSSXOIP="X"
GOTO OIQ
+16 IF '$GET(PSSXOI)!($GET(PSSXOIP)="")
GOTO OIQ
+17 SET PSSPKLX=$SELECT(PSSXOIP="I":1,PSSXOIP="U":1,1:0)
+18 FOR PSSXOLP=0:0
SET PSSXOLP=$ORDER(^PSDRUG("ASP",PSSXOI,PSSXOLP))
if 'PSSXOLP
QUIT
Begin DoDot:1
+19 IF $PIECE($GET(^PSDRUG(PSSXOLP,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+20 IF 'PSSPKLX
IF $PIECE($GET(^PSDRUG(PSSXOLP,2)),"^",3)'["O"
QUIT
+21 IF PSSPKLX
IF $PIECE($GET(^PSDRUG(PSSXOLP,2)),"^",3)'["U"
IF $PIECE($GET(^(2)),"^",3)'["I"
QUIT
+22 SET PSSXNODD=1
SET PSSJ=($PIECE($GET(^PSDRUG(PSSXOLP,0)),"^",3))
if PSSJ]""
SET PSSGD(PSSJ)=""
+23 IF +$PIECE($GET(^PSDRUG(PSSXOLP,"ND")),"^",3)
SET PSSK=$PIECE(^("ND"),"^",3)
Begin DoDot:2
+24 IF +$PIECE($GET(^PSNDF(50.68,PSSK,7)),"^")
SET PSSK=$PIECE(^(7),"^")
SET PSSI($SELECT($EXTRACT(PSSK,2)="n":$EXTRACT(PSSK)_".5",1:PSSK))=""
End DoDot:2
End DoDot:1
+25 if $ORDER(PSSI(""))]""
GOTO CSS
+26 SET PSSXOLPX=""
FOR
SET PSSXOLPX=$ORDER(PSSGD(PSSXOLPX))
if PSSXOLPX=""
QUIT
Begin DoDot:1
+27 IF PSSXOLPX[1
SET PSSI(1)=""
QUIT
+28 IF PSSXOLPX[2
IF PSSXOLPX'["C"
SET PSSI(2)=""
QUIT
+29 IF PSSXOLPX[2
IF PSSXOLPX["C"
SET PSSI(2.5)=""
QUIT
+30 IF PSSXOLPX[3
IF PSSXOLPX'["C"
SET PSSI(3)=""
QUIT
+31 IF PSSXOLPX[3
IF PSSXOLPX["C"
SET PSSI(3.5)=""
QUIT
+32 IF PSSXOLPX[4
SET PSSI(4)=""
QUIT
+33 IF PSSXOLPX[5
SET PSSI(5)=""
End DoDot:1
CSS SET PSSK=0
SET PSSK=$ORDER(PSSI(PSSK))
IF PSSK
SET PSSXOLPD=$EXTRACT(PSSK)_$SELECT($LENGTH(PSSK)>1:"n",1:"")
OIQ IF PSSXOLPD=0
if 'PSSXNODD
SET PSSXOLPD=""
+1 IF +PSSXOLPD=1!(+PSSXOLPD=2)
SET PSSXOLPD=1_";"_PSSXOLPD
+2 IF +PSSXOLPD=3!(+PSSXOLPD=4)!(+PSSXOLPD=5)
SET PSSXOLPD=2_";"_PSSXOLPD
+3 QUIT PSSXOLPD
+4 ;
DEAPKI(PSSDIENM) ;Return CS Federal Sch or the DEA Special Hndl for CPRS Dose Call - PKI Project
+1 if '$GET(PSSDIENM)
QUIT
+2 NEW PSSDEAX,PSSDEAXV,PSSJ
+3 IF +$PIECE($GET(^PSDRUG(PSSDIENM,"ND")),"^",3)
SET PSSDEAX=$PIECE(^("ND"),"^",3)
Begin DoDot:1
+4 IF +$PIECE($GET(^PSNDF(50.68,PSSDEAX,7)),"^")
SET PSSDEAXV=$PIECE(^(7),"^")
SET PSSJ=1
End DoDot:1
+5 if $GET(PSSJ)
GOTO DSET
+6 SET PSSDEAX=$PIECE($GET(^PSDRUG(PSSDIENM,0)),"^",3)
+7 IF PSSDEAX[1
SET PSSDEAXV=1
GOTO DSET
+8 IF PSSDEAX[2
IF PSSDEAX'["C"
SET PSSDEAXV=2
GOTO DSET
+9 IF PSSDEAX[2
IF PSSDEAX["C"
SET PSSDEAXV="2n"
GOTO DSET
+10 IF PSSDEAX[3
IF PSSDEAX'["C"
SET PSSDEAXV=3
GOTO DSET
+11 IF PSSDEAX[3
IF PSSDEAX["C"
SET PSSDEAXV="3n"
GOTO DSET
+12 IF PSSDEAX[4
SET PSSDEAXV=4
GOTO DSET
+13 IF PSSDEAX[5
SET PSSDEAXV=5
GOTO DSET
+14 SET PSSDEAXV=0
DSET ;
+1 IF +PSSDEAXV=1!(+PSSDEAXV=2)
SET PSSDEAXV=1_";"_PSSDEAXV
+2 IF +PSSDEAXV=3!(+PSSDEAXV=4)!(+PSSDEAXV=5)
SET PSSDEAXV=2_";"_PSSDEAXV
+3 SET PSSX("DD",PSSDIENM)=PSSX("DD",PSSDIENM)_"^"_PSSDEAXV_"^"_$SELECT($DATA(PSSHLF(PSSDIENM)):1,1:0)
+4 QUIT
+5 ;
DETOX(PSSDIEN) ; BUPREN drug check to determine if drug is a detox medication
+1 ; Input - PSSDIEN - Drug IEN
+2 ; Output - returns 1 if the drugs is a Detox medication, otherwise it returns 0
+3 ;
+4 ;P261 detox/x-waiver removal
QUIT 0
+5 if '$GET(PSSDIEN)
QUIT 0
+6 if $PIECE($GET(^PSDRUG(PSSDIEN,0)),"^")'["BUPREN"
QUIT 0
+7 NEW PSSJ,PSSY,PSSNDF,PKGLIST,SYSLIST
+8 SET PSSJ=1
+9 DO GETLST^XPAR(.PKGLIST,"PKG","PSS BUPRENORPHINE PAIN VAPRODS","N")
DO DETINDEX(.PKGLIST)
+10 DO GETLST^XPAR(.SYSLIST,"SYS","PSS BUPRENORPHINE PAIN VAPRODS","N")
DO DETINDEX(.SYSLIST)
+11 IF +$PIECE($GET(^PSDRUG(PSSDIEN,"ND")),"^",3)
SET PSSNDF=$PIECE(^("ND"),"^",3)
Begin DoDot:1
+12 SET PSSY=$$GET1^DIQ(50.68,PSSNDF,4)
IF PSSY'=""
IF ($DATA(PKGLIST("B",PSSY))!$DATA(SYSLIST("B",PSSY)))
SET PSSJ=0
End DoDot:1
QUIT PSSJ
+13 QUIT PSSJ
+14 ;
DETINDEX(LIST) ;
+1 NEW I,IEN
+2 SET I=0
FOR
SET I=$ORDER(LIST(I))
if 'I
QUIT
Begin DoDot:1
+3 SET IEN=$PIECE(LIST(I),U)
SET LIST("B",$$GET1^DIQ(50.68,IEN,4))=""
End DoDot:1
+4 QUIT
+5 ;
OIDETOX(PSSXOI,PSSXOIP) ; CPRS Orderable Item to check a drug is a DETOX or not
+1 ;Input - PSSXOI - Orderable Item IEN
+2 ; - PSSXOIP - Package
+3 ;Output - returns 1 if the drugs associated to the Orderable Item contains the text "BUPREN" as part of the name
+4 ; otherwise it returns 0
+5 ;P261 detox/x-waiver removal
QUIT 0
+6 NEW PSSDTOX,PSSLP,PSSDPK
+7 IF '$GET(PSSXOI)!($GET(PSSXOIP)="")!(PSSXOIP'="O")
QUIT 0
+8 SET (PSSLP,PSSDTOX)=0
+9 FOR
SET PSSLP=$ORDER(^PSDRUG("ASP",PSSXOI,PSSLP))
if 'PSSLP!PSSDTOX
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^PSDRUG(PSSLP,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+11 SET PSSDPK=$PIECE($GET(^PSDRUG(PSSLP,2)),"^",3)
+12 if PSSDPK=""!(PSSDPK'["O")
QUIT
+13 IF $$DETOX(PSSLP)
SET PSSDTOX=1
QUIT
End DoDot:1
+14 QUIT PSSDTOX
+15 ;
BUPARED ; Manage Buprenorphine Tx of Pain using VA Product file (#50.68)
+1 DO EDITPAR^XPAREDIT("PSS BUPRENORPHINE PAIN VAPRODS")
+2 QUIT
