PSNSUPLY ;BIR/WRT-Print report of drugs with an "XA" classification- SORT BY CLASS CODE ;01/12/98 5:18 PM
;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
W !!,"This report should be run if you have already classed your local drugs/items",!,"using Version 1.0 of NDF. After the installation of Version 2.0 of NDF and the",!,"VA DRUG CLASS file is re-installed, you may wish "
W "to re-class your local items",!,"with an ""XA"" classification using the newly expanded ""XA000"" classification. It"
W !,"gives you a hard copy of the items from your local drug file which are ""active"" and have an ""XA"" VA Drug Classification.",!,"You may queue the report to print, if you wish.",!
DVC K %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^PSNSUPLY",ZTDESC="Supply (XA000) VA Class Report" D ^%ZTLOAD K ZTSK D ^%ZISC Q
ENQ ;ENTRY POINT WHEN QUEUED
U IO
S PSNPGCT=0,PSNPGLNG=IOSL-6,PSNPRT=0 D TITLE,LOOP1
DONE I $D(PSNPRT) W:PSNPRT=0 !!?10,"No Entries Found"
W @IOF S:$D(ZTQUEUED) ZTREQ="@" K PSNPRT,PSNB,CODE,NAME,CLSDA,WRT,MJT,PSNPGCT,PSNPGLNG,Y,IOP,POP,IO("Q") D ^%ZISC
Q
TITLE I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
W !,?8,"LOCAL ITEMS WITH A ""PROSTHETICS/SUPPLIES/DEVICES"" VA CLASSIFICATION",!
S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?55,"Page: ",PSNPGCT,!
W !,"NUMBER",?10,"LOCAL DRUG GENERIC NAME",?57,"VA CLASS",?70,"NEW CLASS",!
F MJT=1:1:80 W "-"
Q
LOOP1 S NAME="" F WRT=0:0 S NAME=$O(^PSDRUG("B",NAME)) Q:NAME="" S PSNB=$O(^PSDRUG("B",NAME,0)) D LOOP2
Q
LOOP2 I '$D(^PSDRUG(PSNB,"I")),$D(^PSDRUG(PSNB,"ND")),$P(^PSDRUG(PSNB,"ND"),"^",2)']"" S CLSDA=$P(^PSDRUG(PSNB,"ND"),"^",6) I $D(^PS(50.605,CLSDA,0)) D STRIP
Q
STRIP S CODE=$P(^PS(50.605,CLSDA,0),"^",1) I "XA"[$E(CODE,1,2) D REPRT
Q
REPRT D:$Y>PSNPGLNG TITLE W !!,PSNB,?10,$P(^PSDRUG(PSNB,0),"^",1),?57,$P(^PS(50.605,$P(^PSDRUG(PSNB,"ND"),"^",6),0),"^",1),?70,"_______" S PSNPRT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNSUPLY 2077 printed Dec 13, 2024@02:25:02 Page 2
PSNSUPLY ;BIR/WRT-Print report of drugs with an "XA" classification- SORT BY CLASS CODE ;01/12/98 5:18 PM
+1 ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
+2 WRITE !!,"This report should be run if you have already classed your local drugs/items",!,"using Version 1.0 of NDF. After the installation of Version 2.0 of NDF and the",!,"VA DRUG CLASS file is re-installed, you may wish "
+3 WRITE "to re-class your local items",!,"with an ""XA"" classification using the newly expanded ""XA000"" classification. It"
+4 WRITE !,"gives you a hard copy of the items from your local drug file which are ""active"" and have an ""XA"" VA Drug Classification.",!,"You may queue the report to print, if you wish.",!
DVC KILL %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^PSNSUPLY"
SET ZTDESC="Supply (XA000) VA Class Report"
DO ^%ZTLOAD
KILL ZTSK
DO ^%ZISC
QUIT
ENQ ;ENTRY POINT WHEN QUEUED
+1 USE IO
+2 SET PSNPGCT=0
SET PSNPGLNG=IOSL-6
SET PSNPRT=0
DO TITLE
DO LOOP1
DONE IF $DATA(PSNPRT)
if PSNPRT=0
WRITE !!?10,"No Entries Found"
+1 WRITE @IOF
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL PSNPRT,PSNB,CODE,NAME,CLSDA,WRT,MJT,PSNPGCT,PSNPGLNG,Y,IOP,POP,IO("Q")
DO ^%ZISC
+2 QUIT
TITLE IF $DATA(IOF)
IF IOF]""
WRITE @IOF
SET PSNPGCT=PSNPGCT+1
+1 WRITE !,?8,"LOCAL ITEMS WITH A ""PROSTHETICS/SUPPLIES/DEVICES"" VA CLASSIFICATION",!
+2 SET Y=DT
XECUTE ^DD("DD")
WRITE !,"Date printed: ",Y,?55,"Page: ",PSNPGCT,!
+3 WRITE !,"NUMBER",?10,"LOCAL DRUG GENERIC NAME",?57,"VA CLASS",?70,"NEW CLASS",!
+4 FOR MJT=1:1:80
WRITE "-"
+5 QUIT
LOOP1 SET NAME=""
FOR WRT=0:0
SET NAME=$ORDER(^PSDRUG("B",NAME))
if NAME=""
QUIT
SET PSNB=$ORDER(^PSDRUG("B",NAME,0))
DO LOOP2
+1 QUIT
LOOP2 IF '$DATA(^PSDRUG(PSNB,"I"))
IF $DATA(^PSDRUG(PSNB,"ND"))
IF $PIECE(^PSDRUG(PSNB,"ND"),"^",2)']""
SET CLSDA=$PIECE(^PSDRUG(PSNB,"ND"),"^",6)
IF $DATA(^PS(50.605,CLSDA,0))
DO STRIP
+1 QUIT
STRIP SET CODE=$PIECE(^PS(50.605,CLSDA,0),"^",1)
IF "XA"[$EXTRACT(CODE,1,2)
DO REPRT
+1 QUIT
REPRT if $Y>PSNPGLNG
DO TITLE
WRITE !!,PSNB,?10,$PIECE(^PSDRUG(PSNB,0),"^",1),?57,$PIECE(^PS(50.605,$PIECE(^PSDRUG(PSNB,"ND"),"^",6),0),"^",1),?70,"_______"
SET PSNPRT=1
+1 QUIT
