source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRLCNT.m

IMRLCNT ;HCIOFO/FT/FAI/SPS-LOCAL COUNT OF PTS, STATUS, OP VISITS, IP STAYS, ETC. ;07/23/01  07:28
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5,13**;Feb 09, 1998
ASK ;[IMR IP/OP ACTIVITY LIST] - Inpatient and Outpatient Activity
 D ^IMRDATE Q:$G(IMRHNBEG)=""
 S IMRSD=IMRHNBEG,IMRED=IMRHNEND
 I IMRED<IMRSD W !,$C(7),"END CAN NOT BE BEFORE START",! G ASK
 S DIR(0)="Y",DIR("A")="Print Data by CATEGORY as well as totals",DIR("B")="NO",DIR("?")="Answer YES to get separate listings of utilization by HIV CATEGORY as well as the total population." D ^DIR S IMR2C=Y
 S IMRRMAX=0
 I $D(^XUSEC("IMRMGR",DUZ)) D ASKQ^IMRLCNT1 G:IMRUT KILL
 S %ZIS="NQ",IMRUT=0 D IMRDEV^IMREDIT:$D(^XUSEC("IMRMGR",DUZ)),^%ZIS:'$D(^XUSEC("IMRMGR",DUZ)) G:POP KILL
 I $D(IO("Q")) D  G KILL
 .S ZTRTN="DQ^IMRLCNT",ZTIO=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRRMAX")="",ZTSAVE("IMR2C")="",ZTDESC="Selected IP/OP Activty"
 .D ^%ZTLOAD
 .K ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK
 .D HOME^%ZIS
 .D ^%ZISC
 .Q
DQ ;
 U IO K ^TMP($J) S X1=IMRED,X2=1 D C^%DTC S IMREDP1=X
 F IMRL=0:0 S IMRL=$O(^IMR(158,IMRL)) Q:IMRL'>0  S X=+^(IMRL,0),IMR1C=+$P(^(0),U,42) D XOR^IMRXOR S IMRDFN=X I $D(^DPT(IMRDFN,0)) S DFN=IMRDFN D NS^IMRCALL K DFN F IMR0C=IMR1C,"T" I IMR2C!(IMR0C="T") S IMR1C="C"_IMR0C D C1
 K VADM,VA
 D ^IMRLCNT1,^IMRLCNT2
 D ^%ZISC
KILL K IMRSD,IMRK,IMRED,IMREDP1,IMRX,IMRD,IMRAD,IMRDD,IMRBS,IMRCS,IMRCSN,IMRD1,IMRDAYS,IMRDFN,IMRI,IMRJ,IMRK,IMRN,IMRUT,IMRRMAX,IMR0C,IMR1C,IMR2C,IMRLBL,IMRAD1,IMRDX,IMRFLG,IMRL,IMRNAM,IMRSDV,IMRSDVA,IMRSSN,IMRZ,IMRDY
 K IMRFLG,IMRDTH,IMRBSO,%I,%T,I,J,K,K1,L,POP,V,X,X1,X2,Y,Z,Z1,DIR,^TMP($J),VAERR,D,IMRPG,DIRUT,DTOUT,DUOUT,DIROUT,IMRALOS,DISYS,IMRDISP,IMRDSP,IMRDTE,IMREC,IMRFB,IMROUT,IMRPTF,IMRST,IMRSUF
 Q
C1 S IMRSDV=0,IMRSDVA=1,DFN=IMRDFN D DEM^VADPT
 S IMRDTH=$P($G(VADM(6)),"^",1)
 I IMRDTH,IMRDTH<IMRSD Q  ;quit if dead before start date of report
 I +$$VERSION^XPDUTL("SD")>5.3 S IMRSDV=1 D ACRP G DGPT ;get data from File 409.68
 I +$$PATCH^XPDUTL("SD*5.3*131")>0 S IMRSDV=1 D ACRP G DGPT ;get data from File 409.68
 S VASD("F")=IMRSD,VASD("T")=IMREDP1 D SDA^VADPT K DFN,VASD
 F IMRDY=0:0 S IMRDY=$O(^UTILITY("VASD",$J,IMRDY)) Q:IMRDY'>0  S IMRD=+^(IMRDY,"I"),IMRCS=$P(^("I"),U,2) D C2
 K ^UTILITY("VASD",$J)
 S IMRSDV=1
 F IMRD=IMRSD-.0000001:0 S IMRD=$O(^SDV("C",IMRDFN,IMRD)) Q:IMRD'>0!(IMRD'<(IMREDP1))  S IMRSDVA=$S('$D(^TMP($J,IMR1C,"PAT",IMRDFN,"S",(IMRD\1))):1,1:0) S IMRSDVI=IMRD D SDVCS^IMRUTL I $D(IMRAR(409.51)) D
 .S J="" F  S J=$O(IMRAR(409.51,J)) Q:J=""  S IMRCS=$G(IMRAR(409.51,J,.01,"I")) D C2
 .Q
DGPT K IMRAR,IMRSDVI
 F IMRI=0:0 S IMRI=$O(^DGPT("B",IMRDFN,IMRI)) Q:IMRI'>0  I $D(^DGPT(IMRI,0)),+^(0)=IMRDFN S IMRPTF=IMRI D PTF^IMRUTL D
 .S IMRDD=$S(+IMRDD'>0:0,1:+IMRDD)
 .Q:'IMRAD
 .S IMRFLG=0
 .I 'IMRDD D DBCHK(IMRDFN,IMRAD,.IMRDD,.IMRFLG)
 .Q:IMRFLG
 .I (IMRDD=0&(IMRAD'>IMRED))!((IMRDD'<IMRSD)&(IMRAD'>IMRED)) D C3
 .Q
 Q
C2 ;
 S:'IMRSDV IMRCS=+$$ARSC^IMRUTL(+IMRCS) ;get ptr value to File 40.7
 S IMRCS=$S($D(^DIC(40.7,IMRCS,0)):$P(^(0),U,2),1:"NO SC ID")
 S:IMRCS="" IMRCS=$P(^DIC(40.7,IMRCS,0),U)
 I IMRCS="NO SC ID" S ^TMP($J,IMR1C,"NO SC",IMRDFN,IMRD,IMRSDV)=""
 S ^("OP")=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,"OP")):^("OP"),1:0)+1,^(IMRCS)=$S($D(^("OP",IMRCS)):^(IMRCS),1:0)+1
 S IMRDX=IMRD\1
 I '$D(^TMP($J,IMR1C,"PAT",IMRDFN,"S",IMRDX,IMRCS)) S ^(IMRCS)=$S(IMRSDV:"SDV",1:""),^(IMRDX)=$S(($D(^TMP($J,IMR1C,"PAT",IMRDFN,"S",IMRDX))#2):^(IMRDX),1:0)+1
 Q
C3 ;
 I '$D(IMRSUF)!('$D(IMREC)) S IMRPTF=IMRI D PTF^IMRUTL
 I IMRSUF'="",'(IMRSUF="9AA"!(IMRSUF="A0")!(IMRSUF="9AB")!(IMRSUF="9AD")!(IMRSUF="9AC")!(IMRSUF="9AE")!(IMRSUF="9BB")!(IMRSUF="A4")!(IMRSUF="A5")!(IMRSUF="BU")!(IMRSUF="BV")!(IMRSUF="PA")) Q
 Q:+IMREC>1  ; IGNORE CENSUS PTF ENTRIES
 S IMRAD1=IMRAD,IMRAD=$S(IMRAD'<IMRSD:IMRAD,1:IMRSD),IMRDD=$S(IMRDD=0:IMREDP1,(IMRDD\1)'>IMRED:IMRDD,1:IMREDP1)
 S ^("IP")=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,"IP")):^("IP"),1:0)+1,X1=IMRDD\1,X2=IMRAD\1
 D ^%DTC S:X=0 X=1 S IMRDAYS=X,^("DAYS")=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,"IP","DAYS")):^("DAYS"),1:0)+IMRDAYS,^(IMRDAYS)=$S($D(^(IMRDAYS)):^(IMRDAYS),1:0)+1
 S IMRD1=IMRAD\1,K=0 S IMRAD1=IMRAD1\1
 S IMRPTF=IMRI D ICDM^IMRUTL,REORDER^IMRUTL K IMRAR
 I $D(IMR4502) F K=IMRAD1:0 S K=$O(IMR4502(K)) Q:K'<IMRAD!(K="")  S IMRAD1=K\1
 S K=0,IMRROU="C4^IMRLCNT1"
 F IMRJ=IMRD1:0 S IMRJ=$O(IMR4502(IMRJ)) Q:IMRJ'>0!(IMRJ'<(IMRDD\1))  D
 .D C31,^%DTC S IMRDAYS=X
 .S IMRBS=$P(IMR4502(IMRJ),U,1) ;treating specialty (external) File 45
 .S IMRBSO=$$TREAT(IMRDFN) ;treating specialty (external) File 2
 .S IMRBS=$S(IMRBS]"":IMRBS,1:IMRBSO)
 .S:IMRBS="" IMRBS="NO ID"
 .D @IMRROU S IMRD1=IMRJ\1
 .Q
 K IMRROU S X2=IMRD1,X1=IMRDD\1 D ^%DTC S:X=0 X=1 S IMRDAYS=X,IMRBS=$S($D(IMRFIRST):$P(IMRFIRST,U,1),1:0) D
 .S IMRBSO=$$TREAT(IMRDFN)
 .S IMRBS=$S(IMRBS]"":IMRBS,1:IMRBSO)
 .S:IMRBS="" IMRBS="NO ID"
 .D C4^IMRLCNT1
 .Q
 K IMR4502,IMRFIRST
 Q
C31 S X1=IMRJ\1,X2=IMRD1
 Q
DBCHK(DFN,IMRAD,IMRDD,IMRFLG) ; Double Check if Admission date is valid and
 ;                         if there is a discharge date or not.  If
 ;                         Admission date is not valid set IMRFLG=1
 ;                         if Discharge date exist pass it back.
 N IMRX
 S VAINDT=IMRAD D ADM^VADPT2 K VAINDT I 'VADMVT K VADMVT S IMRFLG=1 Q
 S IMRX=$$GET1^DIQ(405,VADMVT,.17,"I") K VADMVT Q:'IMRX
 S IMRDD=$$GET1^DIQ(405,IMRX,.01,"I")
 Q
TREAT(DFN) ; Retrieve the patient's Treatment Specialty
 S Y=$$GET1^DIQ(2,DFN,.103,"")
 Q Y
ACRP ; Ambulatory Care Reporting Changes
 ; If site has SD*5.3*131 installed, then use the ACRP APIs to get
 ; the stop code data.
 N QUERY
 D OPEN^SDQ(.QUERY)
 D INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
 D PAT^SDQ(.QUERY,IMRDFN,"SET")
 D DATE^SDQ(.QUERY,IMRSD,IMREDP1,"SET")
 D SCANCB^SDQ(.QUERY,"D SCAN^IMRLCNT(Y,Y0)","SET")
 D ACTIVE^SDQ(.QUERY,"TRUE","SET")
 D SCAN^SDQ(.QUERY,"FORWARD")
 D CLOSE^SDQ(.QUERY)
 Q
SCAN(Y,Y0) ; Scan records returned by ACRP API
 ; data comes from the Outpatient Encounter file (409.68)
 S IMRD=+Y0 ;get visit/admit date/time
 S IMRCS=$P(Y0,U,3) ;dds id, pointer to File 40.7 (Clinic Stop)
 D C2
 Q