source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORX002.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1RORX002 ;HCIOFO/SG - CURRENT INPATIENT LIST ; 10/20/06 4:09pm
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #325 ADM^VADPT2 (controlled)
7 ; #10061 51^VADPT (supported)
8 ;
9 Q
10 ;
11 ;***** OUTPUTS THE REPORT HEADER
12 ;
13 ; PARTAG Reference (IEN) to the parent tag
14 ;
15 ; Return Values:
16 ; <0 Error code
17 ; 0 Ok
18 ;
19HEADER(PARTAG) ;
20 ;;PATIENTS(#,NAME,LAST4,WARD,ROOM-BED)
21 ;
22 N HEADER,RC
23 S HEADER=$$HEADER^RORXU002(.RORTSK,PARTAG)
24 Q:HEADER<0 HEADER
25 S RC=$$TBLDEF^RORXU002("HEADER^RORX002",HEADER)
26 Q $S(RC<0:RC,1:HEADER)
27 ;
28 ;***** COMPILES THE "CURRENT INPATIENT LIST"
29 ; REPORT CODE: 002
30 ;
31 ; .RORTSK Task number and task parameters
32 ;
33 ; Return Values:
34 ; <0 Error code
35 ; 0 Ok
36 ;
37INPTLST(RORTSK) ;
38 N RORPTN ; Number of patients in the registry
39 N RORREG ; Registry IEN
40 N RORTMP ; Closed root of the temporary buffer
41 ;
42 N BODY,ECNT,INPCNT,RC,REPORT,SFLAGS,TMP
43 ;--- Root node of the report
44 S REPORT=$$ADDVAL^RORTSK11(RORTSK,"REPORT")
45 Q:REPORT<0 REPORT
46 ;
47 ;--- Get and prepare the report parameters
48 S RORREG=$$PARAM^RORTSK01("REGIEN")
49 S RC=$$PARAMS^RORXU002(.RORTSK,REPORT,,,.SFLAGS) Q:RC<0 RC
50 ;
51 ;--- Initialize constants and variables
52 S ECNT=0
53 S RORPTN=$$REGSIZE^RORUTL02(+RORREG) S:RORPTN<0 RORPTN=0
54 ;
55 ;--- Report header
56 S RC=$$HEADER(REPORT) Q:RC<0 RC
57 S RORTMP=$$ALLOC^RORTMP()
58 D
59 . ;--- Query the registry
60 . D TPPSETUP^RORTSK01(50)
61 . S RC=$$QUERY(.INPCNT,SFLAGS)
62 . I RC Q:RC<0 S ECNT=ECNT+RC
63 . ;--- Generate the list of patients
64 . D TPPSETUP^RORTSK01(50)
65 . S RC=$$PTLIST(REPORT,INPCNT)
66 . I RC Q:RC<0 S ECNT=ECNT+RC
67 ;
68 ;--- Cleanup
69 D FREE^RORTMP(RORTMP)
70 Q $S(RC<0:RC,ECNT>0:-43,1:0)
71 ;
72 ;***** ADDS THE PATIENT DATA TO THE REPORT
73 ;
74 ; NODE Closed root of the patient's node in the buffer
75 ; PARTAG Reference (IEN) to the parent tag
76 ;
77 ; Return Values:
78 ; <0 Error code
79 ; 0 Ok
80 ;
81PATIENT(NODE,PARTAG) ;
82 N IEN,NAME,PATIEN,PTAG,PTBUF,RC,TMP
83 S PTBUF=@NODE,PATIEN=$P(PTBUF,U,2)
84 Q:PATIEN'>0 0
85 ;--- The <PATIENT> tag
86 S PTAG=$$ADDVAL^RORTSK11(RORTSK,"PATIENT",,PARTAG,,PATIEN)
87 ;--- Patient data
88 D ADDVAL^RORTSK11(RORTSK,"NAME",$QS(NODE,4),PTAG,1)
89 D ADDVAL^RORTSK11(RORTSK,"LAST4",$QS(NODE,5),PTAG,2)
90 S TMP=$$DATE^RORXU002($P(PTBUF,U,4)\1)
91 ;D ADDVAL^RORTSK11(RORTSK,"DOD",TMP,PTAG,1)
92 D ADDVAL^RORTSK11(RORTSK,"WARD",$QS(NODE,3),PTAG,1)
93 D ADDVAL^RORTSK11(RORTSK,"ROOM-BED",$P(PTBUF,U,3),PTAG,1)
94 Q 0
95 ;
96 ;***** GENERATES THE LIST OF PATIENTS
97 ;
98 ; REPORT IEN of the <REPORT> node
99 ; INPCNT Number of inpatients
100 ;
101 ; Return Values:
102 ; <0 Error code
103 ; 0 Ok
104 ; >0 Number of non-fatal errors
105 ;
106PTLIST(REPORT,INPCNT) ;
107 N BODY,CNT,ECNT,FLT,FLTLEN,NODE,RC,TCNT,TMP
108 S (CNT,ECNT,RC)=0
109 S BODY=$$ADDVAL^RORTSK11(RORTSK,"PATIENTS",,REPORT)
110 Q:BODY<0 BODY
111 D ADDATTR^RORTSK11(RORTSK,BODY,"TABLE","PATIENTS")
112 D:$D(@RORTMP)>1
113 . S NODE=RORTMP
114 . S FLTLEN=$L(NODE)-1,FLT=$E(NODE,1,FLTLEN)
115 . F S NODE=$Q(@NODE) Q:$E(NODE,1,FLTLEN)'=FLT D Q:RC<0
116 . . S TMP=$S(INPCNT>0:CNT/INPCNT,1:"")
117 . . S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
118 . . S CNT=CNT+1
119 . . I $$PATIENT(NODE,BODY)<0 S ECNT=ECNT+1 Q
120 Q $S(RC<0:RC,1:ECNT)
121 ;
122 ;***** QUERIES THE REGISTRY
123 ;
124 ; .INPCNT Number of inpatients is returned in this parameter
125 ; SFLAGS Flags for $$SKIP^RORXU005
126 ;
127 ; Return Values:
128 ; <0 Error code
129 ; 0 Ok
130 ; >0 Number of non-fatal errors
131 ;
132QUERY(INPCNT,SFLAGS) ;
133 N CNT,DFN,ECNT,IEN,IENS,RC,TCNT,TMP,VA,VADM,VAHOW,VAIP,VAROOT,XREFNODE,WARD
134 S XREFNODE=$NA(^RORDATA(798,"AC",+RORREG))
135 S (CNT,ECNT,INPCNT,RC)=0
136 ;--- Browse through the registry records
137 S IEN=0
138 F S IEN=$O(@XREFNODE@(IEN)) Q:IEN'>0 D Q:RC<0
139 . S TMP=$S(RORPTN>0:CNT/RORPTN,1:"")
140 . S RC=$$LOOP^RORTSK01(TMP) Q:RC<0
141 . S IENS=IEN_",",CNT=CNT+1
142 . ;--- Skip a patient
143 . Q:$$SKIP^RORXU005(IEN,SFLAGS)
144 . ;--- Process the registry record
145 . S DFN=$$PTIEN^RORUTL01(IEN) Q:DFN'>0
146 . K VA,VADM,VAIP S VAIP("D")=DT\1 D 51^VADPT
147 . S WARD=$P(VAIP(5),U,2) Q:WARD=""
148 . S TMP=$S($G(VA("BID"))'="":VA("BID"),1:"UNKN") ; Last 4 of SSN
149 . S @RORTMP@(WARD,VADM(1),TMP)=IEN_U_DFN_U_$P(VAIP(6),U,2)_U_$P(VADM(6),U)
150 . S INPCNT=INPCNT+1
151 ;---
152 Q $S(RC<0:RC,1:ECNT)
153 ;
154 ;***** CHECKS THE SUFFIX FOR VALIDITY
155 ;
156 ; SUFFIX Suffix
157 ;
158 ; Return Values:
159 ; 0 Ok
160 ; 1 Invalid suffix
161VSUFFIX(SUFFIX) ;
162 Q '("9AA,9AB,9BB,A0,A4,A5,BU,BV,PA"[SUFFIX)
Note: See TracBrowser for help on using the repository browser.