PSOSUCAT ;EPIP/RTW -Print From Suspense By Category ;08/01/14 14:53
;;7.0;OUTPATIENT PHARMACY;**452**;DEC 1997;Build 56
;---------------------------------------------------------------------
; ICR# TYPE DESCRIPTION
;----- ------- ------------------------------------
;10026 Support ^DIK
;---------------------------------------------------------------------
START N DIR,X,Y,DTOUT,DUOUT,PSOSULST,PSORESP,PSOSTPF,PSOMOD,PSOTAG
S CNT=0
s DIR("B")="ALL"
S DIR(0)="SBO^A:ALL;N:Non-Controlled Drugs;C:Controlled Substances;S:Supplies;R:Refrigerated Items;D:Drugs;V:VA Classifications;E:Exit"
S DIR("A")="Select Print Category"
S DIR("T")=DTIME
S DIR("?",1)="Enter 'A' ALL Prescriptions on Suspense for the Division"
S DIR("?",2)=" 'N' Non-Controlled Rx or OTCs (Special Handling Code 6 or 9)"
S DIR("?",3)=" 'C' Controlled Substance Prescriptions (DEA 1, 2, 3, 4, 5)"
S DIR("?",4)=" 'S' Supply Prescriptions (Special Handling Code 'S')"
S DIR("?",5)=" 'R' Refrigerated Prescriptions (Special Handling Code 'Q')"
S DIR("?",6)=" 'D' Prescriptions by Selected Drugs"
S DIR("?",7)=" 'V' Prescriptions by Selected VA Classifications"
S DIR("?",8)=" or 'E' or '^' to Exit"
S DIR("?")=" "
D ^DIR K DIR I $D(DIRUT)!(Y="E") D MESS^PSOSULB1 G EXIT^PSOSULBL
I Y="A" G ASK^PSOSULB1
I Y="N" S PSORESP="N^Non-Controlled Drugs^DEA"
I Y="C" S PSORESP="C^Controlled Substances^DEA"
I Y="D" S PSORESP="D^Specific Drugs^DRUG"
I Y="V" S PSORESP="V^Specific VA Class^CLASS"
I Y="S" S PSORESP="S^Supplies^SUPPLY"
I Y="R" S PSORESP="R^Refrigerated Items^FRIDGE"
S PSOSULST($P(PSORESP,U,3))=""
D INVR I $D(PSOSTPF) D MESS^PSOSULB1 G EXIT^PSOSULBL
D DISPENSE I $D(PSOSTPF) D MESS^PSOSULB1 G EXIT^PSOSULBL
I "SR"'[$P(PSORESP,U) D @$P(PSORESP,U) I $D(PSOSTPF) D MESS^PSOSULB1 G EXIT^PSOSULBL
S PSOTAG="" F S PSOTAG=$O(PSOSULST(PSOTAG)) Q:PSOTAG']"" S PSOSULST(PSOTAG)=PSOMOD
D CONT I $D(PSOSTPF) D MESS^PSOSULB1 G EXIT^PSOSULBL
G ASK^PSOSULB1
INVR N DIR
S DIR(0)="SBAO^Include:Include "_$P(PSORESP,U,2)_";Exclude:Exclude "_$P(PSORESP,U,2)
S DIR("A")=$P(PSORESP,U,2)_": ",DIR("B")="Include"
S DIR("T")=DTIME
D ^DIR S:$D(DIRUT) PSOSTPF=1 Q:$D(PSOSTPF)
S PSOMOD=""
I Y["Exclude" S PSOMOD="1"
Q
DISPENSE N DIR
S DIR(0)="SBAO^M:Mail;W:Window;B:Both Mail and Window"
S DIR("A")=$S($P(PSOMOD,U):"Exclude:",1:"Include:")_" Mail (M), Window (W), Both (B): ",DIR("B")="Both"
S DIR("T")=DTIME
D ^DIR S:$D(DIRUT) PSOSTPF=1 Q:$D(PSOSTPF)
S PSOMOD=PSOMOD_"^"_$S((Y="B"):"",1:Y)
Q
INCLD N DIR,PSOPMT
S DIR(0)="YO",DIR("B")="YES"
S DIR("T")=DTIME
S PSOPMT=$S(1:$P(PSOMOD,U),1:"")
I $P(PSORESP,U)="N",$G(PSOPMT) D
. S DIR("?")=" ",DIR("?",1)="Enter 'YES' to EXCLUDE refrigerated "_$P(PSORESP,U,2)_" from printing."
. S DIR("?",2)="Enter 'NO' to print refrigerated "_$P(PSORESP,U,2)_" in addition to the"
. S DIR("?",3)="other categories."
I $P(PSORESP,U)="N",'$G(PSOPMT) D
. S DIR("?")=" ",DIR("?",1)="Enter 'NO' to EXCLUDE refrigerated "_$P(PSORESP,U,2)_" from printing."
. S DIR("?",2)="Enter 'YES' to print refrigerated "_$P(PSORESP,U,2)_"."
I $P(PSORESP,U)="C",$G(PSOPMT) D
. S DIR("?")=" "
. S DIR("?",1)="Enter 'YES' to EXCLUDE refrigerated "_$P(PSORESP,U,2)_" of the selected range"
. S DIR("?",2)="from printing."
. S DIR("?",3)="Enter 'NO' to print refrigerated "_$P(PSORESP,U,2)_" of the selected range"
. S DIR("?",4)="in addition to the other categories."
I $P(PSORESP,U)="C",'$G(PSOPMT) D
. S DIR("?")=" ",DIR("?",1)="Enter 'NO' to EXCLUDE refrigerated "_$P(PSORESP,U,2)_" of the selected range"
. S DIR("?",2)="from printing."
. S DIR("?",3)="Enter 'YES' to print refrigerated "_$P(PSORESP,U,2)_" of the selected range."
S DIR("A")=$S($P(PSOMOD,U):"Exclude",1:"Include")_" Refrigerated Items" D ^DIR S:$D(DIRUT) PSOSTPF=1 Q:$D(PSOSTPF) S:Y>0 PSOMOD=PSOMOD_"^" S:Y=0 PSOMOD=PSOMOD_"^Q"
I $P(PSORESP,U)="N",$G(PSOPMT) D
. S DIR("?")=" "
. S DIR("?",1)="Enter 'YES' to EXCLUDE Non-Controlled supplies from printing."
. S DIR("?",2)="Enter 'NO' to print Non-Controlled supplies in addition to the"
. S DIR("?",3)="other categories."
I $P(PSORESP,U)="N",'$G(PSOPMT) D
. S DIR("?")=" "
. S DIR("?",1)="Enter 'NO' to EXCLUDE Non-Controlled supplies from printing."
. S DIR("?",2)="Enter 'YES' to print Non-Controlled supplies."
I $P(PSORESP,U)="N" S DIR("A")=$S($P(PSOMOD,U):"Exclude",1:"Include")_" Supplies" D ^DIR S:$D(DIRUT) PSOSTPF=1 Q:$D(PSOSTPF) S:Y>0 PSOMOD=PSOMOD_"^" S:Y=0 PSOMOD=PSOMOD_"^S"
Q
CONT N DIR
S DIR(0)="YO"
S DIR("A")="Print Suspended '"_$P(PSORESP,U,2)_"' selections" ;rtw
I $P(PSOMOD,U) S DIR("A")="Print everything Suspended EXCEPT '"_$P(PSORESP,U,2)_"' selections" ;rtw
S DIR("B")="NO"
S DIR("T")=DTIME
W ! D ^DIR S:Y'>0 PSOSTPF=1
Q
N N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="SBO^Rx:Rx;OTC:OTC;Both:Both Rx and OTC"
S DIR("A")="Include the following"
I $P(PSOMOD,U) S DIR("A")="Exclude the following"
S DIR("?",1)="Enter 'Rx' Prescriptions for Legend Drugs (Special Handling Code 6)"
S DIR("?",2)=" 'OTC' Prescriptions for OTC Drugs (Special Handling Code 9)"
S DIR("?",3)=" 'Both' Prescriptions for BOTH Legend and OTC Drugs"
S DIR("?")=" "
S DIR("B")="Both"
S DIR("T")=DTIME
D ^DIR K DIR S:$D(DIRUT)!(Y="E") PSOSTPF=1 Q:$D(PSOSTPF)
I Y="Rx" S PSOSULST($P(PSORESP,U,3),6)=""
I Y="OTC" S PSOSULST($P(PSORESP,U,3),9)=""
I Y="Both" S PSOSULST($P(PSORESP,U,3),6)="",PSOSULST($P(PSORESP,U,3),9)=""
D INCLD Q:$D(PSOSTPF)
Q
C N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="LAO^1:5:0"
S DIR("A")="Enter a list or range of CS Federal Schedules to INCLUDE (1-5): "
I $P(PSOMOD,U) S DIR("A")="Enter list or range of CS Federal Schedules to EXCLUDE (1-5): "
S DIR("B")="1-5"
S DIR("?")="This response must be a list or range, e.g. 2,4 or 3-5."
S DIR("T")=DTIME
D ^DIR K DIR S:$D(DIRUT) PSOSTPF=1 Q:$D(PSOSTPF)
N XX F XX=1:1:($L(Y,",")-1) S PSOSULST($P(PSORESP,U,3),+$P(Y,",",XX))=""
D INCLD Q:$D(PSOSTPF)
Q
D N PSODRG,PSOSORT,PSOSRT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
D DSLCT S:'$O(PSOSULST($P(PSORESP,U,3),"")) PSOSTPF=1 Q:$D(PSOSTPF) D
. W !!,"Drugs Selected:"
. S PSODRG=0 F S PSODRG=$O(PSOSULST($P(PSORESP,U,3),PSODRG)) Q:'PSODRG D
.. S PSOSORT($P(^PSDRUG(PSODRG,0),U))=""
. S PSOSRT="" F S PSOSRT=$O(PSOSORT(PSOSRT)) Q:PSOSRT="" D
.. W !,PSOSRT
Q
DSLCT N DIC,X,Y,DTOUT,DUOUT
S DIC=50,DIC(0)="AEQM"
DSLCT2 D ^DIC Q:Y'>0 S PSOSULST($P(PSORESP,U,3),+Y)=""
S DIC("A")="Select Another DRUG GENERIC NAME: "
G DSLCT2
Q
V N PSOCLSS,PSOSORT,PSOSRT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
D VSLCT S:'$O(PSOSULST($P(PSORESP,U,3),"")) PSOSTPF=1 Q:$D(PSOSTPF) D
. W !!,"VA Classification Selected:"
. S PSOCLSS=0 F S PSOCLSS=$O(PSOSULST($P(PSORESP,U,3),PSOCLSS)) Q:'PSOCLSS D
.. S PSOSORT($P(^PS(50.605,PSOCLSS,0),U))=""
. S PSOSRT="" F S PSOSRT=$O(PSOSORT(PSOSRT)) Q:PSOSRT="" D
.. W !,PSOSRT
Q
VSLCT N DIC,X,Y,DTOUT,DUOUT
S DIC=50.605,DIC(0)="AEQM"
VSLCT2 N PSOCLSIN,PSOVACLS,CHLDCLSS
D ^DIC Q:Y'>0 S PSOCLSIN=+Y S PSOSULST($P(PSORESP,U,3),+Y)=""
S PSOVACLS=$P(^PS(50.605,PSOCLSIN,0),U)
D VDISP,VSPLIT
W !
S DIC("A")="Select Another VA DRUG CLASS CODE: "
G VSLCT2
Q
VDISP N OI,PSODRG
N CNT S CNT=0
S OI=0 F S OI=$O(^PSDRUG("AOC",OI)) Q:'OI S PSODRG=0 F S PSODRG=$O(^PSDRUG("AOC",OI,PSOVACLS,PSODRG)) Q:'PSODRG D
. S CNT=CNT+1 I CNT=1 W !!,"Dispense Drugs for VA Class ",PSOVACLS," are:"
. W !,$P(^PSDRUG(PSODRG,0),U)
Q
VSPLIT I $D(^PS(50.605,"AC",PSOCLSIN)) D
. S CHLDCLSS=0 F S CHLDCLSS=$O(^PS(50.605,"AC",PSOCLSIN,CHLDCLSS)) D:$D(^PS(50.605,"AC",+CHLDCLSS)) VSPLIT2 Q:'+CHLDCLSS D
.. S PSOSULST($P(PSORESP,U,3),+CHLDCLSS)="",PSOVACLS=$P(^PS(50.605,CHLDCLSS,0),"^") D VDISP
Q
VSPLIT2 N CHLDCLSS2
S CHLDCLSS2=0 F S CHLDCLSS2=$O(^PS(50.605,"AC",CHLDCLSS,CHLDCLSS2)) Q:'+CHLDCLSS2 S PSOSULST($P(PSORESP,U,3),+CHLDCLSS2)="",PSOVACLS=$P(^PS(50.605,CHLDCLSS2,0),"^") D VDISP
Q
EN N PSODRUG,PSODEA,PSOIEN,PSOMW,PSOPP,PSONODE,PSOVACLS
S PSOIEN=+$G(^PS(52.5,SFN,0)) Q:'PSOIEN S PSODRUG=$P($G(^PSRX(PSOIEN,0)),U,6)
S PSODEA=$P($G(^PSDRUG(PSODRUG,0)),U,3),PSOVACLS=$P($G(^PSDRUG(PSODRUG,0)),U,2),PSOOK=+PSOSULST($O(PSOSULST("")))
S PSONODE=$G(^PS(52.5,SFN,0)) D
. I $P(PSONODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(PSONODE),"Q",$P(PSONODE,"^",5),0)),"^",2) Q
. I $P(PSONODE,"^",13)!($O(^PSRX(+$G(PSONODE),1,0))) D Q
.. I $P(PSONODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(PSONODE),1,$P(PSONODE,"^",13),0)),"^",2) Q
.. F PSOPP=0:0 S PSOPP=$O(^PSRX(+$G(PSONODE),1,PSOPP)) Q:'PSOPP S PSOMW=$P($G(^PSRX(+$G(PSONODE),1,PSOPP,0)),"^",2)
. S PSOMW=$P($G(^PSRX(+$G(PSONODE),0)),"^",11)
D @$O(PSOSULST(""))
Q
DEA N XX
S XX="" F S XX=$O(PSOSULST("DEA",XX)) Q:'XX I (PSODEA[XX)&(PSOMW[$P(PSOSULST("DEA"),U,2)) S PSOOK='PSOOK D
. I (($P(PSOSULST("DEA"),U,3)="Q")&(PSODEA["Q"))!(($P(PSOSULST("DEA"),U,4)="S")&(PSODEA["S")) S PSOOK='PSOOK
. I PSOOK'=+PSOSULST("DEA") Q
Q
DRUG N PSODRG
S PSODRG="" F S PSODRG=$O(PSOSULST("DRUG",PSODRG)) Q:'PSODRG D
. I (PSODRUG=PSODRG)&(PSOMW[$P(PSOSULST("DRUG"),U,2)) S PSOOK='PSOOK Q
Q
CLASS N PSOCLSS
S PSOCLSS="" F S PSOCLSS=$O(PSOSULST("CLASS",PSOCLSS)) Q:'PSOCLSS D
. I (PSOVACLS=$P(^PS(50.605,PSOCLSS,0),U))&(PSOMW[$P(PSOSULST("CLASS"),U,2)) S PSOOK='PSOOK Q
Q
SUPPLY I (PSODEA["S")&(PSOMW[$P(PSOSULST("SUPPLY"),U,2)) S PSOOK='PSOOK
Q
FRIDGE I (PSODEA["Q")&(PSOMW[$P(PSOSULST("FRIDGE"),U,2)) S PSOOK='PSOOK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUCAT 9521 printed Sep 23, 2025@20:11:45 Page 2
PSOSUCAT ;EPIP/RTW -Print From Suspense By Category ;08/01/14 14:53
+1 ;;7.0;OUTPATIENT PHARMACY;**452**;DEC 1997;Build 56
+2 ;---------------------------------------------------------------------
+3 ; ICR# TYPE DESCRIPTION
+4 ;----- ------- ------------------------------------
+5 ;10026 Support ^DIK
+6 ;---------------------------------------------------------------------
START NEW DIR,X,Y,DTOUT,DUOUT,PSOSULST,PSORESP,PSOSTPF,PSOMOD,PSOTAG
+1 SET CNT=0
+2 SET DIR("B")="ALL"
+3 SET DIR(0)="SBO^A:ALL;N:Non-Controlled Drugs;C:Controlled Substances;S:Supplies;R:Refrigerated Items;D:Drugs;V:VA Classifications;E:Exit"
+4 SET DIR("A")="Select Print Category"
+5 SET DIR("T")=DTIME
+6 SET DIR("?",1)="Enter 'A' ALL Prescriptions on Suspense for the Division"
+7 SET DIR("?",2)=" 'N' Non-Controlled Rx or OTCs (Special Handling Code 6 or 9)"
+8 SET DIR("?",3)=" 'C' Controlled Substance Prescriptions (DEA 1, 2, 3, 4, 5)"
+9 SET DIR("?",4)=" 'S' Supply Prescriptions (Special Handling Code 'S')"
+10 SET DIR("?",5)=" 'R' Refrigerated Prescriptions (Special Handling Code 'Q')"
+11 SET DIR("?",6)=" 'D' Prescriptions by Selected Drugs"
+12 SET DIR("?",7)=" 'V' Prescriptions by Selected VA Classifications"
+13 SET DIR("?",8)=" or 'E' or '^' to Exit"
+14 SET DIR("?")=" "
+15 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y="E")
DO MESS^PSOSULB1
GOTO EXIT^PSOSULBL
+16 IF Y="A"
GOTO ASK^PSOSULB1
+17 IF Y="N"
SET PSORESP="N^Non-Controlled Drugs^DEA"
+18 IF Y="C"
SET PSORESP="C^Controlled Substances^DEA"
+19 IF Y="D"
SET PSORESP="D^Specific Drugs^DRUG"
+20 IF Y="V"
SET PSORESP="V^Specific VA Class^CLASS"
+21 IF Y="S"
SET PSORESP="S^Supplies^SUPPLY"
+22 IF Y="R"
SET PSORESP="R^Refrigerated Items^FRIDGE"
+23 SET PSOSULST($PIECE(PSORESP,U,3))=""
+24 DO INVR
IF $DATA(PSOSTPF)
DO MESS^PSOSULB1
GOTO EXIT^PSOSULBL
+25 DO DISPENSE
IF $DATA(PSOSTPF)
DO MESS^PSOSULB1
GOTO EXIT^PSOSULBL
+26 IF "SR"'[$PIECE(PSORESP,U)
DO @$PIECE(PSORESP,U)
IF $DATA(PSOSTPF)
DO MESS^PSOSULB1
GOTO EXIT^PSOSULBL
+27 SET PSOTAG=""
FOR
SET PSOTAG=$ORDER(PSOSULST(PSOTAG))
if PSOTAG']""
QUIT
SET PSOSULST(PSOTAG)=PSOMOD
+28 DO CONT
IF $DATA(PSOSTPF)
DO MESS^PSOSULB1
GOTO EXIT^PSOSULBL
+29 GOTO ASK^PSOSULB1
INVR NEW DIR
+1 SET DIR(0)="SBAO^Include:Include "_$PIECE(PSORESP,U,2)_";Exclude:Exclude "_$PIECE(PSORESP,U,2)
+2 SET DIR("A")=$PIECE(PSORESP,U,2)_": "
SET DIR("B")="Include"
+3 SET DIR("T")=DTIME
+4 DO ^DIR
if $DATA(DIRUT)
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
+5 SET PSOMOD=""
+6 IF Y["Exclude"
SET PSOMOD="1"
+7 QUIT
DISPENSE NEW DIR
+1 SET DIR(0)="SBAO^M:Mail;W:Window;B:Both Mail and Window"
+2 SET DIR("A")=$SELECT($PIECE(PSOMOD,U):"Exclude:",1:"Include:")_" Mail (M), Window (W), Both (B): "
SET DIR("B")="Both"
+3 SET DIR("T")=DTIME
+4 DO ^DIR
if $DATA(DIRUT)
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
+5 SET PSOMOD=PSOMOD_"^"_$SELECT((Y="B"):"",1:Y)
+6 QUIT
INCLD NEW DIR,PSOPMT
+1 SET DIR(0)="YO"
SET DIR("B")="YES"
+2 SET DIR("T")=DTIME
+3 SET PSOPMT=$SELECT(1:$PIECE(PSOMOD,U),1:"")
+4 IF $PIECE(PSORESP,U)="N"
IF $GET(PSOPMT)
Begin DoDot:1
+5 SET DIR("?")=" "
SET DIR("?",1)="Enter 'YES' to EXCLUDE refrigerated "_$PIECE(PSORESP,U,2)_" from printing."
+6 SET DIR("?",2)="Enter 'NO' to print refrigerated "_$PIECE(PSORESP,U,2)_" in addition to the"
+7 SET DIR("?",3)="other categories."
End DoDot:1
+8 IF $PIECE(PSORESP,U)="N"
IF '$GET(PSOPMT)
Begin DoDot:1
+9 SET DIR("?")=" "
SET DIR("?",1)="Enter 'NO' to EXCLUDE refrigerated "_$PIECE(PSORESP,U,2)_" from printing."
+10 SET DIR("?",2)="Enter 'YES' to print refrigerated "_$PIECE(PSORESP,U,2)_"."
End DoDot:1
+11 IF $PIECE(PSORESP,U)="C"
IF $GET(PSOPMT)
Begin DoDot:1
+12 SET DIR("?")=" "
+13 SET DIR("?",1)="Enter 'YES' to EXCLUDE refrigerated "_$PIECE(PSORESP,U,2)_" of the selected range"
+14 SET DIR("?",2)="from printing."
+15 SET DIR("?",3)="Enter 'NO' to print refrigerated "_$PIECE(PSORESP,U,2)_" of the selected range"
+16 SET DIR("?",4)="in addition to the other categories."
End DoDot:1
+17 IF $PIECE(PSORESP,U)="C"
IF '$GET(PSOPMT)
Begin DoDot:1
+18 SET DIR("?")=" "
SET DIR("?",1)="Enter 'NO' to EXCLUDE refrigerated "_$PIECE(PSORESP,U,2)_" of the selected range"
+19 SET DIR("?",2)="from printing."
+20 SET DIR("?",3)="Enter 'YES' to print refrigerated "_$PIECE(PSORESP,U,2)_" of the selected range."
End DoDot:1
+21 SET DIR("A")=$SELECT($PIECE(PSOMOD,U):"Exclude",1:"Include")_" Refrigerated Items"
DO ^DIR
if $DATA(DIRUT)
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
if Y>0
SET PSOMOD=PSOMOD_"^"
if Y=0
SET PSOMOD=PSOMOD_"^Q"
+22 IF $PIECE(PSORESP,U)="N"
IF $GET(PSOPMT)
Begin DoDot:1
+23 SET DIR("?")=" "
+24 SET DIR("?",1)="Enter 'YES' to EXCLUDE Non-Controlled supplies from printing."
+25 SET DIR("?",2)="Enter 'NO' to print Non-Controlled supplies in addition to the"
+26 SET DIR("?",3)="other categories."
End DoDot:1
+27 IF $PIECE(PSORESP,U)="N"
IF '$GET(PSOPMT)
Begin DoDot:1
+28 SET DIR("?")=" "
+29 SET DIR("?",1)="Enter 'NO' to EXCLUDE Non-Controlled supplies from printing."
+30 SET DIR("?",2)="Enter 'YES' to print Non-Controlled supplies."
End DoDot:1
+31 IF $PIECE(PSORESP,U)="N"
SET DIR("A")=$SELECT($PIECE(PSOMOD,U):"Exclude",1:"Include")_" Supplies"
DO ^DIR
if $DATA(DIRUT)
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
if Y>0
SET PSOMOD=PSOMOD_"^"
if Y=0
SET PSOMOD=PSOMOD_"^S"
+32 QUIT
CONT NEW DIR
+1 SET DIR(0)="YO"
+2 ;rtw
SET DIR("A")="Print Suspended '"_$PIECE(PSORESP,U,2)_"' selections"
+3 ;rtw
IF $PIECE(PSOMOD,U)
SET DIR("A")="Print everything Suspended EXCEPT '"_$PIECE(PSORESP,U,2)_"' selections"
+4 SET DIR("B")="NO"
+5 SET DIR("T")=DTIME
+6 WRITE !
DO ^DIR
if Y'>0
SET PSOSTPF=1
+7 QUIT
N NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 SET DIR(0)="SBO^Rx:Rx;OTC:OTC;Both:Both Rx and OTC"
+2 SET DIR("A")="Include the following"
+3 IF $PIECE(PSOMOD,U)
SET DIR("A")="Exclude the following"
+4 SET DIR("?",1)="Enter 'Rx' Prescriptions for Legend Drugs (Special Handling Code 6)"
+5 SET DIR("?",2)=" 'OTC' Prescriptions for OTC Drugs (Special Handling Code 9)"
+6 SET DIR("?",3)=" 'Both' Prescriptions for BOTH Legend and OTC Drugs"
+7 SET DIR("?")=" "
+8 SET DIR("B")="Both"
+9 SET DIR("T")=DTIME
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y="E")
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
+11 IF Y="Rx"
SET PSOSULST($PIECE(PSORESP,U,3),6)=""
+12 IF Y="OTC"
SET PSOSULST($PIECE(PSORESP,U,3),9)=""
+13 IF Y="Both"
SET PSOSULST($PIECE(PSORESP,U,3),6)=""
SET PSOSULST($PIECE(PSORESP,U,3),9)=""
+14 DO INCLD
if $DATA(PSOSTPF)
QUIT
+15 QUIT
C NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 SET DIR(0)="LAO^1:5:0"
+2 SET DIR("A")="Enter a list or range of CS Federal Schedules to INCLUDE (1-5): "
+3 IF $PIECE(PSOMOD,U)
SET DIR("A")="Enter list or range of CS Federal Schedules to EXCLUDE (1-5): "
+4 SET DIR("B")="1-5"
+5 SET DIR("?")="This response must be a list or range, e.g. 2,4 or 3-5."
+6 SET DIR("T")=DTIME
+7 DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
+8 NEW XX
FOR XX=1:1:($LENGTH(Y,",")-1)
SET PSOSULST($PIECE(PSORESP,U,3),+$PIECE(Y,",",XX))=""
+9 DO INCLD
if $DATA(PSOSTPF)
QUIT
+10 QUIT
D NEW PSODRG,PSOSORT,PSOSRT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 DO DSLCT
if '$ORDER(PSOSULST($PIECE(PSORESP,U,3),""))
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
Begin DoDot:1
+2 WRITE !!,"Drugs Selected:"
+3 SET PSODRG=0
FOR
SET PSODRG=$ORDER(PSOSULST($PIECE(PSORESP,U,3),PSODRG))
if 'PSODRG
QUIT
Begin DoDot:2
+4 SET PSOSORT($PIECE(^PSDRUG(PSODRG,0),U))=""
End DoDot:2
+5 SET PSOSRT=""
FOR
SET PSOSRT=$ORDER(PSOSORT(PSOSRT))
if PSOSRT=""
QUIT
Begin DoDot:2
+6 WRITE !,PSOSRT
End DoDot:2
End DoDot:1
+7 QUIT
DSLCT NEW DIC,X,Y,DTOUT,DUOUT
+1 SET DIC=50
SET DIC(0)="AEQM"
DSLCT2 DO ^DIC
if Y'>0
QUIT
SET PSOSULST($PIECE(PSORESP,U,3),+Y)=""
+1 SET DIC("A")="Select Another DRUG GENERIC NAME: "
+2 GOTO DSLCT2
+3 QUIT
V NEW PSOCLSS,PSOSORT,PSOSRT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 DO VSLCT
if '$ORDER(PSOSULST($PIECE(PSORESP,U,3),""))
SET PSOSTPF=1
if $DATA(PSOSTPF)
QUIT
Begin DoDot:1
+2 WRITE !!,"VA Classification Selected:"
+3 SET PSOCLSS=0
FOR
SET PSOCLSS=$ORDER(PSOSULST($PIECE(PSORESP,U,3),PSOCLSS))
if 'PSOCLSS
QUIT
Begin DoDot:2
+4 SET PSOSORT($PIECE(^PS(50.605,PSOCLSS,0),U))=""
End DoDot:2
+5 SET PSOSRT=""
FOR
SET PSOSRT=$ORDER(PSOSORT(PSOSRT))
if PSOSRT=""
QUIT
Begin DoDot:2
+6 WRITE !,PSOSRT
End DoDot:2
End DoDot:1
+7 QUIT
VSLCT NEW DIC,X,Y,DTOUT,DUOUT
+1 SET DIC=50.605
SET DIC(0)="AEQM"
VSLCT2 NEW PSOCLSIN,PSOVACLS,CHLDCLSS
+1 DO ^DIC
if Y'>0
QUIT
SET PSOCLSIN=+Y
SET PSOSULST($PIECE(PSORESP,U,3),+Y)=""
+2 SET PSOVACLS=$PIECE(^PS(50.605,PSOCLSIN,0),U)
+3 DO VDISP
DO VSPLIT
+4 WRITE !
+5 SET DIC("A")="Select Another VA DRUG CLASS CODE: "
+6 GOTO VSLCT2
+7 QUIT
VDISP NEW OI,PSODRG
+1 NEW CNT
SET CNT=0
+2 SET OI=0
FOR
SET OI=$ORDER(^PSDRUG("AOC",OI))
if 'OI
QUIT
SET PSODRG=0
FOR
SET PSODRG=$ORDER(^PSDRUG("AOC",OI,PSOVACLS,PSODRG))
if 'PSODRG
QUIT
Begin DoDot:1
+3 SET CNT=CNT+1
IF CNT=1
WRITE !!,"Dispense Drugs for VA Class ",PSOVACLS," are:"
+4 WRITE !,$PIECE(^PSDRUG(PSODRG,0),U)
End DoDot:1
+5 QUIT
VSPLIT IF $DATA(^PS(50.605,"AC",PSOCLSIN))
Begin DoDot:1
+1 SET CHLDCLSS=0
FOR
SET CHLDCLSS=$ORDER(^PS(50.605,"AC",PSOCLSIN,CHLDCLSS))
if $DATA(^PS(50.605,"AC",+CHLDCLSS))
DO VSPLIT2
if '+CHLDCLSS
QUIT
Begin DoDot:2
+2 SET PSOSULST($PIECE(PSORESP,U,3),+CHLDCLSS)=""
SET PSOVACLS=$PIECE(^PS(50.605,CHLDCLSS,0),"^")
DO VDISP
End DoDot:2
End DoDot:1
+3 QUIT
VSPLIT2 NEW CHLDCLSS2
+1 SET CHLDCLSS2=0
FOR
SET CHLDCLSS2=$ORDER(^PS(50.605,"AC",CHLDCLSS,CHLDCLSS2))
if '+CHLDCLSS2
QUIT
SET PSOSULST($PIECE(PSORESP,U,3),+CHLDCLSS2)=""
SET PSOVACLS=$PIECE(^PS(50.605,CHLDCLSS2,0),"^")
DO VDISP
+2 QUIT
EN NEW PSODRUG,PSODEA,PSOIEN,PSOMW,PSOPP,PSONODE,PSOVACLS
+1 SET PSOIEN=+$GET(^PS(52.5,SFN,0))
if 'PSOIEN
QUIT
SET PSODRUG=$PIECE($GET(^PSRX(PSOIEN,0)),U,6)
+2 SET PSODEA=$PIECE($GET(^PSDRUG(PSODRUG,0)),U,3)
SET PSOVACLS=$PIECE($GET(^PSDRUG(PSODRUG,0)),U,2)
SET PSOOK=+PSOSULST($ORDER(PSOSULST("")))
+3 SET PSONODE=$GET(^PS(52.5,SFN,0))
Begin DoDot:1
+4 IF $PIECE(PSONODE,"^",5)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(PSONODE),"Q",$PIECE(PSONODE,"^",5),0)),"^",2)
QUIT
+5 IF $PIECE(PSONODE,"^",13)!($ORDER(^PSRX(+$GET(PSONODE),1,0)))
Begin DoDot:2
+6 IF $PIECE(PSONODE,"^",13)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(PSONODE),1,$PIECE(PSONODE,"^",13),0)),"^",2)
QUIT
+7 FOR PSOPP=0:0
SET PSOPP=$ORDER(^PSRX(+$GET(PSONODE),1,PSOPP))
if 'PSOPP
QUIT
SET PSOMW=$PIECE($GET(^PSRX(+$GET(PSONODE),1,PSOPP,0)),"^",2)
End DoDot:2
QUIT
+8 SET PSOMW=$PIECE($GET(^PSRX(+$GET(PSONODE),0)),"^",11)
End DoDot:1
+9 DO @$ORDER(PSOSULST(""))
+10 QUIT
DEA NEW XX
+1 SET XX=""
FOR
SET XX=$ORDER(PSOSULST("DEA",XX))
if 'XX
QUIT
IF (PSODEA[XX)&(PSOMW[$PIECE(PSOSULST("DEA"),U,2))
SET PSOOK='PSOOK
Begin DoDot:1
+2 IF (($PIECE(PSOSULST("DEA"),U,3)="Q")&(PSODEA["Q"))!(($PIECE(PSOSULST("DEA"),U,4)="S")&(PSODEA["S"))
SET PSOOK='PSOOK
+3 IF PSOOK'=+PSOSULST("DEA")
QUIT
End DoDot:1
+4 QUIT
DRUG NEW PSODRG
+1 SET PSODRG=""
FOR
SET PSODRG=$ORDER(PSOSULST("DRUG",PSODRG))
if 'PSODRG
QUIT
Begin DoDot:1
+2 IF (PSODRUG=PSODRG)&(PSOMW[$PIECE(PSOSULST("DRUG"),U,2))
SET PSOOK='PSOOK
QUIT
End DoDot:1
+3 QUIT
CLASS NEW PSOCLSS
+1 SET PSOCLSS=""
FOR
SET PSOCLSS=$ORDER(PSOSULST("CLASS",PSOCLSS))
if 'PSOCLSS
QUIT
Begin DoDot:1
+2 IF (PSOVACLS=$PIECE(^PS(50.605,PSOCLSS,0),U))&(PSOMW[$PIECE(PSOSULST("CLASS"),U,2))
SET PSOOK='PSOOK
QUIT
End DoDot:1
+3 QUIT
SUPPLY IF (PSODEA["S")&(PSOMW[$PIECE(PSOSULST("SUPPLY"),U,2))
SET PSOOK='PSOOK
+1 QUIT
FRIDGE IF (PSODEA["Q")&(PSOMW[$PIECE(PSOSULST("FRIDGE"),U,2))
SET PSOOK='PSOOK
+1 QUIT
