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

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1IMRLCNT ;HCIOFO/FT/FAI/SPS-LOCAL COUNT OF PTS, STATUS, OP VISITS, IP STAYS, ETC. ;07/23/01 07:28
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5,13**;Feb 09, 1998
3ASK ;[IMR IP/OP ACTIVITY LIST] - Inpatient and Outpatient Activity
4 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 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
8 S IMRRMAX=0
9 I $D(^XUSEC("IMRMGR",DUZ)) D ASKQ^IMRLCNT1 G:IMRUT KILL
10 S %ZIS="NQ",IMRUT=0 D IMRDEV^IMREDIT:$D(^XUSEC("IMRMGR",DUZ)),^%ZIS:'$D(^XUSEC("IMRMGR",DUZ)) G:POP KILL
11 I $D(IO("Q")) D G KILL
12 .S ZTRTN="DQ^IMRLCNT",ZTIO=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRSD")="",ZTSAVE("IMRED")="",ZTSAVE("IMRRMAX")="",ZTSAVE("IMR2C")="",ZTDESC="Selected IP/OP Activty"
13 .D ^%ZTLOAD
14 .K ZTRTN,ZTIO,ZTSAVE,ZTDESC,ZTSK
15 .D HOME^%ZIS
16 .D ^%ZISC
17 .Q
18DQ ;
19 U IO K ^TMP($J) S X1=IMRED,X2=1 D C^%DTC S IMREDP1=X
20 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
21 K VADM,VA
22 D ^IMRLCNT1,^IMRLCNT2
23 D ^%ZISC
24KILL 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
25 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
26 Q
27C1 S IMRSDV=0,IMRSDVA=1,DFN=IMRDFN D DEM^VADPT
28 S IMRDTH=$P($G(VADM(6)),"^",1)
29 I IMRDTH,IMRDTH<IMRSD Q ;quit if dead before start date of report
30 I +$$VERSION^XPDUTL("SD")>5.3 S IMRSDV=1 D ACRP G DGPT ;get data from File 409.68
31 I +$$PATCH^XPDUTL("SD*5.3*131")>0 S IMRSDV=1 D ACRP G DGPT ;get data from File 409.68
32 S VASD("F")=IMRSD,VASD("T")=IMREDP1 D SDA^VADPT K DFN,VASD
33 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
34 K ^UTILITY("VASD",$J)
35 S IMRSDV=1
36 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
37 .S J="" F S J=$O(IMRAR(409.51,J)) Q:J="" S IMRCS=$G(IMRAR(409.51,J,.01,"I")) D C2
38 .Q
39DGPT K IMRAR,IMRSDVI
40 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
41 .S IMRDD=$S(+IMRDD'>0:0,1:+IMRDD)
42 .Q:'IMRAD
43 .S IMRFLG=0
44 .I 'IMRDD D DBCHK(IMRDFN,IMRAD,.IMRDD,.IMRFLG)
45 .Q:IMRFLG
46 .I (IMRDD=0&(IMRAD'>IMRED))!((IMRDD'<IMRSD)&(IMRAD'>IMRED)) D C3
47 .Q
48 Q
49C2 ;
50 S:'IMRSDV IMRCS=+$$ARSC^IMRUTL(+IMRCS) ;get ptr value to File 40.7
51 S IMRCS=$S($D(^DIC(40.7,IMRCS,0)):$P(^(0),U,2),1:"NO SC ID")
52 S:IMRCS="" IMRCS=$P(^DIC(40.7,IMRCS,0),U)
53 I IMRCS="NO SC ID" S ^TMP($J,IMR1C,"NO SC",IMRDFN,IMRD,IMRSDV)=""
54 S ^("OP")=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,"OP")):^("OP"),1:0)+1,^(IMRCS)=$S($D(^("OP",IMRCS)):^(IMRCS),1:0)+1
55 S IMRDX=IMRD\1
56 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
57 Q
58C3 ;
59 I '$D(IMRSUF)!('$D(IMREC)) S IMRPTF=IMRI D PTF^IMRUTL
60 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
61 Q:+IMREC>1 ; IGNORE CENSUS PTF ENTRIES
62 S IMRAD1=IMRAD,IMRAD=$S(IMRAD'<IMRSD:IMRAD,1:IMRSD),IMRDD=$S(IMRDD=0:IMREDP1,(IMRDD\1)'>IMRED:IMRDD,1:IMREDP1)
63 S ^("IP")=$S($D(^TMP($J,IMR1C,"PAT",IMRDFN,"IP")):^("IP"),1:0)+1,X1=IMRDD\1,X2=IMRAD\1
64 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
65 S IMRD1=IMRAD\1,K=0 S IMRAD1=IMRAD1\1
66 S IMRPTF=IMRI D ICDM^IMRUTL,REORDER^IMRUTL K IMRAR
67 I $D(IMR4502) F K=IMRAD1:0 S K=$O(IMR4502(K)) Q:K'<IMRAD!(K="") S IMRAD1=K\1
68 S K=0,IMRROU="C4^IMRLCNT1"
69 F IMRJ=IMRD1:0 S IMRJ=$O(IMR4502(IMRJ)) Q:IMRJ'>0!(IMRJ'<(IMRDD\1)) D
70 .D C31,^%DTC S IMRDAYS=X
71 .S IMRBS=$P(IMR4502(IMRJ),U,1) ;treating specialty (external) File 45
72 .S IMRBSO=$$TREAT(IMRDFN) ;treating specialty (external) File 2
73 .S IMRBS=$S(IMRBS]"":IMRBS,1:IMRBSO)
74 .S:IMRBS="" IMRBS="NO ID"
75 .D @IMRROU S IMRD1=IMRJ\1
76 .Q
77 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
78 .S IMRBSO=$$TREAT(IMRDFN)
79 .S IMRBS=$S(IMRBS]"":IMRBS,1:IMRBSO)
80 .S:IMRBS="" IMRBS="NO ID"
81 .D C4^IMRLCNT1
82 .Q
83 K IMR4502,IMRFIRST
84 Q
85C31 S X1=IMRJ\1,X2=IMRD1
86 Q
87DBCHK(DFN,IMRAD,IMRDD,IMRFLG) ; Double Check if Admission date is valid and
88 ; if there is a discharge date or not. If
89 ; Admission date is not valid set IMRFLG=1
90 ; if Discharge date exist pass it back.
91 N IMRX
92 S VAINDT=IMRAD D ADM^VADPT2 K VAINDT I 'VADMVT K VADMVT S IMRFLG=1 Q
93 S IMRX=$$GET1^DIQ(405,VADMVT,.17,"I") K VADMVT Q:'IMRX
94 S IMRDD=$$GET1^DIQ(405,IMRX,.01,"I")
95 Q
96TREAT(DFN) ; Retrieve the patient's Treatment Specialty
97 S Y=$$GET1^DIQ(2,DFN,.103,"")
98 Q Y
99ACRP ; Ambulatory Care Reporting Changes
100 ; If site has SD*5.3*131 installed, then use the ACRP APIs to get
101 ; the stop code data.
102 N QUERY
103 D OPEN^SDQ(.QUERY)
104 D INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
105 D PAT^SDQ(.QUERY,IMRDFN,"SET")
106 D DATE^SDQ(.QUERY,IMRSD,IMREDP1,"SET")
107 D SCANCB^SDQ(.QUERY,"D SCAN^IMRLCNT(Y,Y0)","SET")
108 D ACTIVE^SDQ(.QUERY,"TRUE","SET")
109 D SCAN^SDQ(.QUERY,"FORWARD")
110 D CLOSE^SDQ(.QUERY)
111 Q
112SCAN(Y,Y0) ; Scan records returned by ACRP API
113 ; data comes from the Outpatient Encounter file (409.68)
114 S IMRD=+Y0 ;get visit/admit date/time
115 S IMRCS=$P(Y0,U,3) ;dds id, pointer to File 40.7 (Clinic Stop)
116 D C2
117 Q
Note: See TracBrowser for help on using the repository browser.