source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRRXS.m@ 1639

Last change on this file since 1639 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1IMRRXS ;HCIOFO/NCA,FT/FAI-Utilization Report On Selected Drugs ;07/17/00 17:07
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
3 ;[IMR SPECFC RX LIST] - Drug Specific Utilization Report
4 I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRRXS" D ACESSERR^IMRERR,H^XUS K IMRLOC
5 K ^TMP($J)
6ASK D ^IMRDATE Q:$G(IMRHNBEG)=""
7 S IMRSD=IMRHNBEG,IMRED=IMRHNEND
8 ;K %DT S %DT="AQEXP",%DT("A")=" Start Date for Period: " D ^%DT K %DT G:Y'>0 KILL S IMRSD=Y,%DT="AQEXP",%DT("A")=" End Date for Period: " D ^%DT K %DT G:Y'>0 KILL S IMRED=Y
9 I IMRED<IMRSD W !,$C(7),"END DATE CAN NOT BE BEFORE START DATE",! G ASK
10 K DIC S DIC("A")="Select DRUG GENERIC NAME: "
11DRUG S DIC=50,DIC(0)="AEQM" D ^DIC G:$D(DTOUT)!($D(DUOUT)) KILL
12 I Y>0 S IMRDLIST(+Y)="" S DIC("A")="Select ANOTHER DRUG GENERIC NAME: " G DRUG
13 K DIC G:'$O(IMRDLIST(0)) KILL
14 S X=$$RX1589^IMRUTL() ;get pharmacy archive date from File 158.9
15 I X,X'<IMRSD,X'>IMRED D ASKN I $D(DIRUT) D KILL Q
16 I X,X'<IMRSD,X>IMRED D ASKN I $D(DIRUT) D KILL Q
17 D IMRDEV^IMREDIT G:POP KILL
18 I $D(IO("Q")) D SAVE G KILL
19 U IO D DQ D ^%ZISC K %ZIS,IOP G KILL
20DQ ; Process Selected Drugs Utility Report
21 S (IMRPG,IMRUT)=0 D NOW^%DTC S IMRDTE=%,Y=IMRDTE D DD^%DT S IMRDTE=Y
22 S IMRD="FOR THE PERIOD "_$E(IMRSD,4,5)_"/"_$E(IMRSD,6,7)_"/"_$E(IMRSD,2,3)_" TO "_$E(IMRED,4,5)_"/"_$E(IMRED,6,7)_"/"_$E(IMRED,2,3)
23 S IMRX="DRUG SPECIFIC UTILIZATION REPORT" D HEDR
24 F IMRRL=0:0 S IMRRL=$O(^IMR(158,IMRRL)) Q:IMRRL<1 S X=+^(IMRRL,0) D ^IMRXOR S IMRDFN=X I $D(^DPT(IMRDFN,0)) S DFN=IMRDFN D NS^IMRCALL K DFN D C1
25 D RXPRNT
26 I '$D(^TMP($J)) W !!,"No data for this report.",!
27 D:'IMRUT EOP
28 S:$D(ZTQUEUED) ZTREQ="@"
29KILL K C,C1,DIRUT,IMRCL,IMRDFN,IMRDR,IMRI,IMRJ,IMRN,IMRN1,IMRQ,IMRRP,IMRXX1,IMRRXD,IMRRXDR,IMRRXD1,IMRUT,IMRY,IMRSD,IMRED,IMRX,IMRD,IMRR,IMRFLG,IMRNAM,IMRSSN,IMRSTN,A,DISYS,IMRYES,IMRDL,IMRDSUP
30 K %,%DT,%I,I,DIC,DIR,DTOUT,DUOUT,IMRDTE,IMRRI,IMREF,IMRPG,IMREC,IMRRL,IMRPS,IMRUCST,IMREXP,IMRDST,IMRDU,IMRAR,J,K,M,N,POP,Q,X,X1,X2,Y,Z,Z1,^TMP($J),VAERR
31 K NC,NF,NFT,NQ,NQT,IMRDRG,IMRFILDT,IMRRCOST,IMRUC,IMRDLIST
32 Q
33ASKN ; Ask the User Whether they want to Query the National
34 S IMRYES=0 D ASKQ1^IMRNTL Q:'IMRYES S IMRDL="" D ASKQ2^IMRNTL Q:IMRDL="" D MSG^IMRNTL,PHS^IMRNTL1
35 Q
36C1 ; Get the Outpatient Pharmacy Data
37 F IMRRP=0:0 S IMRRP=$O(^PS(55,IMRDFN,"P","A",IMRRP)) Q:IMRRP<1 I IMRRP'<IMRSD F IMRR=0:0 S IMRR=$O(^PS(55,IMRDFN,"P","A",IMRRP,IMRR)) Q:IMRR<1 D RX^IMRUTL,C2
38 Q
39C2 ; Get initial fill data
40 I 'IMRRXD1!('IMRXX1) Q ;quit if no issue date or drug ien
41 Q:'$D(IMRDLIST(IMRXX1)) ;quit if no drug selected by user
42 S:'IMRUCST IMRUCST=IMRDU ;unit price of drug=price per dispense unit
43 S IMRY=0
44 I IMRFILDT>IMRSD,IMRFILDT'>IMRED S IMRY=1,^(IMRDFN)=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN)):^(IMRDFN),1:0)+1,^("Q")=$S($D(^(IMRDFN,"Q")):^("Q"),1:0)+IMRQ
45 I IMRY S ^("C")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"C")):^("C"),1:0)+(IMRQ*IMRUCST)
46 D RXF^IMRUTL ;get refill data
47 S IMRN=""
48 F S IMRN=$O(IMRAR(52.1,IMRN)) Q:IMRN="" S IMRRXD=+$G(IMRAR(52.1,IMRN,.01,"I")) I IMRRXD>IMRSD,IMRRXD'>IMRED D C3
49 Q
50C3 ;
51 S IMRQ=$G(IMRAR(52.1,IMRN,1,"I")),IMRRCOST=$G(IMRAR(52.1,IMRN,1.2,"I"))
52 S:'IMRRCOST IMRRCOST=IMRUCST ;if no refill cost set it to unit price of drug
53 S ^(IMRDFN)=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN)):^(IMRDFN),1:0)+1
54 S ^("Q")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"Q")):^("Q"),1:0)+IMRQ
55 S ^("C")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"C")):^("C"),1:0)+(IMRQ*IMRRCOST)
56 Q
57SAVE ; ZTSAVE the variables Used
58 S ZTRTN="DQ^IMRRXS",ZTIO=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRDLIST(")="",ZTDESC="Selected RX Activity"
59 D ^%ZTLOAD D ^%ZISC K IO("Q"),ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK G KILL
60 Q
61EOP ; Check End of Page
62 Q:$D(IO("S")) ;quit if a slave device
63 I IOST["C-" K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1
64 Q
65RXPRNT ; print output
66 F I=0:0 S I=$O(^TMP($J,"IMRRX",I)) Q:I'>0 I $D(^PSDRUG(I,0)) D PSDRUG,RX
67 Q
68PSDRUG ; Get File 50 data (^PSDRUG global)
69 S IMRDRG=$$GET1^DIQ(50,I,.01,"I") ;generic drug name
70 S IMRUC=+$$GET1^DIQ(50,I,16,"I") ;price per dispensed unit
71 Q
72RX ;
73 S N=0,NQT=0,NFT=0,A=""
74 F J=0:0 S A=$O(^TMP($J,"IMRRX",I,A)) Q:A="" F K=0:0 S K=$O(^TMP($J,"IMRRX",I,A,K)) Q:K'>0 S N=N+1,NFT=NFT+^(K),NQT=NQT+^(K,"Q")
75 W !,IMRDRG,?45,"Current Unit Cost: $ ",$S(IMRUC>0:$J(IMRUC,0,4),1:"NOT ENTERED"),!?5,N," patients",$J(NFT,8)," fills",$J(NQT,8)," Dispensed $ ",$J(IMRUC*NQT,0,2)," Current Value",!
76 S A=""
77 F J=0:0 S A=$O(^TMP($J,"IMRRX",I,A)) Q:A=""!(IMRUT) F K=0:0 S K=$O(^TMP($J,"IMRRX",I,A,K)) Q:K'>0!(IMRUT) S NF=^(K),NQ=^(K,"Q"),NC=NQ*IMRUC,DFN=K D NS^IMRCALL K DFN D
78 .I $Y+4>IOSL D EOP Q:IMRUT D HEDR
79 .W !?5,A,?37,IMRSSN,$J(NF,8),$J(NQ,8),$J(NC,12,2)
80 .Q
81 W !!?12,"TOTAL",?46,$J(NFT,8),$J(NQT,8),$J(IMRUC*NQT,12,2)
82 Q
83HEDR ;
84 S IMRPG=IMRPG+1
85 W:$Y>0 @IOF
86 W:IOST'["C-" !
87 W !,IMRDTE,?(IOM-$L(IMRX)\2),IMRX,?(IOM-8),"Page ",IMRPG,!?(IOM-$L(IMRD)\2),IMRD,!
88 Q
Note: See TracBrowser for help on using the repository browser.