107 lines
3.5 KiB
Mathematica
107 lines
3.5 KiB
Mathematica
CRHDPL ; CAIRO/MGH - Find personal lists for changeover list ;04-Mar-2008 16:00;CLC
|
|
;;1.0;CRHD;****;Jan 28, 2008;Build 19
|
|
;=================================================================
|
|
DEFPAT(CRHDPATL,DUZ) ;Find the personal list for this person
|
|
N VAIN,CRHDLIST,CRHDCT,CRHDPLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN
|
|
N CRHDDOB,CRHDAGE,CRHDSEX,CRHDDSRC,CRHDJ,CRHDN,CRHDTLST
|
|
S CRHDCT=0
|
|
;get default patient list
|
|
D DEFSRC^ORQPTQ11(.CRHDDSRC)
|
|
D DEFLIST^ORQPTQ11(.CRHDLST)
|
|
I $G(CRHDDSRC)["^Combination" D
|
|
.K CRHDLST
|
|
.I $D(^TMP("OR",$J,"PATIENTS")) D
|
|
..S CRHDN=0
|
|
..F S CRHDN=$O(^TMP("OR",$J,"PATIENTS",CRHDN)) Q:'CRHDN S CRHDLST(CRHDN)=^TMP("OR",$J,"PATIENTS",CRHDN,0)
|
|
I $D(CRHDLST) D Q
|
|
.S CRHDJ=0
|
|
.F S CRHDJ=$O(CRHDLST(CRHDJ)) Q:'CRHDJ D
|
|
..S CRHDDFN=+CRHDLST(CRHDJ)
|
|
..Q:'CRHDDFN
|
|
..D PATDATA(CRHDDFN,.CRHDCT)
|
|
.D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
.I $G(CRHDTLST)="" D DEFSRC^ORQPTQ11(.CRHDTLST)
|
|
Q
|
|
PERSLST(CRHDPATL,DUZ) ;
|
|
;If no patient list, get personal list
|
|
D PERSPR^ORQPTQ1(.CRHDLST)
|
|
I $P($G(CRHDLST(1)),U,1) D
|
|
.S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
|
|
..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
|
|
..D GETPTS
|
|
;If no personal list, look for a default team list
|
|
E D
|
|
.K CRHDLST
|
|
.D DEFTM^ORQPTQ1(.CRHDLST)
|
|
.I '$P($G(CRHDLST),U,1) S CRHDPATL(1)=CRHDLST Q
|
|
.S CRHDLIST=$P(CRHDLST,U,1)
|
|
.D GETPTS
|
|
Q
|
|
GETPTS ;subroutine to return patients on a list
|
|
N J,VADM,VAIP
|
|
S J=0
|
|
F S J=$O(^OR(100.21,+CRHDLIST,10,J)) Q:J<1 D
|
|
.S CRHDORX=^(J,0),CRHDDFN=$P(CRHDORX,";")
|
|
.D PATDATA(CRHDDFN,.CRHDCT)
|
|
D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
Q
|
|
ALPHA(CRHDPATA,CRHDPATL,CRHDCT) ;
|
|
N TXX
|
|
S TXX=""
|
|
F S TXX=$O(CRHDPATA(TXX)) Q:TXX="" S CRHDCT=CRHDCT+1,CRHDPATL(CRHDCT)=CRHDPATA(TXX)
|
|
K CRHDPATA
|
|
Q
|
|
PATDATA(CRHDDFN,CRHDCT) ;
|
|
;
|
|
K VAIP,VADM,DFN
|
|
S DFN=CRHDDFN
|
|
D DEM^VADPT,IN5^VADPT
|
|
;Outpatients not valid for changeover list
|
|
;Q:VAIP(1)=""
|
|
S CRHDNAME=VADM(1),CRHDSSN=$P(VADM(2),U,1),CRHDDOB=$P(VADM(3),U,1)
|
|
S CRHDAGE=VADM(4),CRHDSEX=$P(VADM(5),U,1)
|
|
;S CRHDCT=CRHDCT+1
|
|
;S CRHDPATL(CRHDCT)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
|
|
S CRHDPATA(CRHDNAME)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
|
|
Q
|
|
SPECPTS(CRHDPATL,SPL) ;
|
|
N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
|
|
S CRHDCT=0
|
|
D SPECPTS^ORQPTQ2(.CRHDLST,.SPL)
|
|
I $P($G(CRHDLST(1)),U,1) D
|
|
.S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
|
|
..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
|
|
..D PATDATA(CRHDLIST,.CRHDCT)
|
|
.D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
Q
|
|
TEAM(CRHDPATL,TEAM,FLAG) ;
|
|
N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
|
|
S CRHDCT=0
|
|
D TEAMPTS^ORQPTQ1(.CRHDLST,.TEAM,.FLAG)
|
|
I $P($G(CRHDLST(1)),U,1) D
|
|
.S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
|
|
..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
|
|
..D PATDATA(CRHDLIST,.CRHDCT)
|
|
.D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
Q
|
|
PROV(CRHDPATL,PROV) ;
|
|
N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
|
|
S CRHDCT=0
|
|
D PROVPTS^ORQPTQ2(.CRHDLST,.PROV)
|
|
I $P($G(CRHDLST(1)),U,1) D
|
|
.S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
|
|
..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
|
|
..D PATDATA(CRHDLIST,.CRHDCT)
|
|
.D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
Q
|
|
WARD(CRHDPATL,WARD) ;
|
|
N VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
|
|
S CRHDCT=0
|
|
D BYWARD^ORWPT(.CRHDLST,.WARD)
|
|
I $P($G(CRHDLST(1)),U,1) D
|
|
.S CRHDL=0 F S CRHDL=$O(CRHDLST(CRHDL)) Q:CRHDL="" D
|
|
..S CRHDLIST=$P(CRHDLST(CRHDL),U,1)
|
|
..D PATDATA(CRHDLIST,.CRHDCT)
|
|
.D ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
|
|
Q
|