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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHDPL 3674 printed Dec 13, 2024@02:37:58 Page 2
CRHDPL ; CAIRO/MGH - Find personal lists for changeover list ;04-Mar-2008 16:00;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
DEFPAT(CRHDPATL,DUZ) ;Find the personal list for this person
+1 NEW VAIN,CRHDLIST,CRHDCT,CRHDPLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN
+2 NEW CRHDDOB,CRHDAGE,CRHDSEX,CRHDDSRC,CRHDJ,CRHDN,CRHDTLST
+3 SET CRHDCT=0
+4 ;get default patient list
+5 DO DEFSRC^ORQPTQ11(.CRHDDSRC)
+6 DO DEFLIST^ORQPTQ11(.CRHDLST)
+7 IF $GET(CRHDDSRC)["^Combination"
Begin DoDot:1
+8 KILL CRHDLST
+9 IF $DATA(^TMP("OR",$JOB,"PATIENTS"))
Begin DoDot:2
+10 SET CRHDN=0
+11 FOR
SET CRHDN=$ORDER(^TMP("OR",$JOB,"PATIENTS",CRHDN))
if 'CRHDN
QUIT
SET CRHDLST(CRHDN)=^TMP("OR",$JOB,"PATIENTS",CRHDN,0)
End DoDot:2
End DoDot:1
+12 IF $DATA(CRHDLST)
Begin DoDot:1
+13 SET CRHDJ=0
+14 FOR
SET CRHDJ=$ORDER(CRHDLST(CRHDJ))
if 'CRHDJ
QUIT
Begin DoDot:2
+15 SET CRHDDFN=+CRHDLST(CRHDJ)
+16 if 'CRHDDFN
QUIT
+17 DO PATDATA(CRHDDFN,.CRHDCT)
End DoDot:2
+18 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
+19 IF $GET(CRHDTLST)=""
DO DEFSRC^ORQPTQ11(.CRHDTLST)
End DoDot:1
QUIT
+20 QUIT
PERSLST(CRHDPATL,DUZ) ;
+1 ;If no patient list, get personal list
+2 DO PERSPR^ORQPTQ1(.CRHDLST)
+3 IF $PIECE($GET(CRHDLST(1)),U,1)
Begin DoDot:1
+4 SET CRHDL=0
FOR
SET CRHDL=$ORDER(CRHDLST(CRHDL))
if CRHDL=""
QUIT
Begin DoDot:2
+5 SET CRHDLIST=$PIECE(CRHDLST(CRHDL),U,1)
+6 DO GETPTS
End DoDot:2
End DoDot:1
+7 ;If no personal list, look for a default team list
+8 IF '$TEST
Begin DoDot:1
+9 KILL CRHDLST
+10 DO DEFTM^ORQPTQ1(.CRHDLST)
+11 IF '$PIECE($GET(CRHDLST),U,1)
SET CRHDPATL(1)=CRHDLST
QUIT
+12 SET CRHDLIST=$PIECE(CRHDLST,U,1)
+13 DO GETPTS
End DoDot:1
+14 QUIT
GETPTS ;subroutine to return patients on a list
+1 NEW J,VADM,VAIP
+2 SET J=0
+3 FOR
SET J=$ORDER(^OR(100.21,+CRHDLIST,10,J))
if J<1
QUIT
Begin DoDot:1
+4 SET CRHDORX=^(J,0)
SET CRHDDFN=$PIECE(CRHDORX,";")
+5 DO PATDATA(CRHDDFN,.CRHDCT)
End DoDot:1
+6 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
+7 QUIT
ALPHA(CRHDPATA,CRHDPATL,CRHDCT) ;
+1 NEW TXX
+2 SET TXX=""
+3 FOR
SET TXX=$ORDER(CRHDPATA(TXX))
if TXX=""
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDPATL(CRHDCT)=CRHDPATA(TXX)
+4 KILL CRHDPATA
+5 QUIT
PATDATA(CRHDDFN,CRHDCT) ;
+1 ;
+2 KILL VAIP,VADM,DFN
+3 SET DFN=CRHDDFN
+4 DO DEM^VADPT
DO IN5^VADPT
+5 ;Outpatients not valid for changeover list
+6 ;Q:VAIP(1)=""
+7 SET CRHDNAME=VADM(1)
SET CRHDSSN=$PIECE(VADM(2),U,1)
SET CRHDDOB=$PIECE(VADM(3),U,1)
+8 SET CRHDAGE=VADM(4)
SET CRHDSEX=$PIECE(VADM(5),U,1)
+9 ;S CRHDCT=CRHDCT+1
+10 ;S CRHDPATL(CRHDCT)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
+11 SET CRHDPATA(CRHDNAME)=CRHDDFN_U_CRHDNAME_U_CRHDSSN_U_CRHDDOB_U_CRHDAGE_U_CRHDSEX
+12 QUIT
SPECPTS(CRHDPATL,SPL) ;
+1 NEW VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
+2 SET CRHDCT=0
+3 DO SPECPTS^ORQPTQ2(.CRHDLST,.SPL)
+4 IF $PIECE($GET(CRHDLST(1)),U,1)
Begin DoDot:1
+5 SET CRHDL=0
FOR
SET CRHDL=$ORDER(CRHDLST(CRHDL))
if CRHDL=""
QUIT
Begin DoDot:2
+6 SET CRHDLIST=$PIECE(CRHDLST(CRHDL),U,1)
+7 DO PATDATA(CRHDLIST,.CRHDCT)
End DoDot:2
+8 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
End DoDot:1
+9 QUIT
TEAM(CRHDPATL,TEAM,FLAG) ;
+1 NEW VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
+2 SET CRHDCT=0
+3 DO TEAMPTS^ORQPTQ1(.CRHDLST,.TEAM,.FLAG)
+4 IF $PIECE($GET(CRHDLST(1)),U,1)
Begin DoDot:1
+5 SET CRHDL=0
FOR
SET CRHDL=$ORDER(CRHDLST(CRHDL))
if CRHDL=""
QUIT
Begin DoDot:2
+6 SET CRHDLIST=$PIECE(CRHDLST(CRHDL),U,1)
+7 DO PATDATA(CRHDLIST,.CRHDCT)
End DoDot:2
+8 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
End DoDot:1
+9 QUIT
PROV(CRHDPATL,PROV) ;
+1 NEW VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
+2 SET CRHDCT=0
+3 DO PROVPTS^ORQPTQ2(.CRHDLST,.PROV)
+4 IF $PIECE($GET(CRHDLST(1)),U,1)
Begin DoDot:1
+5 SET CRHDL=0
FOR
SET CRHDL=$ORDER(CRHDLST(CRHDL))
if CRHDL=""
QUIT
Begin DoDot:2
+6 SET CRHDLIST=$PIECE(CRHDLST(CRHDL),U,1)
+7 DO PATDATA(CRHDLIST,.CRHDCT)
End DoDot:2
+8 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
End DoDot:1
+9 QUIT
WARD(CRHDPATL,WARD) ;
+1 NEW VAIN,CRHDLIST,CRHDCT,CRHDLST,CRHDL,CRHDORX,CRHDDFN,CRHDNAME,CRHDSSN,CRHDDOB,CRHDAGE
+2 SET CRHDCT=0
+3 DO BYWARD^ORWPT(.CRHDLST,.WARD)
+4 IF $PIECE($GET(CRHDLST(1)),U,1)
Begin DoDot:1
+5 SET CRHDL=0
FOR
SET CRHDL=$ORDER(CRHDLST(CRHDL))
if CRHDL=""
QUIT
Begin DoDot:2
+6 SET CRHDLIST=$PIECE(CRHDLST(CRHDL),U,1)
+7 DO PATDATA(CRHDLIST,.CRHDCT)
End DoDot:2
+8 DO ALPHA(.CRHDPATA,.CRHDPATL,.CRHDCT)
End DoDot:1
+9 QUIT
