PSNNFL ;BIR/WRT-Report of National Formulary Names from VA PRODUCT file ; 11/01/99 7:20
;;4.0; NATIONAL DRUG FILE;**3,22**; 30 Oct 98
PRELIM W !,"This report will print out all National Formulary marked for National",!,"Formulary. You may sort by National Formulary Name or by VA Class.",!
W "This information comes from the VA Product file.",!,"This report requires 132 columns. You may queue the report to print,",!,"if you wish.",!!
ASK K DIR S DIR(0)="SA^C:CLASS;N:NAME",DIR("A")="Sort by VA Class (C) or National Formulary Name (N)? " D ^DIR Q:$D(DIRUT)
I Y(0)="NAME" S PSNANS=Y(0) G DVC
I Y(0)="CLASS" S PSNANS=Y(0) G ^PSNNFL1
Q
DVC K IO("Q"),%ZIS,POP,IOP S %ZIS="QM",%ZIS("B")="",%ZIS("A")="Select Printer: " D ^%ZIS G:POP DONE W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" DVC I POP K IOP,POP,IO("Q") Q
QUEUE I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSNNFL" K ZTSAVE,ZTDTH,ZTSK S PSNDEV=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("PSNDEV")="",ZTSAVE("PSNANS")="",ZTDESC="National Formulary Report",ZTIO=""
I D ^%ZTLOAD K MJT,%ZIS,POP,IOP,ZTSK D ^%ZISC Q
ENQ ;ENTRY POINT WHEN QUEUED
D LOOPA
I $D(ZTQUEUED) D QUEUE1
U IO
ENQ1 S PSNPGCT=0,PSNPGLNG=IOSL-6
D TITLE,LOOP1 W @IOF G DONE
TITLE I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
W !,?37,"VHA NATIONAL FORMULARY (BY NAME)"
S X="T" D ^%DT X ^DD("DD") W ?85,"Date printed: ",Y,!!,"R Indicates that a Restriction exists for the Product.",?85,"Page: ",PSNPGCT,!!
W !,"NATIONAL FORMULARY NAME",?100,"VA CLASS",?110,"RESTRICTION",!
F MJT=1:1:132 W "-"
Q
DONE S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J,"PSNF"),PSNB,PSNFLG,PSNAME,REST,RESTSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNATF,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,CLASS,PSNKK,PC,RS,PSNFLG,PSNFLG1,X0,DA,NA,CL,CLNM,DIR
K PSNANS,SF,DU,PSNANSR,PSNTRD,PSNUM,PSNDATE,X,IOP,POP,IO("Q") W:$Y @IOF D ^%ZISC
Q
QUEUE1 S IOP=PSNDEV F D ^%ZIS Q:'POP H 20
Q
LOOP S X0=^PSNDF(50.68,DA,0) I $D(^PSNDF(50.68,DA,5)),$P(^PSNDF(50.68,DA,5),"^")=1 S NA=$P(X0,"^",6),CL=$P(^PSNDF(50.68,DA,3),"^"),CL=$P($G(^PS(50.605,+CL,0)),"^"),RS=" " D CHECK S ^TMP($J,"PSNF",NA,CL,RS)=""
Q
LOOPA K ^TMP($J,"PSNF") S DA=0 F S DA=$O(^PSNDF(50.68,DA)) Q:'DA D LOOP
Q
LOOP1 S PSNATF="" F S PSNATF=$O(^TMP($J,"PSNF",PSNATF)) Q:PSNATF="" S PSNFLG=1 D LOOP2
Q
LOOP2 S CLASS="" F S CLASS=$O(^TMP($J,"PSNF",PSNATF,CLASS)) Q:CLASS="" D LOOP3
Q
LOOP3 S REST="" F S REST=$O(^TMP($J,"PSNF",PSNATF,CLASS,REST)) Q:REST="" D WRITE
Q
WRITE D:$Y>PSNPGLNG TITLE W:PSNFLG !,PSNATF S PSNFLG=0 W ?100,CLASS,?110,REST,!
Q
CHECK I $D(^PSNDF(50.68,DA,6)) S PC=$P(^PSNDF(50.68,DA,6,1,0),"^") I $E(PC,1,1)'="*" S RS="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNNFL 2661 printed Nov 22, 2024@17:34:23 Page 2
PSNNFL ;BIR/WRT-Report of National Formulary Names from VA PRODUCT file ; 11/01/99 7:20
+1 ;;4.0; NATIONAL DRUG FILE;**3,22**; 30 Oct 98
PRELIM WRITE !,"This report will print out all National Formulary marked for National",!,"Formulary. You may sort by National Formulary Name or by VA Class.",!
+1 WRITE "This information comes from the VA Product file.",!,"This report requires 132 columns. You may queue the report to print,",!,"if you wish.",!!
ASK KILL DIR
SET DIR(0)="SA^C:CLASS;N:NAME"
SET DIR("A")="Sort by VA Class (C) or National Formulary Name (N)? "
DO ^DIR
if $DATA(DIRUT)
QUIT
+1 IF Y(0)="NAME"
SET PSNANS=Y(0)
GOTO DVC
+2 IF Y(0)="CLASS"
SET PSNANS=Y(0)
GOTO ^PSNNFL1
+3 QUIT
DVC KILL IO("Q"),%ZIS,POP,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
SET %ZIS("A")="Select Printer: "
DO ^%ZIS
if POP
GOTO DONE
if $EXTRACT(IOST)'="P"
WRITE !!,"This report must be run on a printer.",!!
if $EXTRACT(IOST)'="P"
GOTO DVC
IF POP
KILL IOP,POP,IO("Q")
QUIT
QUEUE IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ENQ^PSNNFL"
KILL ZTSAVE,ZTDTH,ZTSK
SET PSNDEV=ION_";"_IOST_";"_IOM_";"_IOSL
SET ZTSAVE("PSNDEV")=""
SET ZTSAVE("PSNANS")=""
SET ZTDESC="National Formulary Report"
SET ZTIO=""
+1 IF $TEST
DO ^%ZTLOAD
KILL MJT,%ZIS,POP,IOP,ZTSK
DO ^%ZISC
QUIT
ENQ ;ENTRY POINT WHEN QUEUED
+1 DO LOOPA
+2 IF $DATA(ZTQUEUED)
DO QUEUE1
+3 USE IO
ENQ1 SET PSNPGCT=0
SET PSNPGLNG=IOSL-6
+1 DO TITLE
DO LOOP1
WRITE @IOF
GOTO DONE
TITLE IF $DATA(IOF)
IF IOF]""
WRITE @IOF
SET PSNPGCT=PSNPGCT+1
+1 WRITE !,?37,"VHA NATIONAL FORMULARY (BY NAME)"
+2 SET X="T"
DO ^%DT
XECUTE ^DD("DD")
WRITE ?85,"Date printed: ",Y,!!,"R Indicates that a Restriction exists for the Product.",?85,"Page: ",PSNPGCT,!!
+3 WRITE !,"NATIONAL FORMULARY NAME",?100,"VA CLASS",?110,"RESTRICTION",!
+4 FOR MJT=1:1:132
WRITE "-"
+5 QUIT
DONE if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB,"PSNF"),PSNB,PSNFLG,PSNAME,REST,RESTSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNATF,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,CLASS,PSNKK,PC,RS,PSNFLG,PSNFLG1,X0,DA,NA,CL,CLNM,DIR
+1 KILL PSNANS,SF,DU,PSNANSR,PSNTRD,PSNUM,PSNDATE,X,IOP,POP,IO("Q")
if $Y
WRITE @IOF
DO ^%ZISC
+2 QUIT
QUEUE1 SET IOP=PSNDEV
FOR
DO ^%ZIS
if 'POP
QUIT
HANG 20
+1 QUIT
LOOP SET X0=^PSNDF(50.68,DA,0)
IF $DATA(^PSNDF(50.68,DA,5))
IF $PIECE(^PSNDF(50.68,DA,5),"^")=1
SET NA=$PIECE(X0,"^",6)
SET CL=$PIECE(^PSNDF(50.68,DA,3),"^")
SET CL=$PIECE($GET(^PS(50.605,+CL,0)),"^")
SET RS=" "
DO CHECK
SET ^TMP($JOB,"PSNF",NA,CL,RS)=""
+1 QUIT
LOOPA KILL ^TMP($JOB,"PSNF")
SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
if 'DA
QUIT
DO LOOP
+1 QUIT
LOOP1 SET PSNATF=""
FOR
SET PSNATF=$ORDER(^TMP($JOB,"PSNF",PSNATF))
if PSNATF=""
QUIT
SET PSNFLG=1
DO LOOP2
+1 QUIT
LOOP2 SET CLASS=""
FOR
SET CLASS=$ORDER(^TMP($JOB,"PSNF",PSNATF,CLASS))
if CLASS=""
QUIT
DO LOOP3
+1 QUIT
LOOP3 SET REST=""
FOR
SET REST=$ORDER(^TMP($JOB,"PSNF",PSNATF,CLASS,REST))
if REST=""
QUIT
DO WRITE
+1 QUIT
WRITE if $Y>PSNPGLNG
DO TITLE
if PSNFLG
WRITE !,PSNATF
SET PSNFLG=0
WRITE ?100,CLASS,?110,REST,!
+1 QUIT
CHECK IF $DATA(^PSNDF(50.68,DA,6))
SET PC=$PIECE(^PSNDF(50.68,DA,6,1,0),"^")
IF $EXTRACT(PC,1,1)'="*"
SET RS="R"
+1 QUIT
