PSSDTR ;BIR/EJW-Print Drug Text Report ;
;;1.0;PHARMACY DATA MANAGEMENT;**55**;9/30/97
;
;Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) supported by DBIA #2574
;
W !!,"This report shows each selected drug text entry and lists all drugs",!,"and orderable items linked to it."
EN ;
K PSSHOW,PSSBEG,PSSEND,PSSNUMBX,PSSSRT
K DIR S DIR(0)="S^A:ALL;S:SINGLE ENTRY OR RANGE",DIR("B")="S",DIR("A")="Print for (A)ll or (S)elect Single Entry or Range" D
.S DIR("?")=" ",DIR("?",1)="Enter 'A' for all drug text entries,",DIR("?",2)="or 'S' to select single entry or range."
D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G DONE
S PSSHOW=Y I PSSHOW="A" S PSSBEG="",PSSEND="Z" S PSSSRT="A" G TASK
;
S PSSNUMB="" F S PSSNUMB=$O(^PS(51.7,"B",PSSNUMB)) Q:'PSSNUMB!($G(PSSNUMBX)) S PSSNUMBX=1
I $G(PSSNUMBX) K DIR S DIR(0)="Y",DIR("A")="Print report for drug text entries with leading numerics",DIR("B")="N" D D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) W !!,"Nothing queued to print.",! G DONE
.W !!!,"There are drugs in the drug text file with leading numerics.",!
.S DIR("?")=" ",DIR("?",1)="There are some entries in the drug text file with leading numerics.",DIR("?",2)="Enter Yes to print the report for those entries.",DIR("?",3)=" "
I $G(PSSNUMBX),$G(Y)=1 S PSSSRT="N" G TASK
K PSSNUMB,PSSNUMBX
ASKA K PSSBEG,PSSEND
W !!,"Enter a single drug text entry or to see all drug text entries beginning with"
W !,"the letter 'A' for example, enter 'A' or whichever letter you wish to see."
W !,"To see drug text entries in a range for example starting with 'H', 'I' and 'J'"
W !,"enter in the format 'H-J'.",!
S DIR("?",1)=" ",DIR("?",2)="Enter a single drug text entry or enter a letter, 'A', 'B', etc., to see",DIR("?",3)="entries beginning with that letter or to see a range of drug text entries"
S DIR("?",4)="enter 'A-C', 'G-M', etc.",DIR("?",5)=" ",DIR("?")=" "
S DIR("A")="Enter a single entry or select a range",DIR(0)="F^1:100" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G DONE
S PSSXX=Y
I PSSXX'?1U&(PSSXX'?1U1"-"1U)&(PSSXX'?1L)&(PSSXX'?1L1"-"1L) I PSSXX'="",'$D(^PS(51.7,"B",PSSXX)) D W ! G ASKA
. W !!,"Invalid response." W $S($L(PSSXX)>1&(PSSXX'["-"):" Entry not found.",1:" Enter a single entry, or a letter, 'A', 'B', etc., or a range.")
I PSSXX["-" S PSSBEG=$P(PSSXX,"-"),PSSEND=$P(PSSXX,"-",2) I $A(PSSEND)<$A(PSSBEG) W !!,"Invalid response.",! G ASKA
I PSSXX'["-" S PSSBEG=PSSXX,PSSEND=PSSXX
S PSSSRT="X"
TASK ;
I PSSSRT="X",$L(PSSXX)>1,PSSXX'["-" S PSSSRT="S" ; single entry
I PSSSRT="X" W !!,"Report will be for drug text starting with "_$G(PSSBEG)_",",!,"and ending with drug text starting with "_$G(PSSEND)_".",!
I PSSSRT="N" W !!,"This report will be for drug text with leading numerics.",!
I PSSSRT="A" W !!,"This report will be for all drug text entries.",!
I PSSSRT="S" W !!,"This report will be for drug text entry: ",PSSXX,!
K DIR S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="Y" D ^DIR K DIR I Y'=1 W ! G EN
I PSSSRT="X",$L(PSSXX)>1,PSSXX'["-" S PSSSRT="S" ; single entry
RPT W !!,"You may queue the report to print, if you wish.",!
K PSSFIRST
;
DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
QUEUE I $D(IO("Q")) S ZTRTN="START^PSSDTR",ZTDESC="Drug Text File Report",ZTSAVE("PSSBEG")="",ZTSAVE("PSSEND")="",ZTSAVE("PSSSRT")="",ZTSAVE("PSSXX")="" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
START ;
U IO
S PSSOUT=0,PSSDV=$S($E(IOST)="C":"C",1:"P")
S PSSPGCT=0,PSSPGLN=IOSL-7,PSSPGCT=1
D TITLE
I PSSSRT="X" S PSSX=$A(PSSBEG)-1,PSSLCL=$C(PSSX)_"zzzz"
I $G(PSSSRT)="N"!($G(PSSSRT)="A") S (PSSLCL,PSSEND)=""
;
I PSSSRT'="S" F S PSSLCL=$O(^PS(51.7,"B",PSSLCL)) Q:$S(PSSSRT="N"&('PSSLCL):1,PSSSRT="X"&(PSSLCL](PSSEND_"zzzz")):1,1:0)!(PSSLCL="")!($G(PSSOUT)) D DTXTRPT
I PSSSRT="S",PSSBEG'="" S PSSLCL=PSSBEG I $D(^PS(51.7,"B",PSSLCL)) D DTXTRPT
G END
DTXTRPT F PSSB=0:0 S PSSB=$O(^PS(51.7,"B",PSSLCL,PSSB)) Q:'PSSB D
. I $G(^PS(51.7,PSSB,0))'="" D DTNAME D FULL Q:($G(PSSOUT)) D DTEXT Q:$G(PSSOUT) D OITEXT I $G(PSSOUT) Q
D FULL I $G(PSSOUT) Q
W ! F MJT=1:1:70 W "-"
W !
Q
DTNAME D FULL Q:$G(PSSOUT) W !,"DRUG TEXT NAME: ",PSSLCL
D FULL2 Q:($G(PSSOUT)) S Y=+$P($G(^PS(51.7,PSSB,0)),"^",2) I Y>0 X ^DD("DD") W !,?3,"** INACTIVE DATE: ",Y," **",!
N PSSSYN
; print synonyms, if any
I $O(^PS(51.7,PSSB,1,0))?1.N D FULL Q:(PSSOUT) D
. W !,?3,"SYNONYM(S): "
. S PSSSYN=0 F S PSSSYN=$O(^PS(51.7,PSSB,1,PSSSYN)) Q:'PSSSYN D FULL Q:$G(PSSOUT) W ?17,^PS(51.7,PSSB,1,PSSSYN,0),!
; print drug text
N PSSTXT
D FULL2 I $G(PSSOUT) Q
W !!,?3,"DRUG TEXT:"
S PSSTXT=0 F S PSSTXT=$O(^PS(51.7,PSSB,2,PSSTXT)) Q:'PSSTXT D FULL Q:$G(PSSOUT) W !,?3,^PS(51.7,PSSB,2,PSSTXT,0)
D NRESTR
Q
;
DTEXT ;
D FULL2 I $G(PSSOUT) Q
W !!,?3,"DRUG file entries:",!,?3,"-----------------"
I $O(^PSDRUG("DTXT",PSSB,""))="" D FULL Q:$G(PSSOUT) W !,?3,"NONE" Q
S PSSDRG="" F S PSSDRG=$O(^PSDRUG("DTXT",PSSB,PSSDRG)) Q:'PSSDRG D FULL Q:($G(PSSOUT)) W !,?3,$P($G(^PSDRUG(PSSDRG,0)),"^",1) D
. I $P($G(^PSDRUG(PSSDRG,"I")),"^",1)'="" D FULL Q:($G(PSSOUT)) S Y=+$P($G(^PSDRUG(PSSDRG,"I")),"^",1) I Y>0 X ^DD("DD") W !,?6,"** INACTIVE DATE: ",Y," **",!
Q
;
OITEXT ;
N DFPTR
D FULL2 Q:$G(PSSOUT) W !!,?3,"ORDERABLE ITEM file entries: " D
. W !,?3,"---------------------------"
I $O(^PS(50.7,"DTXT",PSSB,""))="" D FULL Q:$G(PSSOUT) W !,?3,"NONE"
S PSSDRG="" F S PSSDRG=$O(^PS(50.7,"DTXT",PSSB,PSSDRG)) Q:'PSSDRG D FULL Q:$G(PSSOUT) W !,?3,$P($G(^PS(50.7,PSSDRG,0)),"^",1) D
. S DFPTR=$P(^PS(50.7,PSSDRG,0),"^",2) W " ",$P(^PS(50.606,DFPTR,0),"^",1)
. I $P(^PS(50.7,PSSDRG,0),"^",4)'="" D
. . D FULL Q:($G(PSSOUT)) S Y=+$P($G(^PS(50.7,PSSDRG,0)),"^",4) I Y>0 X ^DD("DD") W !,?6,"** INACTIVE DATE: ",Y," **",!
Q
;
NRESTR ; check for National Formulary Restrictions
N PSXGN,PSXVP,PSXDN,DONE,XX2
S DONE=0
S PSSDRG="" F S PSSDRG=$O(^PSDRUG("DTXT",PSSB,PSSDRG)) Q:'PSSDRG D Q:DONE
.I $D(^PSDRUG(PSSDRG,"ND")) S PSXDN=$G(^PSDRUG(PSSDRG,"ND")),PSXGN=$P(PSXDN,"^"),PSXVP=$P(PSXDN,"^",3)
.D FULL2 Q:$G(PSSOUT) I $G(PSXGN),$G(PSXVP) S DONE=1 W !!,?3,"NATIONAL FORMULARY RESTRICTION TEXT:" S XX2=$$FORMRX^PSNAPIS(PSXGN,PSXVP,.LIST) I $G(XX2)=1,$D(LIST) F XX2=0:0 S XX2=$O(LIST(XX2)) Q:'XX2 D FULL Q:$G(PSSOUT) W !,?3,LIST(XX2,0)
K LIST
Q
;
FULL ;
I ($Y+5)>IOSL&('$G(PSSOUT)) D TITLE
Q
;
FULL2 ;
I ($Y+6)>IOSL&('$G(PSSOUT)) D TITLE
Q
TITLE ;
I $G(PSSDV)="C",$G(PSSPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
;
W @IOF D
. I PSSSRT="N" W !,?16,"Drug Text Report for Drug Text entries with Leading Numerics",! Q
. I PSSSRT="A" W !,?16,"Drug Text Report for all Drug Text entries",! Q
. I PSSSRT="X" W !,?16,"Drug Text Report for drug text from "_PSSBEG_" through "_PSSEND,! Q
. I PSSSRT="S" W !,?16,"Drug Text Report for drug text : "_PSSBEG,! Q
S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSSPGCT,!
F MJT=1:1:79 W "="
W !
I $G(PSSFIRST)="" D
. W !,"PLEASE NOTE: The National Formulary Restriction Text is the original text"
. W !,"exported with the DRUG TEXT file (#51.7) and automatically linked to the DRUG"
. W !,"file (#50) entries based on the VA product match. No ORDERABLE ITEM file"
. W !,"(#50.7) entries were automatically linked with DRUG TEXT file (#51.7).",!
. S PSSFIRST=1
S PSSPGCT=PSSPGCT+1
Q
END ;
I '$G(PSSOUT),$G(PSSDV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSSDV)="C" W !
E W @IOF
DONE ;
K PSSB,PSSLCL,MJT,PSSPGCT,PSSPGLN,Y,DIR,INDT,PSSXX,X,OITM,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
K PSSSRT,PSSDRG,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSEND D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
PSSDTR ;BIR/EJW-Print Drug Text Report ;
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**55**;9/30/97
+2 ;
+3 ;Reference to $$FORMRX^PSNAPIS(DA,K,.LIST) supported by DBIA #2574
+4 ;
+5 WRITE !!,"This report shows each selected drug text entry and lists all drugs",!,"and orderable items linked to it."
EN ;
+1 KILL PSSHOW,PSSBEG,PSSEND,PSSNUMBX,PSSSRT
+2 KILL DIR
SET DIR(0)="S^A:ALL;S:SINGLE ENTRY OR RANGE"
SET DIR("B")="S"
SET DIR("A")="Print for (A)ll or (S)elect Single Entry or Range"
Begin DoDot:1
+3 SET DIR("?")=" "
SET DIR("?",1)="Enter 'A' for all drug text entries,"
SET DIR("?",2)="or 'S' to select single entry or range."
End DoDot:1
+4 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
WRITE !!,"Nothing queued to print.",!
GOTO DONE
+5 SET PSSHOW=Y
IF PSSHOW="A"
SET PSSBEG=""
SET PSSEND="Z"
SET PSSSRT="A"
GOTO TASK
+6 ;
+7 SET PSSNUMB=""
FOR
SET PSSNUMB=$ORDER(^PS(51.7,"B",PSSNUMB))
IF 'PSSNUMB!($GET(PSSNUMBX))
QUIT
SET PSSNUMBX=1
+8 IF $GET(PSSNUMBX)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Print report for drug text entries with leading numerics"
SET DIR("B")="N"
Begin DoDot:1
+9 WRITE !!!,"There are drugs in the drug text file with leading numerics.",!
+10 SET DIR("?")=" "
SET DIR("?",1)="There are some entries in the drug text file with leading numerics."
SET DIR("?",2)="Enter Yes to print the report for those entries."
SET DIR("?",3)=" "
End DoDot:1
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
WRITE !!,"Nothing queued to print.",!
GOTO DONE
+11 IF $GET(PSSNUMBX)
IF $GET(Y)=1
SET PSSSRT="N"
GOTO TASK
+12 KILL PSSNUMB,PSSNUMBX
ASKA KILL PSSBEG,PSSEND
+1 WRITE !!,"Enter a single drug text entry or to see all drug text entries beginning with"
+2 WRITE !,"the letter 'A' for example, enter 'A' or whichever letter you wish to see."
+3 WRITE !,"To see drug text entries in a range for example starting with 'H', 'I' and 'J'"
+4 WRITE !,"enter in the format 'H-J'.",!
+5 SET DIR("?",1)=" "
SET DIR("?",2)="Enter a single drug text entry or enter a letter, 'A', 'B', etc., to see"
SET DIR("?",3)="entries beginning with that letter or to see a range of drug text entries"
+6 SET DIR("?",4)="enter 'A-C', 'G-M', etc."
SET DIR("?",5)=" "
SET DIR("?")=" "
+7 SET DIR("A")="Enter a single entry or select a range"
SET DIR(0)="F^1:100"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
WRITE !!,"Nothing queued to print.",!
GOTO DONE
+8 SET PSSXX=Y
+9 IF PSSXX'?1U&(PSSXX'?1U1"-"1U)&(PSSXX'?1L)&(PSSXX'?1L1"-"1L)
IF PSSXX'=""
IF '$DATA(^PS(51.7,"B",PSSXX))
Begin DoDot:1
+10 WRITE !!,"Invalid response."
WRITE $SELECT($LENGTH(PSSXX)>1&(PSSXX'["-"):" Entry not found.",1:" Enter a single entry, or a letter, 'A', 'B', etc., or a range.")
End DoDot:1
WRITE !
GOTO ASKA
+11 IF PSSXX["-"
SET PSSBEG=$PIECE(PSSXX,"-")
SET PSSEND=$PIECE(PSSXX,"-",2)
IF $ASCII(PSSEND)<$ASCII(PSSBEG)
WRITE !!,"Invalid response.",!
GOTO ASKA
+12 IF PSSXX'["-"
SET PSSBEG=PSSXX
SET PSSEND=PSSXX
+13 SET PSSSRT="X"
TASK ;
+1 ; single entry
IF PSSSRT="X"
IF $LENGTH(PSSXX)>1
IF PSSXX'["-"
SET PSSSRT="S"
+2 IF PSSSRT="X"
WRITE !!,"Report will be for drug text starting with "_$GET(PSSBEG)_",",!,"and ending with drug text starting with "_$GET(PSSEND)_".",!
+3 IF PSSSRT="N"
WRITE !!,"This report will be for drug text with leading numerics.",!
+4 IF PSSSRT="A"
WRITE !!,"This report will be for all drug text entries.",!
+5 IF PSSSRT="S"
WRITE !!,"This report will be for drug text entry: ",PSSXX,!
+6 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Is this correct"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y'=1
WRITE !
GOTO EN
+7 ; single entry
IF PSSSRT="X"
IF $LENGTH(PSSXX)>1
IF PSSXX'["-"
SET PSSSRT="S"
RPT WRITE !!,"You may queue the report to print, if you wish.",!
+1 KILL PSSFIRST
+2 ;
DVC KILL %ZIS,POP,IOP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
GOTO DONE
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="START^PSSDTR"
SET ZTDESC="Drug Text File Report"
SET ZTSAVE("PSSBEG")=""
SET ZTSAVE("PSSEND")=""
SET ZTSAVE("PSSSRT")=""
SET ZTSAVE("PSSXX")=""
DO ^%ZTLOAD
KILL %ZSI
WRITE !,"Report queued to print.",!
GOTO DONE
START ;
+1 USE IO
+2 SET PSSOUT=0
SET PSSDV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+3 SET PSSPGCT=0
SET PSSPGLN=IOSL-7
SET PSSPGCT=1
+4 DO TITLE
+5 IF PSSSRT="X"
SET PSSX=$ASCII(PSSBEG)-1
SET PSSLCL=$CHAR(PSSX)_"zzzz"
+6 IF $GET(PSSSRT)="N"!($GET(PSSSRT)="A")
SET (PSSLCL,PSSEND)=""
+7 ;
+8 IF PSSSRT'="S"
FOR
SET PSSLCL=$ORDER(^PS(51.7,"B",PSSLCL))
IF $SELECT(PSSSRT="N"&('PSSLCL)
QUIT
DO DTXTRPT
+9 IF PSSSRT="S"
IF PSSBEG'=""
SET PSSLCL=PSSBEG
IF $DATA(^PS(51.7,"B",PSSLCL))
DO DTXTRPT
+10 GOTO END
DTXTRPT FOR PSSB=0:0
SET PSSB=$ORDER(^PS(51.7,"B",PSSLCL,PSSB))
IF 'PSSB
QUIT
Begin DoDot:1
+1 IF $GET(^PS(51.7,PSSB,0))'=""
DO DTNAME
DO FULL
IF ($GET(PSSOUT))
QUIT
DO DTEXT
IF $GET(PSSOUT)
QUIT
DO OITEXT
IF $GET(PSSOUT)
QUIT
End DoDot:1
+2 DO FULL
IF $GET(PSSOUT)
QUIT
+3 WRITE !
FOR MJT=1:1:70
WRITE "-"
+4 WRITE !
+5 QUIT
DTNAME DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,"DRUG TEXT NAME: ",PSSLCL
+1 DO FULL2
IF ($GET(PSSOUT))
QUIT
SET Y=+$PIECE($GET(^PS(51.7,PSSB,0)),"^",2)
IF Y>0
XECUTE ^DD("DD")
WRITE !,?3,"** INACTIVE DATE: ",Y," **",!
+2 NEW PSSSYN
+3 ; print synonyms, if any
+4 IF $ORDER(^PS(51.7,PSSB,1,0))?1.N
DO FULL
IF (PSSOUT)
QUIT
Begin DoDot:1
+5 WRITE !,?3,"SYNONYM(S): "
+6 SET PSSSYN=0
FOR
SET PSSSYN=$ORDER(^PS(51.7,PSSB,1,PSSSYN))
IF 'PSSSYN
QUIT
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE ?17,^PS(51.7,PSSB,1,PSSSYN,0),!
End DoDot:1
+7 ; print drug text
+8 NEW PSSTXT
+9 DO FULL2
IF $GET(PSSOUT)
QUIT
+10 WRITE !!,?3,"DRUG TEXT:"
+11 SET PSSTXT=0
FOR
SET PSSTXT=$ORDER(^PS(51.7,PSSB,2,PSSTXT))
IF 'PSSTXT
QUIT
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,?3,^PS(51.7,PSSB,2,PSSTXT,0)
+12 DO NRESTR
+13 QUIT
+14 ;
DTEXT ;
+1 DO FULL2
IF $GET(PSSOUT)
QUIT
+2 WRITE !!,?3,"DRUG file entries:",!,?3,"-----------------"
+3 IF $ORDER(^PSDRUG("DTXT",PSSB,""))=""
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,?3,"NONE"
QUIT
+4 SET PSSDRG=""
FOR
SET PSSDRG=$ORDER(^PSDRUG("DTXT",PSSB,PSSDRG))
IF 'PSSDRG
QUIT
DO FULL
IF ($GET(PSSOUT))
QUIT
WRITE !,?3,$PIECE($GET(^PSDRUG(PSSDRG,0)),"^",1)
Begin DoDot:1
+5 IF $PIECE($GET(^PSDRUG(PSSDRG,"I")),"^",1)'=""
DO FULL
IF ($GET(PSSOUT))
QUIT
SET Y=+$PIECE($GET(^PSDRUG(PSSDRG,"I")),"^",1)
IF Y>0
XECUTE ^DD("DD")
WRITE !,?6,"** INACTIVE DATE: ",Y," **",!
End DoDot:1
+6 QUIT
+7 ;
OITEXT ;
+1 NEW DFPTR
+2 DO FULL2
IF $GET(PSSOUT)
QUIT
WRITE !!,?3,"ORDERABLE ITEM file entries: "
Begin DoDot:1
+3 WRITE !,?3,"---------------------------"
End DoDot:1
+4 IF $ORDER(^PS(50.7,"DTXT",PSSB,""))=""
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,?3,"NONE"
+5 SET PSSDRG=""
FOR
SET PSSDRG=$ORDER(^PS(50.7,"DTXT",PSSB,PSSDRG))
IF 'PSSDRG
QUIT
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,?3,$PIECE($GET(^PS(50.7,PSSDRG,0)),"^",1)
Begin DoDot:1
+6 SET DFPTR=$PIECE(^PS(50.7,PSSDRG,0),"^",2)
WRITE " ",$PIECE(^PS(50.606,DFPTR,0),"^",1)
+7 IF $PIECE(^PS(50.7,PSSDRG,0),"^",4)'=""
Begin DoDot:2
+8 DO FULL
IF ($GET(PSSOUT))
QUIT
SET Y=+$PIECE($GET(^PS(50.7,PSSDRG,0)),"^",4)
IF Y>0
XECUTE ^DD("DD")
WRITE !,?6,"** INACTIVE DATE: ",Y," **",!
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
NRESTR ; check for National Formulary Restrictions
+1 NEW PSXGN,PSXVP,PSXDN,DONE,XX2
+2 SET DONE=0
+3 SET PSSDRG=""
FOR
SET PSSDRG=$ORDER(^PSDRUG("DTXT",PSSB,PSSDRG))
IF 'PSSDRG
QUIT
Begin DoDot:1
+4 IF $DATA(^PSDRUG(PSSDRG,"ND"))
SET PSXDN=$GET(^PSDRUG(PSSDRG,"ND"))
SET PSXGN=$PIECE(PSXDN,"^")
SET PSXVP=$PIECE(PSXDN,"^",3)
+5 DO FULL2
IF $GET(PSSOUT)
QUIT
IF $GET(PSXGN)
IF $GET(PSXVP)
SET DONE=1
WRITE !!,?3,"NATIONAL FORMULARY RESTRICTION TEXT:"
SET XX2=$$FORMRX^PSNAPIS(PSXGN,PSXVP,.LIST)
IF $GET(XX2)=1
IF $DATA(LIST)
FOR XX2=0:0
SET XX2=$ORDER(LIST(XX2))
IF 'XX2
QUIT
DO FULL
IF $GET(PSSOUT)
QUIT
WRITE !,?3,LIST(XX2,0)
End DoDot:1
IF DONE
QUIT
+6 KILL LIST
+7 QUIT
+8 ;
FULL ;
+1 IF ($Y+5)>IOSL&('$GET(PSSOUT))
DO TITLE
+2 QUIT
+3 ;
FULL2 ;
+1 IF ($Y+6)>IOSL&('$GET(PSSOUT))
DO TITLE
+2 QUIT
TITLE ;
+1 IF $GET(PSSDV)="C"
IF $GET(PSSPGCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+2 ;
+3 WRITE @IOF
Begin DoDot:1
+4 IF PSSSRT="N"
WRITE !,?16,"Drug Text Report for Drug Text entries with Leading Numerics",!
QUIT
+5 IF PSSSRT="A"
WRITE !,?16,"Drug Text Report for all Drug Text entries",!
QUIT
+6 IF PSSSRT="X"
WRITE !,?16,"Drug Text Report for drug text from "_PSSBEG_" through "_PSSEND,!
QUIT
+7 IF PSSSRT="S"
WRITE !,?16,"Drug Text Report for drug text : "_PSSBEG,!
QUIT
End DoDot:1
+8 SET Y=DT
XECUTE ^DD("DD")
WRITE !,"Date printed: ",Y,?70,"Page: ",PSSPGCT,!
+9 FOR MJT=1:1:79
WRITE "="
+10 WRITE !
+11 IF $GET(PSSFIRST)=""
Begin DoDot:1
+12 WRITE !,"PLEASE NOTE: The National Formulary Restriction Text is the original text"
+13 WRITE !,"exported with the DRUG TEXT file (#51.7) and automatically linked to the DRUG"
+14 WRITE !,"file (#50) entries based on the VA product match. No ORDERABLE ITEM file"
+15 WRITE !,"(#50.7) entries were automatically linked with DRUG TEXT file (#51.7).",!
+16 SET PSSFIRST=1
End DoDot:1
+17 SET PSSPGCT=PSSPGCT+1
+18 QUIT
END ;
+1 IF '$GET(PSSOUT)
IF $GET(PSSDV)="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $GET(PSSDV)="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
DONE ;
+1 KILL PSSB,PSSLCL,MJT,PSSPGCT,PSSPGLN,Y,DIR,INDT,PSSXX,X,OITM,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
+2 KILL PSSSRT,PSSDRG,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSEND
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
