source: WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHDPL.m@ 1524

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1CRHDPL ; CAIRO/MGH - Find personal lists for changeover list ;04-Mar-2008 16:00;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4DEFPAT(CRHDPATL,DUZ) ;Find the personal list for this person
5 N VAIN,CRHDLIST,CRHDCT,CRHDPLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN
6 N CRHDDOB,CRHDAGE,CRHDSEX,CRHDDSRC,CRHDJ,CRHDN,CRHDTLST
7 S CRHDCT=0
8 ;get default patient list
9 D DEFSRC^ORQPTQ11(.CRHDDSRC)
10 D DEFLIST^ORQPTQ11(.CRHDLST)
11 I $G(CRHDDSRC)["^Combination" D
12 .K CRHDLST
13 .I $D(^TMP("OR",$J,"PATIENTS")) D
14 ..S CRHDN=0
15 ..F S CRHDN=$O(^TMP("OR",$J,"PATIENTS",CRHDN)) Q:'CRHDN S CRHDLST(CRHDN)=^TMP("OR",$J,"PATIENTS",CRHDN,0)
16 I $D(CRHDLST) D Q
17 .S CRHDJ=0
18 .F S CRHDJ=$O(CRHDLST(CRHDJ)) Q:'CRHDJ D
19 ..S CRHDDFN=+CRHDLST(CRHDJ)
20 ..Q:'CRHDDFN
21 ..D PATDATA(CRHDDFN,.CRHDCT)
22 .D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
23 .I $G(CRHDTLST)="" D DEFSRC^ORQPTQ11(.CRHDTLST)
24 Q
25PERSLST(CRHDPATL,DUZ) ;
26 ;If no patient list, get personal list
27 D PERSPR^ORQPTQ1(.CRHDLST)
28 I $P($G(CRHDLST(1)),U,1) D
29 .S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
30 ..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
31 ..D GETPTS
32 ;If no personal list, look for a default team list
33 E D
34 .K CRHDLST
35 .D DEFTM^ORQPTQ1(.CRHDLST)
36 .I '$P($G(CRHDLST),U,1) S CRHDPATL(1)=CRHDLST Q
37 .S CRHDLIST=$P(CRHDLST,U,1)
38 .D GETPTS
39 Q
40GETPTS ;subroutine to return patients on a list
41 N J,VADM,VAIP
42 S J=0
43 F S J=$O(^OR(100.21,+CRHDLIST,10,J)) Q:J<1 D
44 .S CRHDORX=^(J,0),CRHDDFN=$P(CRHDORX,";")
45 .D PATDATA(CRHDDFN,.CRHDCT)
46 D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
47 Q
48ALPHA(CRHDPATA,CRHDPATL,CRHDCT) ;
49 N TXX
50 S TXX=""
51 F S TXX=$O(CRHDPATA(TXX)) Q:TXX="" S CRHDCT=CRHDCT+1,CRHDPATL(CRHDCT)=CRHDPATA(TXX)
52 K CRHDPATA
53 Q
54PATDATA(CRHDDFN,CRHDCT) ;
55 ;
56 K VAIP,VADM,DFN
57 S DFN=CRHDDFN
58 D DEM^VADPT,IN5^VADPT
59 ;Outpatients not valid for changeover list
60 ;Q:VAIP(1)=""
61 S CRHDNAME=VADM(1),CRHDSSN=$P(VADM(2),U,1),CRHDDOB=$P(VADM(3),U,1)
62 S CRHDAGE=VADM(4),CRHDSEX=$P(VADM(5),U,1)
63 ;S CRHDCT=CRHDCT+1
64 ;S CRHDPATL(CRHDCT)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
65 S CRHDPATA(CRHDNAME)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
66 Q
67SPECPTS(CRHDPATL,SPL) ;
68 N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
69 S CRHDCT=0
70 D SPECPTS^ORQPTQ2(.CRHDLST,.SPL)
71 I $P($G(CRHDLST(1)),U,1) D
72 .S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
73 ..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
74 ..D PATDATA(CRHDLIST,.CRHDCT)
75 .D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
76 Q
77TEAM(CRHDPATL,TEAM,FLAG) ;
78 N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
79 S CRHDCT=0
80 D TEAMPTS^ORQPTQ1(.CRHDLST,.TEAM,.FLAG)
81 I $P($G(CRHDLST(1)),U,1) D
82 .S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
83 ..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
84 ..D PATDATA(CRHDLIST,.CRHDCT)
85 .D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
86 Q
87PROV(CRHDPATL,PROV) ;
88 N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
89 S CRHDCT=0
90 D PROVPTS^ORQPTQ2(.CRHDLST,.PROV)
91 I $P($G(CRHDLST(1)),U,1) D
92 .S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
93 ..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
94 ..D PATDATA(CRHDLIST,.CRHDCT)
95 .D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
96 Q
97WARD(CRHDPATL,WARD) ;
98 N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
99 S CRHDCT=0
100 D BYWARD^ORWPT(.CRHDLST,.WARD)
101 I $P($G(CRHDLST(1)),U,1) D
102 .S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
103 ..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
104 ..D PATDATA(CRHDLIST,.CRHDCT)
105 .D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
106 Q
Note: See TracBrowser for help on using the repository browser.