IMRSUDRA ;HCIOFO/NCA/FAI-Print Radiology Utility Report ;7/17/97  09:39
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
DQ ; Process Radiology Report
 K ^TMP($J) S (IMRPG,IMRUT)=0
 S (IMRPAT,IMRCPR,IMRDPR,IMRTTP)=""
 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 Q
 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)) D
 .S IMRPR=$E($P(IMRX,"^",1),1,30),IMRCPT=$P(IMRX,"^",10) 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
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