- 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
- 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
