IMRLCAT ;ISC-FAI/SF/JLI,HCIOFO/FT-PATIENT DEMOGRAPHICS BY CATEGORY ;06/19/00 14:54
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
 ;[IMR CATEGORY BREAKDOWN] - Local ICR Demographics by Category
 W !,?10,"####################################################"
 W !,?10,"#",?20,"Local ICR Demographics by Category",?61,"#"
 W !,?10,"####################################################"
 D ^IMRDATE
 Q:'$D(IMRHNEND)
 Q:'$D(IMRHNBEG)
MISCAT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to check for entries in the ICR file without CATEGORY data" D ^DIR K DIR Q:$D(DIRUT)  S IMRMC=Y
 I $G(IMRMC)=1 S IMRMC=0 ;initialize flag for missing category from Nat'l Registry D CHKCAT^IMRLCAT1
 S IMREXC=0
 W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want a list of patients with MISSING data elements" D ^DIR K DIR Q:$D(DIRUT)  S IMRTEST=Y
 S X=$$RX1589^IMRUTL() ;get pharmacy archive date from File 158.9
 D LRARC^IMRUTL ;check Lab archive date
DEV D IMRDEV^IMREDIT
 G:POP KILL
 I '$D(IO("Q")) W @IOF D DQ K ^TMP($J) Q
 I $D(IO("Q")) D  G KILL
 .S ZTRTN="DQ^IMRLCAT",ZTDESC="Local ICR Demographics By Category"
 .S ZTSAVE("*")="",ZTIO=ION_";"_IOM_";"_IOSL
 .D ^%ZTLOAD K ZTRTN,ZTDESC,ZTSAVE,ZTSK
 .Q
DQ ; Print Patients By Category
 U IO K ^TMP($J),IMRLAB,IMRINP,IMRSCH,IMRCHK,IMRRX S IMRMC=1
 S IMRHED="Patients Seen During "_IMRHRANG_"   FOR "_$S(IMREXC="A":"LIVING ",IMREXC="B":"ALIVE & DECEASED ",IMREXC="D":"DECEASED ",1:"")_"PATIENTS IN THE FILE"
 F IMRI=0:0 K VA,VADM,VAEL S IMRI=$O(^IMR(158,IMRI)) Q:IMRI'>0  S X=$P(^(IMRI,0),U) D XOR^IMRXOR I $D(^DPT(X,0)) S (DFN,IMRDFN)=X D 2^VADPT S IMRDOD=$P(VADM(6),U) D  S:IMRDOD>0 $P(^IMR(158,IMRI,1),U,34)=2 D A1^IMRLCAT2
 . S:IMRDOD'>0 IMRDOD=$S($D(^IMR(158,IMRI,5)):+$P(^(5),U,19),1:0)
 . Q
 D PRNT^IMRLCAT1
CLOSE D ^%ZISC K %ZIS,IOP
 S:$D(ZTQUEUED) ZTREQ="@"
KILL D ^%ZISC K IMREXC,IMRPER,IMRED,IMRSD,IMRDFN,IMRDD,IMRAD,IMRAGE,IMRCHK,IMRD,IMRD0,IMRDDA,IMRDOB,IMREL,IMRI,IMRJ,IMRLOC,IMRLR,IMRINP,IMRLAB,IMRPOS,IMRSEX,IMRTY,IMRHED
 K IMRRXN,IMRDT,IMRDTE,IMRPG,IMRREC,IMRRAC,DTOUT,VAROOT,VAERR,A,DIRUT,I,J,POP,X,X0,X1,Y,Z,D,DFN,IMRUT,IMRX,IMRX1,XC0,IMRYES,IMRDL,IMRTEST,IMRMC,IMRNODE,^TMP($J)
 K %I,DISYS,IMRDISP,IMRDSP,IMREC,IMRFB,IMRFLG,IMRLRC,IMRMCAT,IMROUT,IMRPTF,IMRRISK,IMRSSN,IMRST,IMRSUF,IMRY,XC1,XC102,XC110,XC2,Y1,Y2,Y3,Y4,IMRDOD
 D HOME^%ZIS
 Q