- 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 Feb 19, 2025@00:04:26 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