PSSUTIL1 ;BIR/RTR-Utility routine ;08/21/00
;;1.0;PHARMACY DATA MANAGEMENT;**38,66,69,166,189,255**;9/30/97;Build 2
;Reference to ^PS(50.607 supported by DBIA #2221
;Reference to ^PSNAPIS supported by DBIA 2531
;
EN(PSSDRIEN) ;
N PSSMASH,PSSMNDFS,PSSMSSTR,PSSMUNIT,PSSUNZ,PSSMA,PSSMB,PSSMA1,PSSMB1,PSSUNX,PSSMASH2,PSSMASH3,PSSNAT1,PSSNAT3,PSSNODEU
I '$G(PSSDRIEN) Q "|^^^^^99PSU"
S PSSMSSTR=$P($G(^PSDRUG(PSSDRIEN,"DOS")),"^"),PSSMUNIT=$P($G(^("DOS")),"^",2)
S PSSNAT1=$P($G(^PSDRUG(PSSDRIEN,"ND")),"^"),PSSNAT3=$P($G(^("ND")),"^",3) I PSSNAT1,PSSNAT3 S PSSNODEU=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT3) S PSSMNDFS=$P(PSSNODEU,"^",4) S:'$G(PSSMUNIT) PSSMUNIT=$P(PSSNODEU,"^",5)
S PSSUNZ=$P($G(^PS(50.607,+$G(PSSMUNIT),0)),"^")
I PSSUNZ'["/" Q $S($G(PSSMSSTR)'="":$G(PSSMSSTR),$G(PSSMNDFS)'="":$G(PSSMNDFS),1:"")_"|"_"^^^"_$S($G(PSSMUNIT):$G(PSSMUNIT),1:"")_"^"_$G(PSSUNZ)_"^"_"99PSU"
S PSSMASH=0
I $G(PSSMSSTR),$G(PSSMNDFS),+$G(PSSMSSTR)'=+$G(PSSMNDFS) S PSSMASH=1
I 'PSSMASH Q PSSMSSTR_"|"_"^^^"_$S($G(PSSMUNIT):$G(PSSMUNIT),1:"")_"^"_$G(PSSUNZ)_"^"_"99PSU"
S PSSMA=$P(PSSUNZ,"/"),PSSMB=$P(PSSUNZ,"/",2),PSSMA1=+$G(PSSMA),PSSMB1=+$G(PSSMB)
S PSSMASH2=PSSMSSTR/PSSMNDFS,PSSMASH3=PSSMASH2*($S($G(PSSMB1):$G(PSSMB1),1:1))
S PSSUNX=$G(PSSMA)_"/"_$G(PSSMASH3)_$S('$G(PSSMB1):$G(PSSMB),1:$P(PSSMB,PSSMB1,2))
Q $S($G(PSSMSSTR)'="":$G(PSSMSSTR),$G(PSSMNDFS)'="":$G(PSSMNDFS),1:"")_"|"_"^^^^"_$G(PSSUNX)_"^"_"99PSU"
;
Q
;
DRG(PSSDD,PSSOI,PSSPK) ;
; PSSDD - Array of Drugs
; PSSOI - Orderable Item (Pharmacy)
; PSSPK - Application Package ("O"-Outpatient;"I"-IV;"X"-Non-VA Med)
;Return active dispense drugs for package based on Orderable Item
N PSSL,PSSAP,PSSIN,PSSND
Q:'$G(PSSOI)
I $G(PSSPK)'="O",$G(PSSPK)'="I",$G(PSSPK)'="X" Q
F PSSL=0:0 S PSSL=$O(^PSDRUG("ASP",PSSOI,PSSL)) Q:'PSSL D
. S PSSIN=$P($G(^PSDRUG(PSSL,"I")),"^"),PSSAP=$P($G(^(2)),"^",3)
. I PSSIN,PSSIN<DT Q
. S PSSND=$P($G(^PSDRUG(PSSL,"ND")),"^")
. I PSSPK="O"!(PSSPK="X") D Q
. . S:PSSAP[PSSPK PSSDD(PSSL_";"_PSSND)=$P($G(^PSDRUG(PSSL,0)),"^")
. I PSSAP["I"!(PSSAP["U") D
. . S PSSDD(PSSL_";"_PSSND)=$P($G(^PSDRUG(PSSL,0)),"^")
Q
;
ITEM(PSSIT,PSSDR) ;Return Orderable Item to CPRS
N PSSNEW
I '$G(PSSIT)!('$G(PSSDR)) Q -1
I '$D(^PS(50.7,+$G(PSSIT),0))!('$D(^PSDRUG(+$G(PSSDR),0))) Q -1
S PSSNEW=+$P($G(^PSDRUG(+$G(PSSDR),2)),"^")
I PSSNEW,PSSNEW=$G(PSSIT) Q 0
I PSSNEW,PSSNEW'=$G(PSSIT) Q 1_"^"_PSSNEW
Q -1
;
Q
;
EN1(PSSOA,PSSOAP) ;
;Return Orderable Item Forumary Alternatives to CPRS
;PSSOA = Pharmacy Orderable Item number
;PSSOAP = "I" For Inpatient, "O" For Outpatient
Q:'$G(PSSOA)
I $G(PSSOAP)'="O",$G(PSSOAP)'="I" Q
N PSSOAL,PSSOALD,PSSOAN,PSSOAIT,PSSOADT,PSSOAZ
S PSSOAL="" F S PSSOAL=$O(^PSDRUG("ASP",PSSOA,PSSOAL)) Q:PSSOAL="" D
.S PSSOALD="" F S PSSOALD=$O(^PSDRUG(PSSOAL,65,PSSOALD)) Q:PSSOALD="" D
..S PSSOAN=$P($G(^PSDRUG(PSSOAL,65,PSSOALD,0)),"^") I PSSOAN S PSSOAIT=$P($G(^PSDRUG(PSSOAN,2)),"^") D:PSSOAIT
...Q:PSSOAIT=PSSOA
...Q:$D(PSSOA(PSSOAIT))
...Q:'$D(^PS(50.7,PSSOAIT,0))!($P($G(^PS(50.7,PSSOAIT,0)),"^",12))
...Q:$P($G(^PS(50.7,PSSOAIT,0)),"^",4)&(+$P($G(^(0)),"^",4)'>DT)
...S PSSOAZ="" F S PSSOAZ=$O(^PSDRUG("ASP",PSSOAIT,PSSOAZ)) Q:PSSOAZ=""!($D(PSSOA(PSSOAIT))) D
....Q:$P($G(^PSDRUG(PSSOAZ,"I")),"^")&(+$P($G(^("I")),"^")'>DT)
....Q:$P($G(^PSDRUG(PSSOAZ,0)),"^",9)
....I $G(PSSOAP)="O" S:$P($G(^PSDRUG(PSSOAZ,2)),"^",3)["O" PSSOA(PSSOAIT)="" Q
....I $P($G(^PSDRUG(PSSOAZ,2)),"^",3)["I"!($P($G(^(2)),"^",3)["U") S PSSOA(PSSOAIT)=""
Q
SCH(SCH) ;Expand schedule for Outpatient order in CPRS
N SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST,SCHEX
S SCHEX=$G(SCH) S SQFLAG=0
I $G(SCH)="" G SCHQT
;I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
F SCLOOP=0:0 S SCLOOP=$O(^PS(51.1,"B",SCH,SCLOOP)) Q:'SCLOOP!(SQFLAG) I $P($G(^PS(51.1,SCLOOP,0)),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SQFLAG=1
I SQFLAG G SCHQT
I $P($G(^PS(51,"A",SCH)),"^")'="" S SCHEX=$P(^(SCH),"^") G SCHQT
S SCLOOP=0 F SCLP=1:1:$L(SCH) S SCLPS=$E(SCH,SCLP) I SCLPS=" " S SCLOOP=SCLOOP+1
I SCLOOP=0 S SCHEX=SCH G SCHQT
S SCLOOP=SCLOOP+1
K SCLHOLD F SCIN=1:1:SCLOOP S (SODL,SCLHOLD(SCIN))=$P(SCH," ",SCIN) D
.Q:$G(SODL)=""
.S SQFLAG=0 F SST=0:0 S SST=$O(^PS(51.1,"B",SODL,SST)) Q:'SST!($G(SQFLAG)) I $P($G(^PS(51.1,SST,0)),"^",8)'="" S SCLHOLD(SCIN)=$P($G(^(0)),"^",8),SQFLAG=1
.Q:$G(SQFLAG)
.I $P($G(^PS(51,"A",SODL)),"^")'="" S SCLHOLD(SCIN)=$P(^(SODL),"^")
S SCHEX="",SQFLAG=0 F SST=1:1:SCLOOP S SCHEX=SCHEX_$S($G(SQFLAG):" ",1:"")_$G(SCLHOLD(SST)),SQFLAG=1
SCHQT ;
S SCH=SCHEX
Q
;
IVDEA(PSSIVOI,PSSIVOIP) ;CS Federal Schedule/DEA Special Handling to CPRS for IV Fluids dialogue
;parameter 1 is Orderable Item
;parameter 2 is "A" for Additive, "S" for Solution
;Return 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.
;1;1 Sch. I Nar.
;1;2 II
;1;2n II Non-Nar.
;2;3 III
;2;3n III Non-Nar.
;2;4 IV
;2;5 V
;0 there are other active drugs
;"" no active drugs
N PSSIVDO,PSSIVDD,PSSIVL,PSSIVLP,PSSIVDEA,PSSIVLPX,PSSK,PSSI,PSSGD
S (PSSIVDO,PSSIVDD)=0
I $G(PSSIVOIP)'="S" S PSSIVOIP="A"
I '$G(PSSIVOI) G IVQ1
S PSSIVL="" F S PSSIVL=$O(^PSDRUG("ASP",PSSIVOI,PSSIVL)) Q:'PSSIVL D
.I $P($G(^PSDRUG(PSSIVL,"I")),"^"),$P($G(^("I")),"^")<DT Q
.I $P($G(^PSDRUG(PSSIVL,2)),"^",3)'["I",$P($G(^(2)),"^",3)'["U" Q
.S PSSIVDD=1
.I PSSIVOIP="A" D Q
..S (PSSIVLP,PSSIVLPX)=0 F S PSSIVLP=$O(^PSDRUG("A526",PSSIVL,PSSIVLP)) Q:'PSSIVLP!(PSSIVLPX) D
...I $D(^PS(52.6,PSSIVLP,0)) I '$P($G(^("I")),"^")!($P($G(^("I")),"^")>DT) D IVX
.S (PSSIVLP,PSSIVLPX)=0 F S PSSIVLP=$O(^PSDRUG("A527",PSSIVL,PSSIVLP)) Q:'PSSIVLP!(PSSIVLPX) D
..I $D(^PS(52.7,PSSIVLP,0)) I '$P($G(^("I")),"^")!($P($G(^("I")),"^")>DT) D IVX
IVQ ;
G:$O(PSSI(""))]"" CSS
S PSSIVLPX="" F S PSSIVLPX=$O(PSSGD(PSSIVLPX)) Q:PSSIVLPX="" D
.I PSSIVLPX[1 S PSSI(1)="" Q
.I PSSIVLPX[2,PSSIVLPX'["C" S PSSI(2)="" Q
.I PSSIVLPX[2,PSSIVLPX["C" S PSSI(2.5)="" Q
.I PSSIVLPX[3,PSSIVLPX'["C" S PSSI(3)="" Q
.I PSSIVLPX[3,PSSIVLPX["C" S PSSI(3.5)="" Q
.I PSSIVLPX[4 S PSSI(4)="" Q
.I PSSIVLPX[5 S PSSI(5)=""
CSS S PSSK=0 S PSSK=$O(PSSI(PSSK)) I PSSK S PSSIVDO=$E(PSSK)_$S($L(PSSK)>1:"n",1:"")
OIQ I PSSIVDO=0 S:'PSSIVDD PSSIVDO=""
I +PSSIVDO=1!(+PSSIVDO=2) S PSSIVDO=1_";"_PSSIVDO
I +PSSIVDO=3!(+PSSIVDO=4)!(+PSSIVDO=5) S PSSIVDO=2_";"_PSSIVDO
Q PSSIVDO
IVQ1 ;
I PSSIVDO=0,'PSSIVDD S PSSIVDO=""
Q PSSIVDO
;
IVX ;
S (PSSIVDD,PSSIVLPX)=1
S PSSIVDEA=$P($G(^PSDRUG(PSSIVL,0)),"^",3) S:PSSIVDEA]"" PSSGD(PSSIVDEA)=""
I +$P($G(^PSDRUG(PSSIVL,"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))=""
Q
;
MAXDS(INPUT) ; Returns the Maximum Day Supply to CPRS for a specific Drug or Orderable Item
; Input: INPUT("PSOI") - PHARMACY ORDERABLE ITEM (#50.7) IEN
; INPUT("DRUG") - DRUG file (#50) IEN
;Output: Maximum Days Supply (1 thru 365) - Default: 90
;
N MAXDS,DRG,DRGMAXDS
I +$G(INPUT("DRUG")) Q $$MXDAYSUP(+INPUT("DRUG"))
S MAXDS=90
I +$G(INPUT("PSOI")) D
. S DRG=0
. F S DRG=$O(^PSDRUG("ASP",+INPUT("PSOI"),DRG)) Q:'DRG D
. . S DRGMAXDS=$$MXDAYSUP(DRG) I DRGMAXDS<MAXDS S MAXDS=DRGMAXDS ;p255 '<' replaces '>'
Q MAXDS
;
MXDAYSUP(DRUG) ; Returns the Maximum Day Supply for the Dispense Drug
; Input: DRUG - Pointer to the DRUG file (#50)
;Output: MXDAYSUP - Maximum Days Supply allowed for the Dispense Drug
;
N MXDAYSUP,DRGMAXDS,NDFMAXDS,VAPRDIEN,DEASPHLG
; - Default value = 90
S MXDAYSUP=90
; - Invalid Dispense Drug
I '$D(^PSDRUG(+$G(DRUG),0)) Q MXDAYSUP
; - Retrieving Dispense Drug (If value is populated)
S DRGMAXDS=$$GET1^DIQ(50,DRUG,66) I DRGMAXDS S MXDAYSUP=DRGMAXDS
; - Retrieving NDF Maximum (If Drug is matched to NDF and value is populated)
S VAPRDIEN=+$$GET1^DIQ(50,DRUG,22,"I")
I VAPRDIEN D
. S NDFMAXDS=$$GET1^DIQ(50.68,VAPRDIEN,32)
. I NDFMAXDS,'DRGMAXDS S MXDAYSUP=NDFMAXDS
. I NDFMAXDS,DRGMAXDS,NDFMAXDS<DRGMAXDS S MXDAYSUP=NDFMAXDS
; - Controlled Substances have different upper limits (not 365)
S DEASPHLG=$$GET1^DIQ(50,DRUG,3)
I DEASPHLG["2",MXDAYSUP>30 S MXDAYSUP=30
I (DEASPHLG["3")!(DEASPHLG["4")!(DEASPHLG["5"),MXDAYSUP>90 S MXDAYSUP=90
;- Clozapine Drug
I $P($G(^PSDRUG(DRUG,"CLOZ1")),"^")="PSOCLO1" S MXDAYSUP=28
;
Q MXDAYSUP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSUTIL1 8557 printed Oct 16, 2024@18:35:16 Page 2
PSSUTIL1 ;BIR/RTR-Utility routine ;08/21/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**38,66,69,166,189,255**;9/30/97;Build 2
+2 ;Reference to ^PS(50.607 supported by DBIA #2221
+3 ;Reference to ^PSNAPIS supported by DBIA 2531
+4 ;
EN(PSSDRIEN) ;
+1 NEW PSSMASH,PSSMNDFS,PSSMSSTR,PSSMUNIT,PSSUNZ,PSSMA,PSSMB,PSSMA1,PSSMB1,PSSUNX,PSSMASH2,PSSMASH3,PSSNAT1,PSSNAT3,PSSNODEU
+2 IF '$GET(PSSDRIEN)
QUIT "|^^^^^99PSU"
+3 SET PSSMSSTR=$PIECE($GET(^PSDRUG(PSSDRIEN,"DOS")),"^")
SET PSSMUNIT=$PIECE($GET(^("DOS")),"^",2)
+4 SET PSSNAT1=$PIECE($GET(^PSDRUG(PSSDRIEN,"ND")),"^")
SET PSSNAT3=$PIECE($GET(^("ND")),"^",3)
IF PSSNAT1
IF PSSNAT3
SET PSSNODEU=$$DFSU^PSNAPIS(PSSNAT1,PSSNAT3)
SET PSSMNDFS=$PIECE(PSSNODEU,"^",4)
if '$GET(PSSMUNIT)
SET PSSMUNIT=$PIECE(PSSNODEU,"^",5)
+5 SET PSSUNZ=$PIECE($GET(^PS(50.607,+$GET(PSSMUNIT),0)),"^")
+6 IF PSSUNZ'["/"
QUIT $SELECT($GET(PSSMSSTR)'="":$GET(PSSMSSTR),$GET(PSSMNDFS)'="":$GET(PSSMNDFS),1:"")_"|"_"^^^"_$SELECT($GET(PSSMUNIT):$GET(PSSMUNIT),1:"")_"^"_$GET(PSSUNZ)_"^"_"99PSU"
+7 SET PSSMASH=0
+8 IF $GET(PSSMSSTR)
IF $GET(PSSMNDFS)
IF +$GET(PSSMSSTR)'=+$GET(PSSMNDFS)
SET PSSMASH=1
+9 IF 'PSSMASH
QUIT PSSMSSTR_"|"_"^^^"_$SELECT($GET(PSSMUNIT):$GET(PSSMUNIT),1:"")_"^"_$GET(PSSUNZ)_"^"_"99PSU"
+10 SET PSSMA=$PIECE(PSSUNZ,"/")
SET PSSMB=$PIECE(PSSUNZ,"/",2)
SET PSSMA1=+$GET(PSSMA)
SET PSSMB1=+$GET(PSSMB)
+11 SET PSSMASH2=PSSMSSTR/PSSMNDFS
SET PSSMASH3=PSSMASH2*($SELECT($GET(PSSMB1):$GET(PSSMB1),1:1))
+12 SET PSSUNX=$GET(PSSMA)_"/"_$GET(PSSMASH3)_$SELECT('$GET(PSSMB1):$GET(PSSMB),1:$PIECE(PSSMB,PSSMB1,2))
+13 QUIT $SELECT($GET(PSSMSSTR)'="":$GET(PSSMSSTR),$GET(PSSMNDFS)'="":$GET(PSSMNDFS),1:"")_"|"_"^^^^"_$GET(PSSUNX)_"^"_"99PSU"
+14 ;
+15 QUIT
+16 ;
DRG(PSSDD,PSSOI,PSSPK) ;
+1 ; PSSDD - Array of Drugs
+2 ; PSSOI - Orderable Item (Pharmacy)
+3 ; PSSPK - Application Package ("O"-Outpatient;"I"-IV;"X"-Non-VA Med)
+4 ;Return active dispense drugs for package based on Orderable Item
+5 NEW PSSL,PSSAP,PSSIN,PSSND
+6 if '$GET(PSSOI)
QUIT
+7 IF $GET(PSSPK)'="O"
IF $GET(PSSPK)'="I"
IF $GET(PSSPK)'="X"
QUIT
+8 FOR PSSL=0:0
SET PSSL=$ORDER(^PSDRUG("ASP",PSSOI,PSSL))
if 'PSSL
QUIT
Begin DoDot:1
+9 SET PSSIN=$PIECE($GET(^PSDRUG(PSSL,"I")),"^")
SET PSSAP=$PIECE($GET(^(2)),"^",3)
+10 IF PSSIN
IF PSSIN<DT
QUIT
+11 SET PSSND=$PIECE($GET(^PSDRUG(PSSL,"ND")),"^")
+12 IF PSSPK="O"!(PSSPK="X")
Begin DoDot:2
+13 if PSSAP[PSSPK
SET PSSDD(PSSL_";"_PSSND)=$PIECE($GET(^PSDRUG(PSSL,0)),"^")
End DoDot:2
QUIT
+14 IF PSSAP["I"!(PSSAP["U")
Begin DoDot:2
+15 SET PSSDD(PSSL_";"_PSSND)=$PIECE($GET(^PSDRUG(PSSL,0)),"^")
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
ITEM(PSSIT,PSSDR) ;Return Orderable Item to CPRS
+1 NEW PSSNEW
+2 IF '$GET(PSSIT)!('$GET(PSSDR))
QUIT -1
+3 IF '$DATA(^PS(50.7,+$GET(PSSIT),0))!('$DATA(^PSDRUG(+$GET(PSSDR),0)))
QUIT -1
+4 SET PSSNEW=+$PIECE($GET(^PSDRUG(+$GET(PSSDR),2)),"^")
+5 IF PSSNEW
IF PSSNEW=$GET(PSSIT)
QUIT 0
+6 IF PSSNEW
IF PSSNEW'=$GET(PSSIT)
QUIT 1_"^"_PSSNEW
+7 QUIT -1
+8 ;
+9 QUIT
+10 ;
EN1(PSSOA,PSSOAP) ;
+1 ;Return Orderable Item Forumary Alternatives to CPRS
+2 ;PSSOA = Pharmacy Orderable Item number
+3 ;PSSOAP = "I" For Inpatient, "O" For Outpatient
+4 if '$GET(PSSOA)
QUIT
+5 IF $GET(PSSOAP)'="O"
IF $GET(PSSOAP)'="I"
QUIT
+6 NEW PSSOAL,PSSOALD,PSSOAN,PSSOAIT,PSSOADT,PSSOAZ
+7 SET PSSOAL=""
FOR
SET PSSOAL=$ORDER(^PSDRUG("ASP",PSSOA,PSSOAL))
if PSSOAL=""
QUIT
Begin DoDot:1
+8 SET PSSOALD=""
FOR
SET PSSOALD=$ORDER(^PSDRUG(PSSOAL,65,PSSOALD))
if PSSOALD=""
QUIT
Begin DoDot:2
+9 SET PSSOAN=$PIECE($GET(^PSDRUG(PSSOAL,65,PSSOALD,0)),"^")
IF PSSOAN
SET PSSOAIT=$PIECE($GET(^PSDRUG(PSSOAN,2)),"^")
if PSSOAIT
Begin DoDot:3
+10 if PSSOAIT=PSSOA
QUIT
+11 if $DATA(PSSOA(PSSOAIT))
QUIT
+12 if '$DATA(^PS(50.7,PSSOAIT,0))!($PIECE($GET(^PS(50.7,PSSOAIT,0)),"^",12))
QUIT
+13 if $PIECE($GET(^PS(50.7,PSSOAIT,0)),"^",4)&(+$PIECE($GET(^(0)),"^",4)'>DT)
QUIT
+14 SET PSSOAZ=""
FOR
SET PSSOAZ=$ORDER(^PSDRUG("ASP",PSSOAIT,PSSOAZ))
if PSSOAZ=""!($DATA(PSSOA(PSSOAIT)))
QUIT
Begin DoDot:4
+15 if $PIECE($GET(^PSDRUG(PSSOAZ,"I")),"^")&(+$PIECE($GET(^("I")),"^")'>DT)
QUIT
+16 if $PIECE($GET(^PSDRUG(PSSOAZ,0)),"^",9)
QUIT
+17 IF $GET(PSSOAP)="O"
if $PIECE($GET(^PSDRUG(PSSOAZ,2)),"^",3)["O"
SET PSSOA(PSSOAIT)=""
QUIT
+18 IF $PIECE($GET(^PSDRUG(PSSOAZ,2)),"^",3)["I"!($PIECE($GET(^(2)),"^",3)["U")
SET PSSOA(PSSOAIT)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
SCH(SCH) ;Expand schedule for Outpatient order in CPRS
+1 NEW SQFLAG,SCLOOP,SCLP,SCLPS,SCLHOLD,SCIN,SODL,SST,SCHEX
+2 SET SCHEX=$GET(SCH)
SET SQFLAG=0
+3 IF $GET(SCH)=""
GOTO SCHQT
+4 ;I SCH[""""!($A(SCH)=45)!(SCH?.E1C.E)!($L(SCH," ")>3)!($L(SCH)>20)!($L(SCH)<1) K SCH Q
+5 FOR SCLOOP=0:0
SET SCLOOP=$ORDER(^PS(51.1,"B",SCH,SCLOOP))
if 'SCLOOP!(SQFLAG)
QUIT
IF $PIECE($GET(^PS(51.1,SCLOOP,0)),"^",8)'=""
SET SCHEX=$PIECE($GET(^(0)),"^",8)
SET SQFLAG=1
+6 IF SQFLAG
GOTO SCHQT
+7 IF $PIECE($GET(^PS(51,"A",SCH)),"^")'=""
SET SCHEX=$PIECE(^(SCH),"^")
GOTO SCHQT
+8 SET SCLOOP=0
FOR SCLP=1:1:$LENGTH(SCH)
SET SCLPS=$EXTRACT(SCH,SCLP)
IF SCLPS=" "
SET SCLOOP=SCLOOP+1
+9 IF SCLOOP=0
SET SCHEX=SCH
GOTO SCHQT
+10 SET SCLOOP=SCLOOP+1
+11 KILL SCLHOLD
FOR SCIN=1:1:SCLOOP
SET (SODL,SCLHOLD(SCIN))=$PIECE(SCH," ",SCIN)
Begin DoDot:1
+12 if $GET(SODL)=""
QUIT
+13 SET SQFLAG=0
FOR SST=0:0
SET SST=$ORDER(^PS(51.1,"B",SODL,SST))
if 'SST!($GET(SQFLAG))
QUIT
IF $PIECE($GET(^PS(51.1,SST,0)),"^",8)'=""
SET SCLHOLD(SCIN)=$PIECE($GET(^(0)),"^",8)
SET SQFLAG=1
+14 if $GET(SQFLAG)
QUIT
+15 IF $PIECE($GET(^PS(51,"A",SODL)),"^")'=""
SET SCLHOLD(SCIN)=$PIECE(^(SODL),"^")
End DoDot:1
+16 SET SCHEX=""
SET SQFLAG=0
FOR SST=1:1:SCLOOP
SET SCHEX=SCHEX_$SELECT($GET(SQFLAG):" ",1:"")_$GET(SCLHOLD(SST))
SET SQFLAG=1
SCHQT ;
+1 SET SCH=SCHEX
+2 QUIT
+3 ;
IVDEA(PSSIVOI,PSSIVOIP) ;CS Federal Schedule/DEA Special Handling to CPRS for IV Fluids dialogue
+1 ;parameter 1 is Orderable Item
+2 ;parameter 2 is "A" for Additive, "S" for Solution
+3 ;Return the CS Federal Schedule code in the VA PRODUCT file (#50.68)
+4 ;or the DEA Special Hndl code depending on the "ND" node of the
+5 ;drugs associated to the Orderable Item.
+6 ;1;1 Sch. I Nar.
+7 ;1;2 II
+8 ;1;2n II Non-Nar.
+9 ;2;3 III
+10 ;2;3n III Non-Nar.
+11 ;2;4 IV
+12 ;2;5 V
+13 ;0 there are other active drugs
+14 ;"" no active drugs
+15 NEW PSSIVDO,PSSIVDD,PSSIVL,PSSIVLP,PSSIVDEA,PSSIVLPX,PSSK,PSSI,PSSGD
+16 SET (PSSIVDO,PSSIVDD)=0
+17 IF $GET(PSSIVOIP)'="S"
SET PSSIVOIP="A"
+18 IF '$GET(PSSIVOI)
GOTO IVQ1
+19 SET PSSIVL=""
FOR
SET PSSIVL=$ORDER(^PSDRUG("ASP",PSSIVOI,PSSIVL))
if 'PSSIVL
QUIT
Begin DoDot:1
+20 IF $PIECE($GET(^PSDRUG(PSSIVL,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+21 IF $PIECE($GET(^PSDRUG(PSSIVL,2)),"^",3)'["I"
IF $PIECE($GET(^(2)),"^",3)'["U"
QUIT
+22 SET PSSIVDD=1
+23 IF PSSIVOIP="A"
Begin DoDot:2
+24 SET (PSSIVLP,PSSIVLPX)=0
FOR
SET PSSIVLP=$ORDER(^PSDRUG("A526",PSSIVL,PSSIVLP))
if 'PSSIVLP!(PSSIVLPX)
QUIT
Begin DoDot:3
+25 IF $DATA(^PS(52.6,PSSIVLP,0))
IF '$PIECE($GET(^("I")),"^")!($PIECE($GET(^("I")),"^")>DT)
DO IVX
End DoDot:3
End DoDot:2
QUIT
+26 SET (PSSIVLP,PSSIVLPX)=0
FOR
SET PSSIVLP=$ORDER(^PSDRUG("A527",PSSIVL,PSSIVLP))
if 'PSSIVLP!(PSSIVLPX)
QUIT
Begin DoDot:2
+27 IF $DATA(^PS(52.7,PSSIVLP,0))
IF '$PIECE($GET(^("I")),"^")!($PIECE($GET(^("I")),"^")>DT)
DO IVX
End DoDot:2
End DoDot:1
IVQ ;
+1 if $ORDER(PSSI(""))]""
GOTO CSS
+2 SET PSSIVLPX=""
FOR
SET PSSIVLPX=$ORDER(PSSGD(PSSIVLPX))
if PSSIVLPX=""
QUIT
Begin DoDot:1
+3 IF PSSIVLPX[1
SET PSSI(1)=""
QUIT
+4 IF PSSIVLPX[2
IF PSSIVLPX'["C"
SET PSSI(2)=""
QUIT
+5 IF PSSIVLPX[2
IF PSSIVLPX["C"
SET PSSI(2.5)=""
QUIT
+6 IF PSSIVLPX[3
IF PSSIVLPX'["C"
SET PSSI(3)=""
QUIT
+7 IF PSSIVLPX[3
IF PSSIVLPX["C"
SET PSSI(3.5)=""
QUIT
+8 IF PSSIVLPX[4
SET PSSI(4)=""
QUIT
+9 IF PSSIVLPX[5
SET PSSI(5)=""
End DoDot:1
CSS SET PSSK=0
SET PSSK=$ORDER(PSSI(PSSK))
IF PSSK
SET PSSIVDO=$EXTRACT(PSSK)_$SELECT($LENGTH(PSSK)>1:"n",1:"")
OIQ IF PSSIVDO=0
if 'PSSIVDD
SET PSSIVDO=""
+1 IF +PSSIVDO=1!(+PSSIVDO=2)
SET PSSIVDO=1_";"_PSSIVDO
+2 IF +PSSIVDO=3!(+PSSIVDO=4)!(+PSSIVDO=5)
SET PSSIVDO=2_";"_PSSIVDO
+3 QUIT PSSIVDO
IVQ1 ;
+1 IF PSSIVDO=0
IF 'PSSIVDD
SET PSSIVDO=""
+2 QUIT PSSIVDO
+3 ;
IVX ;
+1 SET (PSSIVDD,PSSIVLPX)=1
+2 SET PSSIVDEA=$PIECE($GET(^PSDRUG(PSSIVL,0)),"^",3)
if PSSIVDEA]""
SET PSSGD(PSSIVDEA)=""
+3 IF +$PIECE($GET(^PSDRUG(PSSIVL,"ND")),"^",3)
SET PSSK=$PIECE(^("ND"),"^",3)
Begin DoDot:1
+4 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:1
+5 QUIT
+6 ;
MAXDS(INPUT) ; Returns the Maximum Day Supply to CPRS for a specific Drug or Orderable Item
+1 ; Input: INPUT("PSOI") - PHARMACY ORDERABLE ITEM (#50.7) IEN
+2 ; INPUT("DRUG") - DRUG file (#50) IEN
+3 ;Output: Maximum Days Supply (1 thru 365) - Default: 90
+4 ;
+5 NEW MAXDS,DRG,DRGMAXDS
+6 IF +$GET(INPUT("DRUG"))
QUIT $$MXDAYSUP(+INPUT("DRUG"))
+7 SET MAXDS=90
+8 IF +$GET(INPUT("PSOI"))
Begin DoDot:1
+9 SET DRG=0
+10 FOR
SET DRG=$ORDER(^PSDRUG("ASP",+INPUT("PSOI"),DRG))
if 'DRG
QUIT
Begin DoDot:2
+11 ;p255 '<' replaces '>'
SET DRGMAXDS=$$MXDAYSUP(DRG)
IF DRGMAXDS<MAXDS
SET MAXDS=DRGMAXDS
End DoDot:2
End DoDot:1
+12 QUIT MAXDS
+13 ;
MXDAYSUP(DRUG) ; Returns the Maximum Day Supply for the Dispense Drug
+1 ; Input: DRUG - Pointer to the DRUG file (#50)
+2 ;Output: MXDAYSUP - Maximum Days Supply allowed for the Dispense Drug
+3 ;
+4 NEW MXDAYSUP,DRGMAXDS,NDFMAXDS,VAPRDIEN,DEASPHLG
+5 ; - Default value = 90
+6 SET MXDAYSUP=90
+7 ; - Invalid Dispense Drug
+8 IF '$DATA(^PSDRUG(+$GET(DRUG),0))
QUIT MXDAYSUP
+9 ; - Retrieving Dispense Drug (If value is populated)
+10 SET DRGMAXDS=$$GET1^DIQ(50,DRUG,66)
IF DRGMAXDS
SET MXDAYSUP=DRGMAXDS
+11 ; - Retrieving NDF Maximum (If Drug is matched to NDF and value is populated)
+12 SET VAPRDIEN=+$$GET1^DIQ(50,DRUG,22,"I")
+13 IF VAPRDIEN
Begin DoDot:1
+14 SET NDFMAXDS=$$GET1^DIQ(50.68,VAPRDIEN,32)
+15 IF NDFMAXDS
IF 'DRGMAXDS
SET MXDAYSUP=NDFMAXDS
+16 IF NDFMAXDS
IF DRGMAXDS
IF NDFMAXDS<DRGMAXDS
SET MXDAYSUP=NDFMAXDS
End DoDot:1
+17 ; - Controlled Substances have different upper limits (not 365)
+18 SET DEASPHLG=$$GET1^DIQ(50,DRUG,3)
+19 IF DEASPHLG["2"
IF MXDAYSUP>30
SET MXDAYSUP=30
+20 IF (DEASPHLG["3")!(DEASPHLG["4")!(DEASPHLG["5")
IF MXDAYSUP>90
SET MXDAYSUP=90
+21 ;- Clozapine Drug
+22 IF $PIECE($GET(^PSDRUG(DRUG,"CLOZ1")),"^")="PSOCLO1"
SET MXDAYSUP=28
+23 ;
+24 QUIT MXDAYSUP
