source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHDPL.m@ 1726

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