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

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