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

IMRRXS ;HCIOFO/NCA,FT/FAI-Utilization Report On Selected Drugs ;07/17/00  17:07
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
 ;[IMR SPECFC RX LIST] - Drug Specific Utilization Report
 I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRRXS" D ACESSERR^IMRERR,H^XUS K IMRLOC
 K ^TMP($J)
ASK D ^IMRDATE Q:$G(IMRHNBEG)=""
 S IMRSD=IMRHNBEG,IMRED=IMRHNEND
 ;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
 I IMRED<IMRSD W !,$C(7),"END DATE CAN NOT BE BEFORE START DATE",! G ASK
 K DIC S DIC("A")="Select DRUG GENERIC NAME: "
DRUG S DIC=50,DIC(0)="AEQM" D ^DIC G:$D(DTOUT)!($D(DUOUT)) KILL
 I Y>0 S IMRDLIST(+Y)="" S DIC("A")="Select ANOTHER DRUG GENERIC NAME: " G DRUG
 K DIC G:'$O(IMRDLIST(0)) KILL
 S X=$$RX1589^IMRUTL() ;get pharmacy archive date from File 158.9
 I X,X'<IMRSD,X'>IMRED D ASKN I $D(DIRUT) D KILL Q
 I X,X'<IMRSD,X>IMRED D ASKN I $D(DIRUT) D KILL Q
 D IMRDEV^IMREDIT G:POP KILL
 I $D(IO("Q")) D SAVE G KILL
 U IO D DQ D ^%ZISC K %ZIS,IOP G KILL
DQ ; Process Selected Drugs Utility Report
 S (IMRPG,IMRUT)=0 D NOW^%DTC S IMRDTE=%,Y=IMRDTE D DD^%DT S IMRDTE=Y
 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)
 S IMRX="DRUG SPECIFIC UTILIZATION REPORT" D HEDR
 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
 D RXPRNT
 I '$D(^TMP($J)) W !!,"No data for this report.",!
 D:'IMRUT EOP
 S:$D(ZTQUEUED) ZTREQ="@"
KILL 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
 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
 K NC,NF,NFT,NQ,NQT,IMRDRG,IMRFILDT,IMRRCOST,IMRUC,IMRDLIST
 Q
ASKN ; Ask the User Whether they want to Query the National
 S IMRYES=0 D ASKQ1^IMRNTL Q:'IMRYES  S IMRDL="" D ASKQ2^IMRNTL Q:IMRDL=""  D MSG^IMRNTL,PHS^IMRNTL1
 Q
C1 ; Get the Outpatient Pharmacy Data
 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
 Q
C2 ; Get initial fill data
 I 'IMRRXD1!('IMRXX1) Q  ;quit if no issue date or drug ien
 Q:'$D(IMRDLIST(IMRXX1))  ;quit if no drug selected by user
 S:'IMRUCST IMRUCST=IMRDU ;unit price of drug=price per dispense unit
 S IMRY=0
 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
 I IMRY S ^("C")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"C")):^("C"),1:0)+(IMRQ*IMRUCST)
 D RXF^IMRUTL ;get refill data
 S IMRN=""
 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
 Q
C3 ;
 S IMRQ=$G(IMRAR(52.1,IMRN,1,"I")),IMRRCOST=$G(IMRAR(52.1,IMRN,1.2,"I"))
 S:'IMRRCOST IMRRCOST=IMRUCST ;if no refill cost set it to unit price of drug
 S ^(IMRDFN)=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN)):^(IMRDFN),1:0)+1
 S ^("Q")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"Q")):^("Q"),1:0)+IMRQ
 S ^("C")=$S($D(^TMP($J,"IMRRX",IMRXX1,IMRNAM,IMRDFN,"C")):^("C"),1:0)+(IMRQ*IMRRCOST)
 Q
SAVE ; ZTSAVE the variables Used
 S ZTRTN="DQ^IMRRXS",ZTIO=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRDLIST(")="",ZTDESC="Selected RX Activity"
 D ^%ZTLOAD D ^%ZISC K IO("Q"),ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK G KILL
 Q
EOP ; Check End of Page
 Q:$D(IO("S"))  ;quit if a slave device
 I IOST["C-" K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1
 Q
RXPRNT ; print output
 F I=0:0 S I=$O(^TMP($J,"IMRRX",I)) Q:I'>0  I $D(^PSDRUG(I,0)) D PSDRUG,RX
 Q
PSDRUG ; Get File 50 data (^PSDRUG global)
 S IMRDRG=$$GET1^DIQ(50,I,.01,"I") ;generic drug name
 S IMRUC=+$$GET1^DIQ(50,I,16,"I") ;price per dispensed unit
 Q
RX ;
 S N=0,NQT=0,NFT=0,A=""
 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")
 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",!
 S A=""
 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
 .I $Y+4>IOSL D EOP Q:IMRUT  D HEDR
 .W !?5,A,?37,IMRSSN,$J(NF,8),$J(NQ,8),$J(NC,12,2)
 .Q
 W !!?12,"TOTAL",?46,$J(NFT,8),$J(NQT,8),$J(IMRUC*NQT,12,2)
 Q
HEDR ;
 S IMRPG=IMRPG+1
 W:$Y>0 @IOF
 W:IOST'["C-" !
 W !,IMRDTE,?(IOM-$L(IMRX)\2),IMRX,?(IOM-8),"Page ",IMRPG,!?(IOM-$L(IMRD)\2),IMRD,!
 Q