source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRRADL.m@ 1246

IMRRADL ;HCIOFO/NCA-/FAIPrint Radiology Utility Report ;09/26/00  07:03
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5,11**;Feb 09, 1998
 ;[IMR RADIOLOGY UTILIZATION] - Radiology Utilization Report
ASK D ^IMRDATE Q:$G(IMRHNBEG)=""
 S IMRSD=IMRHNBEG,IMRED=IMRHNEND
 I IMRED<IMRSD W !,$C(7),"END CAN NOT BE BEFORE START",! G ASK
 K DIR S DIR(0)="N^1:999999",DIR("A")="Minimum number of procedures to display",DIR("B")=2,DIR("?")="This determines the minimum number of procedures which will be displayed in the listing by order of number of procedures."
 D ^DIR K DIR G:$D(DIRUT) KIL S IMRN1=X
 S DIR(0)="Y",DIR("A")="Print Data by CATEGORY as well as totals",DIR("B")="NO",DIR("?")="Answer YES to get a listings of utilization by HIV CATEGORY as well as total population." D ^DIR
 G:$D(DIRUT) KIL S IMR2C=Y K DIR
 S IMRRMAX=0 I $D(^XUSEC("IMRMGR",DUZ)) D ASKQ G:$D(DIRUT) KIL
 I $D(^XUSEC("IMRMGR",DUZ)) D IMRDEV^IMREDIT G:POP KIL
 I '$D(^XUSEC("IMRMGR",DUZ)) D ^%ZIS G:POP KIL
 I $D(IO("Q")) D SAVE G KIL
 U IO D DQ D ^%ZISC K %ZIS,IOP G KIL
SAVE ; ZTSAVE all the Variables
 S ZTSAVE("IMR2C")="",ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRN1")="",ZTSAVE("IMRRMAX")="",ZTDESC="Radiology Utilization Report"
 S ZTRTN="DQ^IMRRADL",ZTIO=ION_";"_IOM_";"_IOSL
 D ^%ZTLOAD D ^%ZISC K IO("Q"),ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK G KIL
DQ ; Process Radiology Report
 K ^TMP($J) S (IMRPG,IMRUT)=0
 S (IMRPAT,IMRCPR,IMRDPR,IMRTTP)=""
 S:$D(ZTQUEUED) ZTREQ="@"
 D NOW^%DTC S IMRDTE=%,Y=IMRDTE D DD^%DT S IMRDTE=Y
 F IMRRL=0:0 S IMRRL=$O(^IMR(158,IMRRL)) Q:IMRRL'>0  S X=+^(IMRRL,0),IMR0C=+$P(^(0),U,42) D XOR^IMRXOR S IMRDFN=X I $D(^DPT(IMRDFN,0)) D CAT^IMRUTL S IMR1C=$S(IMR2C:"C"_IMR0C,1:"CT") D C1
 D C2,PRNT^IMRRADL1
 I 'IMRUT D EOP^IMRRADL1
 Q
KIL K %,%DT,%I,DFN,DIR,DIRUT,DIROUT,IMRCTR,IMRCPR,IMRCPT,IMRD,IMRDPR,IMRDTE,IMRFLG,IMRNAM,IMRPAT,IMRPCTR,IMRPG,IMRPN,IMRPR,IMRSTAT,IMRDFN,IMRI,IMRJ,IMRQ,IMRUT,IMRSD,IMRED,IMRX,IMRN,IMRN1,IMRN2,^TMP($J)
 K %ZIS,H,I1,IMRCP,IMR2C,IMR0C,IMR1C,IMRRI,IMRRL,IMRNAM,IMRPRN,IMRSSN,IMRTIT,IMRRDT,IMRSTN,IMRTOT,IMRTP,IMRTTP,I,J,K,M,N,IMRRMAX,IMRX1,IMRY,POP,Q,X,X1,X2,Y,Z,Z1,L,P,VAERR
 K CINF,CNPT,CPCAT,CPIND,CPTCT,CPTID,CPTMD,CPTNO,CPTPT,CPTREC,IMR0C,IMRCPT,IMRLBL,IMCX,IMRTP,IMRTTP,PTCOUNT,NBP,TCPM,TOTMOD,TTM,UNPT
 Q
C1 ; Get the Radiology Data
 S (IMRSTAT,IMRPN,IMRPR,IMRRDT,IMRCPT)="",IMRPCTR=1 K IMRCTR
 S IMR0C=IMR0C+1 S:'IMR2C IMR0C=6
 D RAD^IMRUTL Q:'$D(^TMP($J,"RAE1",IMRDFN))
 S IMRI="" F  S IMRI=$O(^TMP($J,"RAE1",IMRDFN,IMRI)) Q:IMRI=""  S IMRX=$G(^(IMRI)),IMRCPT=$P(IMRX,"^",10) D
 .D CPTMOD
 .S IMRPR=$E($P(IMRX,"^",1),1,30) Q:IMRPR=""
 .S IMRRDT=9999999.9999-$P(IMRI,"-",1),IMRPN=IMRPR_"~"_IMRCPT
 .S:'$D(^TMP($J,"IMRPT",IMR1C,IMRDFN)) ^(IMRDFN)=""
 .S IMRCTR=$G(^TMP($J,"IMRPT",IMR1C,IMRDFN))
 .I '$D(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN)) S ^(IMRPN)=0_"^"_IMRPCTR,$P(IMRCTR,"^",2)=$P(IMRCTR,"^",2)+1
 .S IMRX1=$G(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN))
 .S $P(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN),"^",1)=$P(IMRX1,"^",1)+1,$P(IMRCTR,"^",1)=$P(IMRCTR,"^",1)+1
 .S $P(IMRCPR,"^",IMR0C)=$P(IMRCPR,"^",IMR0C)+1
 .S ^TMP($J,"IMRPT",IMR1C,IMRDFN)=IMRCTR Q
 S IMRPN="" F  S IMRPN=$O(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN)) Q:IMRPN=""  S X=$G(^(IMRPN)) D
 .I '$D(^TMP($J,"IMRPR",IMR1C,IMRPN)) S ^(IMRPN)=0,$P(IMRDPR,"^",IMR0C)=$P(IMRDPR,"^",IMR0C)+1
 .S Y=$G(^TMP($J,"IMRPR",IMR1C,IMRPN))
 .S $P(Y,"^",1)=$P(Y,"^",1)+X,$P(Y,"^",2)=$P(Y,"^",2)+$P(X,"^",2)
 .S $P(IMRTTP,"^",IMR0C)=$P(IMRTTP,"^",IMR0C)+$P(X,"^",2)
 .S ^TMP($J,"IMRPR",IMR1C,IMRPN)=Y
 .Q
 S $P(IMRPAT,"^",IMR0C)=$P(IMRPAT,"^",IMR0C)+1
 K ^TMP($J,"IMRT"),^TMP($J,"RAE1")
 Q
CPTMOD S IMCX="" F  S IMCX=$O(^TMP($J,"RAE1",IMRDFN,IMRI,"CMOD",IMCX)) Q:IMCX=""  S IMCPM=$P($G(^TMP($J,"RAE1",IMRDFN,IMRI,"CMOD",IMCX)),U,1) S:$G(IMCPM)'="" IMRCPT=IMRCPT_"-"_IMCPM
 Q
C2 ; Set tabulation in ^TMP for each category and All
 I 'IMR2C S IMR1C="CT" D C3,C31,REMOV Q
 F IMR0C=0:1:4 S IMR1C="C"_IMR0C D C3,C31
REMOV K ^TMP($J,"IMRPR"),^TMP($J,"IMRPT")
 Q
C3 ; Set in ^TMP in order of total Procedures
 S IMRPRN="" F  S IMRPN=$O(^TMP($J,"IMRPR",IMR1C,IMRPN)) Q:IMRPN=""  S X=$G(^(IMRPN)),^TMP($J,"IMRPRN",IMR1C,+X,IMRPN)=X
 Q
C31 Q:'IMRRMAX  F IMRDFN=0:0 S IMRDFN=$O(^TMP($J,"IMRPT",IMR1C,IMRDFN)) Q:IMRDFN<1  S X=$G(^(IMRDFN)),^TMP($J,"IMRPAT",IMR1C,+X,IMRDFN)=X
 Q
ASKQ K DIR S DIR(0)="N^0:999999",DIR("A")="How many of the highest users do you want identified",DIR("B")=0
 S DIR("?")="This determines the number of individuals with the highest utilization of procedures you wish listed" D ^DIR Q:$D(DIRUT)
 S IMRRMAX=X K DIR
 Q