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