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

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

initial load of WorldVistAEHR

File size: 4.4 KB
RevLine 
[613]1IMRRADL ;HCIOFO/NCA-/FAIPrint Radiology Utility Report ;09/26/00 07:03
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5,11**;Feb 09, 1998
3 ;[IMR RADIOLOGY UTILIZATION] - Radiology Utilization Report
4ASK D ^IMRDATE Q:$G(IMRHNBEG)=""
5 S IMRSD=IMRHNBEG,IMRED=IMRHNEND
6 I IMRED<IMRSD W !,$C(7),"END CAN NOT BE BEFORE START",! G ASK
7 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."
8 D ^DIR K DIR G:$D(DIRUT) KIL S IMRN1=X
9 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
10 G:$D(DIRUT) KIL S IMR2C=Y K DIR
11 S IMRRMAX=0 I $D(^XUSEC("IMRMGR",DUZ)) D ASKQ G:$D(DIRUT) KIL
12 I $D(^XUSEC("IMRMGR",DUZ)) D IMRDEV^IMREDIT G:POP KIL
13 I '$D(^XUSEC("IMRMGR",DUZ)) D ^%ZIS G:POP KIL
14 I $D(IO("Q")) D SAVE G KIL
15 U IO D DQ D ^%ZISC K %ZIS,IOP G KIL
16SAVE ; ZTSAVE all the Variables
17 S ZTSAVE("IMR2C")="",ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRN1")="",ZTSAVE("IMRRMAX")="",ZTDESC="Radiology Utilization Report"
18 S ZTRTN="DQ^IMRRADL",ZTIO=ION_";"_IOM_";"_IOSL
19 D ^%ZTLOAD D ^%ZISC K IO("Q"),ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK G KIL
20DQ ; Process Radiology Report
21 K ^TMP($J) S (IMRPG,IMRUT)=0
22 S (IMRPAT,IMRCPR,IMRDPR,IMRTTP)=""
23 S:$D(ZTQUEUED) ZTREQ="@"
24 D NOW^%DTC S IMRDTE=%,Y=IMRDTE D DD^%DT S IMRDTE=Y
25 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
26 D C2,PRNT^IMRRADL1
27 I 'IMRUT D EOP^IMRRADL1
28 Q
29KIL 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)
30 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
31 K CINF,CNPT,CPCAT,CPIND,CPTCT,CPTID,CPTMD,CPTNO,CPTPT,CPTREC,IMR0C,IMRCPT,IMRLBL,IMCX,IMRTP,IMRTTP,PTCOUNT,NBP,TCPM,TOTMOD,TTM,UNPT
32 Q
33C1 ; Get the Radiology Data
34 S (IMRSTAT,IMRPN,IMRPR,IMRRDT,IMRCPT)="",IMRPCTR=1 K IMRCTR
35 S IMR0C=IMR0C+1 S:'IMR2C IMR0C=6
36 D RAD^IMRUTL Q:'$D(^TMP($J,"RAE1",IMRDFN))
37 S IMRI="" F S IMRI=$O(^TMP($J,"RAE1",IMRDFN,IMRI)) Q:IMRI="" S IMRX=$G(^(IMRI)),IMRCPT=$P(IMRX,"^",10) D
38 .D CPTMOD
39 .S IMRPR=$E($P(IMRX,"^",1),1,30) Q:IMRPR=""
40 .S IMRRDT=9999999.9999-$P(IMRI,"-",1),IMRPN=IMRPR_"~"_IMRCPT
41 .S:'$D(^TMP($J,"IMRPT",IMR1C,IMRDFN)) ^(IMRDFN)=""
42 .S IMRCTR=$G(^TMP($J,"IMRPT",IMR1C,IMRDFN))
43 .I '$D(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN)) S ^(IMRPN)=0_"^"_IMRPCTR,$P(IMRCTR,"^",2)=$P(IMRCTR,"^",2)+1
44 .S IMRX1=$G(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN))
45 .S $P(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN),"^",1)=$P(IMRX1,"^",1)+1,$P(IMRCTR,"^",1)=$P(IMRCTR,"^",1)+1
46 .S $P(IMRCPR,"^",IMR0C)=$P(IMRCPR,"^",IMR0C)+1
47 .S ^TMP($J,"IMRPT",IMR1C,IMRDFN)=IMRCTR Q
48 S IMRPN="" F S IMRPN=$O(^TMP($J,"IMRT",IMR1C,IMRDFN,IMRPN)) Q:IMRPN="" S X=$G(^(IMRPN)) D
49 .I '$D(^TMP($J,"IMRPR",IMR1C,IMRPN)) S ^(IMRPN)=0,$P(IMRDPR,"^",IMR0C)=$P(IMRDPR,"^",IMR0C)+1
50 .S Y=$G(^TMP($J,"IMRPR",IMR1C,IMRPN))
51 .S $P(Y,"^",1)=$P(Y,"^",1)+X,$P(Y,"^",2)=$P(Y,"^",2)+$P(X,"^",2)
52 .S $P(IMRTTP,"^",IMR0C)=$P(IMRTTP,"^",IMR0C)+$P(X,"^",2)
53 .S ^TMP($J,"IMRPR",IMR1C,IMRPN)=Y
54 .Q
55 S $P(IMRPAT,"^",IMR0C)=$P(IMRPAT,"^",IMR0C)+1
56 K ^TMP($J,"IMRT"),^TMP($J,"RAE1")
57 Q
58CPTMOD 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
59 Q
60C2 ; Set tabulation in ^TMP for each category and All
61 I 'IMR2C S IMR1C="CT" D C3,C31,REMOV Q
62 F IMR0C=0:1:4 S IMR1C="C"_IMR0C D C3,C31
63REMOV K ^TMP($J,"IMRPR"),^TMP($J,"IMRPT")
64 Q
65C3 ; Set in ^TMP in order of total Procedures
66 S IMRPRN="" F S IMRPN=$O(^TMP($J,"IMRPR",IMR1C,IMRPN)) Q:IMRPN="" S X=$G(^(IMRPN)),^TMP($J,"IMRPRN",IMR1C,+X,IMRPN)=X
67 Q
68C31 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
69 Q
70ASKQ K DIR S DIR(0)="N^0:999999",DIR("A")="How many of the highest users do you want identified",DIR("B")=0
71 S DIR("?")="This determines the number of individuals with the highest utilization of procedures you wish listed" D ^DIR Q:$D(DIRUT)
72 S IMRRMAX=X K DIR
73 Q
Note: See TracBrowser for help on using the repository browser.