PSNNFL1 ;BIR/WRT-Report of National Formulary Names from VA PRODUCT file ; 11/22/98 15:10
;;4.0; NATIONAL DRUG FILE;**3**; 30 Oct 98
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 to 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^PSNNFL1" 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 CLASS)"
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 !,"VA CLASS",!?8,"RESTRICTION",?21,"NATIONAL FORMULARY NAME",!
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 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),"^"),CLNM=$P($G(^PS(50.605,+CL,0)),"^",2),CL=$P($G(^PS(50.605,+CL,0)),"^"),CL=CL_" "_CLNM,RS=" " D CHECK S ^TMP($J,"PSNF",CL,NA,RS)=""
Q
LOOPA K ^TMP($J,"PSNF") S DA=0 F S DA=$O(^PSNDF(50.68,DA)) Q:'DA S X0=^PSNDF(50.68,DA,0) D LOOP
Q
LOOP1 S CLASS="" F S CLASS=$O(^TMP($J,"PSNF",CLASS)) Q:CLASS="" S PSNFLG=1 D LOOP2
Q
LOOP2 S PSNATF="" F S PSNATF=$O(^TMP($J,"PSNF",CLASS,PSNATF)) Q:PSNATF="" S PSNFLG1=1 D LOOP3
Q
LOOP3 S REST="" F S REST=$O(^TMP($J,"PSNF",CLASS,PSNATF,REST)) Q:REST="" D WRITE
Q
WRITE D:$Y>PSNPGLNG TITLE W:PSNFLG !!,CLASS,! S PSNFLG=0 W:PSNFLG1 !,?8,REST,?21,PSNATF S PSNFLG1=0
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[HPSNNFL1 2234 printed Sep 23, 2025@20:00:23 Page 2
PSNNFL1 ;BIR/WRT-Report of National Formulary Names from VA PRODUCT file ; 11/22/98 15:10
+1 ;;4.0; NATIONAL DRUG FILE;**3**; 30 Oct 98
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 to 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^PSNNFL1"
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 CLASS)"
+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 !,"VA CLASS",!?8,"RESTRICTION",?21,"NATIONAL FORMULARY NAME",!
+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 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 CLNM=$PIECE($GET(^PS(50.605,+CL,0)),"^",2)
SET CL=$PIECE($GET(^PS(50.605,+CL,0)),"^")
SET CL=CL_" "_CLNM
SET RS=" "
DO CHECK
SET ^TMP($JOB,"PSNF",CL,NA,RS)=""
+1 QUIT
LOOPA KILL ^TMP($JOB,"PSNF")
SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
if 'DA
QUIT
SET X0=^PSNDF(50.68,DA,0)
DO LOOP
+1 QUIT
LOOP1 SET CLASS=""
FOR
SET CLASS=$ORDER(^TMP($JOB,"PSNF",CLASS))
if CLASS=""
QUIT
SET PSNFLG=1
DO LOOP2
+1 QUIT
LOOP2 SET PSNATF=""
FOR
SET PSNATF=$ORDER(^TMP($JOB,"PSNF",CLASS,PSNATF))
if PSNATF=""
QUIT
SET PSNFLG1=1
DO LOOP3
+1 QUIT
LOOP3 SET REST=""
FOR
SET REST=$ORDER(^TMP($JOB,"PSNF",CLASS,PSNATF,REST))
if REST=""
QUIT
DO WRITE
+1 QUIT
WRITE if $Y>PSNPGLNG
DO TITLE
if PSNFLG
WRITE !!,CLASS,!
SET PSNFLG=0
if PSNFLG1
WRITE !,?8,REST,?21,PSNATF
SET PSNFLG1=0
+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
