PSSDTR.m

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSSDTR   7853     printed  Mar 13, 2025@21:35:54                                                                                                                                                                                                      Page 2

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