source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORX005A.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1RORX005A ;HCIOFO/BH,SG - INPATIENT UTILIZATION (QUERY) ; 3/13/06 9:25am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #92 Read access to the file #45 (controlled)
7 ; #557 Read access to the file #40.7 (controlled)
8 ; #2438 .01 field and "C" x-ref of file #40.8 (controlled)
9 ; #10035 Read access to the file #2 (supported)
10 ;
11 Q
12 ;
13 ;***** ADDS THE INPATIENT STAY
14 ;
15 ; DFN Patient IEN (in file #2)
16 ; PTFIEN IEN of the PTF record
17 ; LOS Length of stay
18 ; BSID Bed section ID
19 ; DATE Movement date/time (FileMan)
20 ;
21ADDSTAY(DFN,PTFIEN,LOS,BSID,DATE) ;
22 N DST,I,TMP
23 S:$G(BSID)="" BSID=0
24 ;--- Number of patients for the bedsection
25 I 'BSID S DST=$NA(@RORDST@("IP",DFN))
26 E S DST=$NA(@RORDST@("IPB",BSID)) D:'$D(@DST@("P",DFN))
27 . S @DST@("P")=$G(@DST@("P"))+1,@DST@("P",DFN)=""
28 ;--- No bed section ID
29 S:BSID<0 @RORDST@("IPNOBS",RORPNAME,DATE,PTFIEN,DFN)=""
30 ;--- Short stays (visits)
31 I LOS'>0 S @DST@("V")=$G(@DST@("V"))+1 Q
32 ;--- Days and stays
33 S @DST@("D")=$G(@DST@("D"))+LOS
34 S @DST@("S")=$G(@DST@("S"))+1
35 ;--- Lengths of stay for median value calculations
36 S I=$O(@RORDST@("IPMLOS",BSID,LOS,""),-1)+1
37 S @RORDST@("IPMLOS",BSID,LOS,I)=""
38 Q
39 ;
40 ;***** LOADS AND PROCESSES THE INPATIENT DATA
41 ;
42 ; DFN Patient IEN (in file #2)
43 ;
44 ; Return Values:
45 ; <0 Error code
46 ; 0 Ok
47 ; >0 Number of non-fatal errors
48 ;
49IPDATA(DFN) ;
50 N RORDST ; Closed reference to the category node in ^TMP
51 ;
52 N BSID,DATE,DISDT,ENDT,FACILITY,LOS,PTFIEN,RC,RORMSG,STDT,SUFFIX,TMP,VAHOW,VAIP,VAROOT,XDATE
53 S RORDST=$NA(^TMP("RORX005",$J))
54 ;---
55 S XDATE=RORSDT
56 F S RC=0 D Q:RC<2 S XDATE=$O(^DGPT("AAD",DFN,XDATE)) Q:XDATE'>0
57 . I XDATE'<ROREDT1 S RC=1 Q
58 . K DATE,LOS,VAIP S VAIP(16,1)=XDATE
59 . F D Q:RC
60 . . S VAIP("D")=+$G(VAIP(16,1))
61 . . I VAIP("D")'>0 S RC=2 Q
62 . . D IN5^VADPT
63 . . I $G(VAIP(1))'>0 S RC=2 Q
64 . . S DATE=+VAIP(3)
65 . . Q:+$G(VAIP(4))=3
66 . . ;--- Check the movement date
67 . . I DATE'<ROREDT1 S RC=1 Q
68 . . S:DATE<RORSDT DATE=RORSDT
69 . . ;--- Check the PTF record
70 . . S PTFIEN=+$G(VAIP(12)) Q:PTFIEN'>0
71 . . I '$D(PTFIEN(PTFIEN)) D Q:RC
72 . . . S PTFIEN(PTFIEN)=0
73 . . . Q:$$PTF^RORXU001(PTFIEN,"FP",,,.SUFFIX,,.FACILITY)
74 . . . ;--- Check the suffix
75 . . . ;I SUFFIX'="" Q:$$VSUFFIX(SUFFIX) ; ROR 1.5
76 . . . ;--- Check the division
77 . . . S TMP=$$PARAM^RORTSK01("DIVISIONS","ALL")
78 . . . I 'TMP D Q:'$D(RORTSK("PARAMS","DIVISIONS","C",DIVIEN))
79 . . . . S TMP=FACILITY_SUFFIX
80 . . . . S DIVIEN=$S(TMP'="":+$O(^DG(40.8,"C",TMP,"")),1:0)
81 . . . S PTFIEN(PTFIEN)=1
82 . . ;--- Skip the PTF record if necessary
83 . . Q:'PTFIEN(PTFIEN)
84 . . ;--- Process the admission (only once)
85 . . I '$D(LOS) D Q:RC
86 . . . S LOS=$$LOS(+$G(VAIP(13,1)),+$G(VAIP(17,1)))
87 . . . D ADDSTAY(DFN,PTFIEN,LOS)
88 . . ;--- Process the movement
89 . . S ENDT=$G(VAIP(16,1))\1
90 . . S:(ENDT'>0)!(ENDT'<ROREDT1) ENDT=ROREDT,RC=2
91 . . Q:ENDT<RORSDT
92 . . S LOS=$$FMDIFF^XLFDT(ENDT,DATE\1,1) S:LOS'>0 LOS=0
93 . . ;--- Use the IEN in the SPECIALTY file (#42.4) as the Bedsection
94 . . ; ID if it is available (it should be). Otherwise, use the
95 . . ;--- IEN in the FACILITY TREATING SPECIALTY file (#45.7).
96 . . I $G(VAIP(8))>0 D
97 . . . S TMP=$$GET1^DIQ(45.7,+VAIP(8),1,"I",,"RORMSG")
98 . . . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,DFN,45.7,+VAIP(8))
99 . . . S BSID=$S(TMP>0:TMP_";42.4",1:+VAIP(8)_";45.7")
100 . . E S BSID=-1
101 . . D ADDSTAY(DFN,PTFIEN,LOS,BSID,+VAIP(3))
102 . S:$G(DATE)>XDATE XDATE=DATE
103 ;---
104 Q $S(RC<0:RC,1:0)
105 ;
106 ;***** CALCULATES THE LENGTH OF STAY
107LOS(STDT,ENDT) ;
108 N DAYS
109 S:STDT<RORSDT STDT=RORSDT
110 S:(ENDT'>0)!(ENDT>ROREDT) ENDT=ROREDT
111 S DAYS=$$FMDIFF^XLFDT(ENDT\1,STDT\1,1)
112 Q $S(DAYS'<0:DAYS,1:0)
113 ;
114 ;***** QUERIES THE REGISTRY
115 ;
116 ; FLAGS Flags for the $$SKIP^RORXU005
117 ;
118 ; Return Values:
119 ; <0 Error code
120 ; 0 Ok
121 ; >0 Number of non-fatal errors
122 ;
123QUERY(FLAGS) ;
124 N ROREDT1 ; Day after the end date
125 N RORLAST4 ; Last 4 digits of the current patient's SSN
126 N RORPNAME ; Name of the current patient
127 N RORPTN ; Number of patients in the registry
128 ;
129 N CNT,ECNT,IEN,IENS,PATIEN,RC,TMP,VA,VADM,XREFNODE
130 S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
131 S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
132 S ROREDT1=$$FMADD^XLFDT(ROREDT,1)
133 S (CNT,ECNT,RC)=0
134 ;--- Browse through the registry records
135 S IEN=0
136 F S IEN=$O(@XREFNODE@(IEN)) Q:IEN'>0 D Q:RC<0
137 . S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
138 . S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
139 . S IENS=IEN_",",CNT=CNT+1
140 . ;--- Check if the patient should be skipped
141 . Q:$$SKIP^RORXU005(IEN,FLAGS,RORSDT,ROREDT)
142 . ;
143 . ;--- Get the patient IEN (DFN)
144 . S PATIEN=$$PTIEN^RORUTL01(IEN) Q:PATIEN'>0
145 . ;
146 . ;--- Get the patient's data
147 . D VADEM^RORUTL05(PATIEN,1)
148 . S RORPNAME=VADM(1),RORLAST4=VA("BID")
149 . ;
150 . ;--- Get the inpatient data
151 . S RC=$$IPDATA(PATIEN)
152 . I RC S ECNT=ECNT+1 Q:RC<0
153 . ;
154 . ;--- Calculate intermediate totals
155 . S RC=$$TOTALS^RORX005B(PATIEN)
156 . I RC S ECNT=ECNT+1 Q:RC<0
157 ;---
158 Q $S(RC<0:RC,1:ECNT)
159 ;
160 ;***** CHECKS THE SUFFIX FOR VALIDITY
161 ;
162 ; SUFFIX Suffix
163 ;
164 ; Return Values:
165 ; 0 Ok
166 ; 1 Invalid suffix
167VSUFFIX(SUFFIX) ;
168 Q '("9AA,9AB,9AC,9AD,9AE,9BB,A0,A4,A5,BU,BV,PA"[SUFFIX)
Note: See TracBrowser for help on using the repository browser.