- PSSOPKI ;BHAM ISC/MHA-New API's to CPRS for DEA/PKI Pilot Project ;03/11/02
- ;;1.0;PHARMACY DATA MANAGEMENT;**61,69**;9/30/97
- ;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
- 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**;9/30/97
- +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
