| 1 | PSNNFL1 ;BIR/WRT-Report of National Formulary Names from VA PRODUCT file ; 11/22/98 15:10
|
|---|
| 2 | ;;4.0; NATIONAL DRUG FILE;**3**; 30 Oct 98
|
|---|
| 3 | 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
|
|---|
| 4 | 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=""
|
|---|
| 5 | I D ^%ZTLOAD K MJT,%ZIS,POP,IOP,ZTSK D ^%ZISC Q
|
|---|
| 6 | ENQ ;ENTRY POINT WHEN QUEUED
|
|---|
| 7 | D LOOPA
|
|---|
| 8 | I $D(ZTQUEUED) D QUEUE1
|
|---|
| 9 | U IO
|
|---|
| 10 | ENQ1 S PSNPGCT=0,PSNPGLNG=IOSL-6
|
|---|
| 11 | D TITLE,LOOP1 W @IOF G DONE
|
|---|
| 12 | TITLE I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
|
|---|
| 13 | W !,?37,"VHA NATIONAL FORMULARY (BY CLASS)"
|
|---|
| 14 | 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,!!
|
|---|
| 15 | W !,"VA CLASS",!?8,"RESTRICTION",?21,"NATIONAL FORMULARY NAME",!
|
|---|
| 16 | F MJT=1:1:132 W "-"
|
|---|
| 17 | Q
|
|---|
| 18 | 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
|
|---|
| 19 | K PSNANS,SF,DU,PSNANSR,PSNTRD,PSNUM,PSNDATE,X,IOP,POP,IO("Q") W:$Y @IOF D ^%ZISC
|
|---|
| 20 | Q
|
|---|
| 21 | QUEUE1 S IOP=PSNDEV F D ^%ZIS Q:'POP H 20
|
|---|
| 22 | Q
|
|---|
| 23 | 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)=""
|
|---|
| 24 | Q
|
|---|
| 25 | 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
|
|---|
| 26 | Q
|
|---|
| 27 | LOOP1 S CLASS="" F S CLASS=$O(^TMP($J,"PSNF",CLASS)) Q:CLASS="" S PSNFLG=1 D LOOP2
|
|---|
| 28 | Q
|
|---|
| 29 | LOOP2 S PSNATF="" F S PSNATF=$O(^TMP($J,"PSNF",CLASS,PSNATF)) Q:PSNATF="" S PSNFLG1=1 D LOOP3
|
|---|
| 30 | Q
|
|---|
| 31 | LOOP3 S REST="" F S REST=$O(^TMP($J,"PSNF",CLASS,PSNATF,REST)) Q:REST="" D WRITE
|
|---|
| 32 | Q
|
|---|
| 33 | WRITE D:$Y>PSNPGLNG TITLE W:PSNFLG !!,CLASS,! S PSNFLG=0 W:PSNFLG1 !,?8,REST,?21,PSNATF S PSNFLG1=0
|
|---|
| 34 | Q
|
|---|
| 35 | 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"
|
|---|
| 36 | Q
|
|---|
