PSNHFRM1 ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file -sort by class ; 11/22/98 15:10
;;4.0; NATIONAL DRUG FILE;**3**; 30 Oct 98
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 !,PSNANS_" FORMULARY (BY VA DRUG CLASS)"
S X="T",%DT="" D ^%DT X ^DD("DD") W ?55,"Date printed: ",Y,!?55,"Page: ",PSNPGCT,!!
W !,?10,"VA DRUG CLASS",!,?29,"PRICE /"
W !,"GENERIC NAME",?29,"DISP UNT",?49,"TRADE NAME(S)",!
F MJT=1:1:80 W "-"
Q
DONE S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J),PSNB,PSNFLG,PSNAME,PSNCL,PSNCLSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNLGN,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,PSNLOC,PSNKK,PSNPRIC,PSNPRICE
K PSNANS,SF,DU,PSNCN,PSNFG1,PSNFG2,PSNFLAGG,PSNHH,PSNQ,PSNVCN,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 PSNB=D0,PSNAME=$P(^PSDRUG(PSNB,0),"^",1),PSNCLSS=$P(^PSDRUG(PSNB,0),"^",2),PSNQ=$O(^PS(50.605,"B",PSNCLSS,0)),PSNVCN=$P(^PS(50.605,PSNQ,0),"^",2) I $P(^PSDRUG(PSNB,0),"^",9)'=1 D CHECK
Q
GETDATE I '$D(^PSDRUG(PSNB,"I")) D GETNODE,GETPRIC
I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X<PSNDATE D GETNODE,GETPRIC
Q
GETNODE K X I '$D(^PSDRUG(PSNB,660)) S PSNPRICE="No Price /" D GETRADE,GETRADE1
Q
GETPRIC I $D(^PSDRUG(PSNB,660)) S PSNPRIC=$P(^PSDRUG(PSNB,660),"^",6),DU=$P(^PSDRUG(PSNB,660),"^",8) D PRICE1,PRICE2
Q
PRICE1 I PSNPRIC']"" S PSNPRICE="No Price"_" / "_DU D GETRADE,GETRADE1,BUILDIT
Q
PRICE2 I PSNPRIC]"" S PSNPRICE=PSNPRIC,PSNPRICE=PSNPRICE_" / "_DU D GETRADE,GETRADE1,BUILDIT
Q
GETRADE1 I '$O(^PSDRUG(PSNB,1,0)) K PSNAR S PSNTRD="ZZXZZXZZX" S PSNAR(1,PSNCLSS,PSNAME,PSNTRD)=""
Q
GETRADE I $O(^PSDRUG(PSNB,1,0)) K PSNAR F PSNUM=0:0 S PSNUM=$O(^PSDRUG(PSNB,1,PSNUM)) Q:'PSNUM D TRADE1,TRADE2,TRADE3
Q
TRADE1 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=1 S PSNTRD="ZZXZZXZZX" S PSNAR(3,PSNCLSS,PSNAME,PSNTRD)=""
Q
TRADE2 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0 S PSNTRD=$P(^PSDRUG(PSNB,1,PSNUM,0),"^",1) S PSNAR(1,PSNCLSS,PSNAME,PSNTRD)=""
Q
TRADE3 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)="" S PSNTRD="ZZXZZXZZX" S PSNAR(2,PSNCLSS,PSNAME,PSNTRD)=""
Q
BUILDIT F PSNKK=1,2,3 D BUILDIT1
Q
BUILDIT1 S PSNFF="" F S PSNFF=$O(PSNAR(PSNKK,PSNFF)) Q:PSNFF="" S PSNGG="" F S PSNGG=$O(PSNAR(PSNKK,PSNFF,PSNGG)) Q:PSNGG="" S PSNHH="" F S PSNHH=$O(PSNAR(PSNKK,PSNFF,PSNGG,PSNHH)) Q:PSNHH="" D BUILD
Q
BUILD S PSNFG=0 I PSNFG=0 S ^TMP($J,"PSNFC",PSNFF,PSNGG,PSNPRICE,PSNHH)=PSNVCN
Q
LOOP1 S PSNCL="" F S PSNCL=$O(^TMP($J,"PSNFC",PSNCL)) Q:PSNCL="" S PSNFLG=1 D LOOP2
Q
LOOP2 S PSNLGN="" F S PSNLGN=$O(^TMP($J,"PSNFC",PSNCL,PSNLGN)) Q:PSNLGN="" S PSNFLAGG=1 D LOOP3
Q
LOOP3 S PSNPR="" F S PSNPR=$O(^TMP($J,"PSNFC",PSNCL,PSNLGN,PSNPR)) Q:PSNPR="" S PSNFG1=1 D LOOP4
Q
LOOP4 S PSNLOC="" F S PSNLOC=$O(^TMP($J,"PSNFC",PSNCL,PSNLGN,PSNPR,PSNLOC)) Q:PSNLOC="" S PSNFG2=1,PSNCN=$P(^TMP($J,"PSNFC",PSNCL,PSNLGN,PSNPR,PSNLOC),"^") D WRITE
Q
WRITE D:$Y>PSNPGLNG TITLE W:PSNFLG !!?10,PSNCL_" "_PSNCN,! S PSNFLG=0 W:PSNFLAGG !,PSNLGN S PSNFLAGG=0 W:PSNFG1 !?29,PSNPR S PSNFG1=0 I PSNLOC'="ZZXZZXZZX" W:PSNFG2 ?49,PSNLOC S PSNFG2=0
W !
Q
CHECK I SF=0,$P(^PSDRUG(PSNB,0),"^",3)'["S" D GETDATE
I SF=1 D GETDATE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNHFRM1 3275 printed Oct 16, 2024@18:24:54 Page 2
PSNHFRM1 ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file -sort by class ; 11/22/98 15:10
+1 ;;4.0; NATIONAL DRUG FILE;**3**; 30 Oct 98
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 !,PSNANS_" FORMULARY (BY VA DRUG CLASS)"
+2 SET X="T"
SET %DT=""
DO ^%DT
XECUTE ^DD("DD")
WRITE ?55,"Date printed: ",Y,!?55,"Page: ",PSNPGCT,!!
+3 WRITE !,?10,"VA DRUG CLASS",!,?29,"PRICE /"
+4 WRITE !,"GENERIC NAME",?29,"DISP UNT",?49,"TRADE NAME(S)",!
+5 FOR MJT=1:1:80
WRITE "-"
+6 QUIT
DONE if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB),PSNB,PSNFLG,PSNAME,PSNCL,PSNCLSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNLGN,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,PSNLOC,PSNKK,PSNPRIC,PSNPRICE
+1 KILL PSNANS,SF,DU,PSNCN,PSNFG1,PSNFG2,PSNFLAGG,PSNHH,PSNQ,PSNVCN,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 PSNB=D0
SET PSNAME=$PIECE(^PSDRUG(PSNB,0),"^",1)
SET PSNCLSS=$PIECE(^PSDRUG(PSNB,0),"^",2)
SET PSNQ=$ORDER(^PS(50.605,"B",PSNCLSS,0))
SET PSNVCN=$PIECE(^PS(50.605,PSNQ,0),"^",2)
IF $PIECE(^PSDRUG(PSNB,0),"^",9)'=1
DO CHECK
+1 QUIT
GETDATE IF '$DATA(^PSDRUG(PSNB,"I"))
DO GETNODE
DO GETPRIC
+1 IF $DATA(^PSDRUG(PSNB,"I"))
SET PSNDATE=$PIECE(^PSDRUG(PSNB,"I"),"^")
DO NOW^%DTC
IF X<PSNDATE
DO GETNODE
DO GETPRIC
+2 QUIT
GETNODE KILL X
IF '$DATA(^PSDRUG(PSNB,660))
SET PSNPRICE="No Price /"
DO GETRADE
DO GETRADE1
+1 QUIT
GETPRIC IF $DATA(^PSDRUG(PSNB,660))
SET PSNPRIC=$PIECE(^PSDRUG(PSNB,660),"^",6)
SET DU=$PIECE(^PSDRUG(PSNB,660),"^",8)
DO PRICE1
DO PRICE2
+1 QUIT
PRICE1 IF PSNPRIC']""
SET PSNPRICE="No Price"_" / "_DU
DO GETRADE
DO GETRADE1
DO BUILDIT
+1 QUIT
PRICE2 IF PSNPRIC]""
SET PSNPRICE=PSNPRIC
SET PSNPRICE=PSNPRICE_" / "_DU
DO GETRADE
DO GETRADE1
DO BUILDIT
+1 QUIT
GETRADE1 IF '$ORDER(^PSDRUG(PSNB,1,0))
KILL PSNAR
SET PSNTRD="ZZXZZXZZX"
SET PSNAR(1,PSNCLSS,PSNAME,PSNTRD)=""
+1 QUIT
GETRADE IF $ORDER(^PSDRUG(PSNB,1,0))
KILL PSNAR
FOR PSNUM=0:0
SET PSNUM=$ORDER(^PSDRUG(PSNB,1,PSNUM))
if 'PSNUM
QUIT
DO TRADE1
DO TRADE2
DO TRADE3
+1 QUIT
TRADE1 IF $PIECE(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=1
SET PSNTRD="ZZXZZXZZX"
SET PSNAR(3,PSNCLSS,PSNAME,PSNTRD)=""
+1 QUIT
TRADE2 IF $PIECE(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0
SET PSNTRD=$PIECE(^PSDRUG(PSNB,1,PSNUM,0),"^",1)
SET PSNAR(1,PSNCLSS,PSNAME,PSNTRD)=""
+1 QUIT
TRADE3 IF $PIECE(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=""
SET PSNTRD="ZZXZZXZZX"
SET PSNAR(2,PSNCLSS,PSNAME,PSNTRD)=""
+1 QUIT
BUILDIT FOR PSNKK=1,2,3
DO BUILDIT1
+1 QUIT
BUILDIT1 SET PSNFF=""
FOR
SET PSNFF=$ORDER(PSNAR(PSNKK,PSNFF))
if PSNFF=""
QUIT
SET PSNGG=""
FOR
SET PSNGG=$ORDER(PSNAR(PSNKK,PSNFF,PSNGG))
if PSNGG=""
QUIT
SET PSNHH=""
FOR
SET PSNHH=$ORDER(PSNAR(PSNKK,PSNFF,PSNGG,PSNHH))
if PSNHH=""
QUIT
DO BUILD
+1 QUIT
BUILD SET PSNFG=0
IF PSNFG=0
SET ^TMP($JOB,"PSNFC",PSNFF,PSNGG,PSNPRICE,PSNHH)=PSNVCN
+1 QUIT
LOOP1 SET PSNCL=""
FOR
SET PSNCL=$ORDER(^TMP($JOB,"PSNFC",PSNCL))
if PSNCL=""
QUIT
SET PSNFLG=1
DO LOOP2
+1 QUIT
LOOP2 SET PSNLGN=""
FOR
SET PSNLGN=$ORDER(^TMP($JOB,"PSNFC",PSNCL,PSNLGN))
if PSNLGN=""
QUIT
SET PSNFLAGG=1
DO LOOP3
+1 QUIT
LOOP3 SET PSNPR=""
FOR
SET PSNPR=$ORDER(^TMP($JOB,"PSNFC",PSNCL,PSNLGN,PSNPR))
if PSNPR=""
QUIT
SET PSNFG1=1
DO LOOP4
+1 QUIT
LOOP4 SET PSNLOC=""
FOR
SET PSNLOC=$ORDER(^TMP($JOB,"PSNFC",PSNCL,PSNLGN,PSNPR,PSNLOC))
if PSNLOC=""
QUIT
SET PSNFG2=1
SET PSNCN=$PIECE(^TMP($JOB,"PSNFC",PSNCL,PSNLGN,PSNPR,PSNLOC),"^")
DO WRITE
+1 QUIT
WRITE if $Y>PSNPGLNG
DO TITLE
if PSNFLG
WRITE !!?10,PSNCL_" "_PSNCN,!
SET PSNFLG=0
if PSNFLAGG
WRITE !,PSNLGN
SET PSNFLAGG=0
if PSNFG1
WRITE !?29,PSNPR
SET PSNFG1=0
IF PSNLOC'="ZZXZZXZZX"
if PSNFG2
WRITE ?49,PSNLOC
SET PSNFG2=0
+1 WRITE !
+2 QUIT
CHECK IF SF=0
IF $PIECE(^PSDRUG(PSNB,0),"^",3)'["S"
DO GETDATE
+1 IF SF=1
DO GETDATE
+2 QUIT
