CRHD3 ; CAIRO/CLC - Modules to support CAIRO Hand-off Tool ;03-Apr-2008 11:22;CLC
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
GTEMPTXT(CRHDRTN,CRHDSTR) ;
D GETTEXT(.CRHDRTN,.CRHDSTR,1)
Q
GETTEXT(CRHDRTN,CRHDSTR,DIWF) ;
N CRHDFLD,CRHDUSER,CRHDDFN,CRHDVALS,CRHDTEAM,X,CRHDX1
N CRHDFLDN,CRHDTRG,CRHDTM,CRHDTSP,CRHDPN,CRHDFG,CRHDX
N CRHDLEN,CRHDCT,CRHDWLED,CRHDTMP,CRHDATTN,CRHDDIV,CRHDEX,CRHDZ0,DIWL,DIWR
N CRHDEXPD,CRHDFG2,CRHDLEDI,CRHDLL,CRHDLSTT,CRHDMN2,CRHDROOT,CRHDNAM
K CRHDRTN
S CRHDTRG="^CRHD(183.2)"
S CRHDFLD=$P(CRHDSTR,"^",1)
S:CRHDFLD'="" CRHDFLD=$$UP^XLFSTR(CRHDFLD)
S CRHDUSER=$P(CRHDSTR,"^",2)
S CRHDDFN=$P(CRHDSTR,"^",3)
S CRHDLEN=$P(CRHDSTR,"^",4)
I 'CRHDLEN S CRHDLEN=256
S CRHDDIV=$P(CRHDSTR,"^",5)
S DIWF=$S(+$G(DIWF):"NR",1:"R")
I CRHDDIV="" S CRHDDIV=+$$SITE^VASITE
S CRHDATTN=+$G(^DPT(+CRHDDFN,.1041))
Q:CRHDFLD=""
Q:'CRHDUSER
Q:'CRHDDFN
;get expiration date for temp fields
S CRHDEX=$$GET^XPAR("DIV.`"_CRHDDIV,"CRHD TEMP FLD EXPIRE",1,"I")
S CRHDFLDN=$O(@CRHDTRG@("B",CRHDFLD,0))
Q:'CRHDFLDN
S CRHDFG=$O(^CRHD(183.2,"C",+CRHDDFN,CRHDFLDN,0))
Q:'CRHDFG
;check expiration date here
S CRHDZ0=$G(@CRHDTRG@(CRHDFLDN,1,CRHDFG,0)),CRHDLEDI=$P(CRHDZ0,"^",5),CRHDWLED=$P(CRHDZ0,"^",4)
;S CRHDEX=7
I 'CRHDEX S CRHDEX=7 ;if parameter not set default to 7 days
I CRHDEX&(CRHDLEDI) S CRHDEXPD=$$FMADD^XLFDT(CRHDLEDI,CRHDEX)
I $G(CRHDEXPD) I $G(CRHDEXPD)<DT D DELTMPTX^CRHD7(CRHDFLDN,CRHDFG) Q
;
S CRHDROOT="^CRHD(183.2,"_CRHDFLDN_",1,"_CRHDFG_")"
S DIWL=1,DIWR=CRHDLEN K ^UTILITY($J,"W"),CRHDTMP
I DIWF="R" S CRHDCT=1 D B2
I DIWF="NR" D
.M CRHDTMP(CRHDFLDN)=@CRHDROOT@("TEXT")
S CRHDCT=2,CRHDX=0
S CRHDX=$O(CRHDTMP(CRHDX)) Q:'CRHDX S CRHDX1=0 F S CRHDX1=$O(CRHDTMP(CRHDX,CRHDX1)) Q:'CRHDX1 S CRHDRTN(CRHDX1+1)=CRHDTMP(CRHDX,CRHDX1,0)
S CRHDCT=99999,CRHDCT=$O(CRHDRTN(CRHDCT),-1)
S CRHDNAM=$$GET1^DIQ(200,+CRHDWLED,.01,"E")
S CRHDWLED=$$TITLE^XLFSTR($P(CRHDNAM,",",1))_","_$E($P(CRHDNAM,",",2),1)
S CRHDRTN(1)=CRHDCT_"^"_$$FMTE^XLFDT(CRHDLEDI,2)_"^"_CRHDWLED
Q
I DIWF="R" D
.S CRHDMN=0
.F S CRHDMN=$O(@CRHDROOT@("TEXT",CRHDMN)) Q:'CRHDMN S CRHDX=@CRHDROOT@("TEXT",CRHDMN,0) S:CRHDX="" CRHDX=" " D ^DIWP ;M TMP=^UTILITY($J,"W")
.M CRHDTMP=^UTILITY($J,"W") D ^DIWW K ^UTILITY($J,"W")
Q
B2 ;
S CRHDMN=0
F S CRHDMN=$O(@CRHDROOT@("TEXT",CRHDMN)) Q:'CRHDMN S CRHDX=@CRHDROOT@("TEXT",CRHDMN,0) D
.S CRHDFG2=0
.S CRHDMN2=CRHDMN F S CRHDMN2=$O(@CRHDROOT@("TEXT",CRHDMN2)) Q:'CRHDMN2!(CRHDFG2) D
..S CRHDX1=@CRHDROOT@("TEXT",CRHDMN2,0)
..I ($E(CRHDX1,1,3)?1N1". ")!($E(CRHDX1,1,3)?1N1") ")!($E(CRHDX1,1,4)?2N1". ")!($E(CRHDX1,1,4)?2N1") ") I CRHDX'="" D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDFG2=1,CRHDMN=CRHDMN2-1,CRHDX1="" Q
..E D
...I ($L(CRHDX)+$L(CRHDX1))>256 D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDLL=999,CRHDLL=$O(CRHDTMP(1,CRHDLL),-1) I $L(CRHDTMP(1,CRHDLL,0))<CRHDLEN S CRHDX=CRHDTMP(1,CRHDLL,0) K CRHDTMP(1,CRHDLL,0) S CRHDCT=CRHDCT-1
...S:CRHDX="" CRHDX=" " S CRHDX=CRHDX_CRHDX1 I ($E(CRHDX,$L(CRHDX)-2,$L(CRHDX))[".")!($E(CRHDX,$L(CRHDX)-2,$L(CRHDX))["?") D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDMN=CRHDMN2,CRHDFG2=1 S CRHDX=""
Q
DIWP(CRHDRN,CRHDSTR,CRHDL,CRHDN) ;
N CRHDX,CRHDFG
;CRHDRN : Array to return data
;CRHDSTR: String to manipulate
;CRHDL : Length to return
;CRHDN : Next number to use in array
I $L(CRHDSTR)<CRHDL S CRHDRN(1,CRHDN,0)=CRHDSTR,CRHDN=CRHDN+1 Q
F Q:'$L(CRHDSTR) D
.S CRHDFG=0
.S CRHDX=$E(CRHDSTR,1,CRHDL)
.I $L(CRHDX)<CRHDL S CRHDRN(1,CRHDN,0)=CRHDX,CRHDSTR="",CRHDN=CRHDN+1 Q
.F Q:CRHDFG S:$E(CRHDX,$L(CRHDX))=" "!($E(CRHDSTR,$L(CRHDX)+1)=" ") CRHDFG=1 S:'CRHDFG CRHDX=$E(CRHDX,1,$L(CRHDX)-1)
.S CRHDRN(1,CRHDN,0)=CRHDX,CRHDSTR=$E(CRHDSTR,$L(CRHDX)+1,$L(CRHDSTR)),CRHDN=CRHDN+1
Q
PRIV(CRHDUSR,CRHDFN,CRHDMN) ;returns 1 if note is private, viewable only to the author; 0 anyone on the authors team or treating specialty or attending can view
N CRHDPRIV
S CRHDPRIV=0
I CRHDUSR'=$P($G(@CRHDTRG@(CRHDFN,1,CRHDMN,0)),"^",2) D
. I +$P(@CRHDTRG@(CRHDFN,1,CRHDMN,0),"^",6) S CRHDPRIV=1
Q CRHDPRIV
GETPTLST(CRHDPATL,CRHDTML) ;
N CRHDSTG
S CRHDSTG="DFN^NAME^SSN^DOB^AGE^SEX"
I $G(CRHDTML)'="" D
.S CRHDLSTT=$$UP^XLFSTR($P(CRHDTML,"^",3))
.I CRHDLSTT="P"!(CRHDTML["^TEAM") D TEAM(+CRHDTML)
.I CRHDLSTT="TEAM" D TEAM(+CRHDTML)
.I CRHDLSTT="SPECIALTY" D SPECPTS(+CRHDTML)
.I CRHDLSTT="PATLIST"!(CRHDTML["PATLIST") D DEFPATL()
.I CRHDLSTT="WARD" D WARD(+CRHDTML)
.I CRHDLSTT="PROVIDER"!(CRHDTML["PROVIDER") D PROV(+CRHDTML)
I $G(CRHDTML)="" D DEFPATL()
Q
LISTINPT(Y,CRHDFRM,CRHDDIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
N CRHDI2,CRHDIEN,CRHDCNT,CRHDFROM,CRHDORID,CRHDPM
S CRHDCNT=44,CRHDI2=0,CRHDFROM=0
S CRHDPM=0
F S CRHDPM=$O(^DPT("ACA",CRHDPM)) Q:'CRHDPM S CRHDIEN=0 F S CRHDIEN=$O(^DPT("ACA",CRHDPM,CRHDIEN)) Q:'CRHDIEN S:$P($G(^DPT(+CRHDIEN,0)),"^",1)'="" ^TMP("CRHDACA",$J,$P(^DPT(+CRHDIEN,0),"^",1),CRHDIEN)=""
I $D(^TMP("CRHDACA",$J)) D
. I $P(CRHDFRM,U,2)'="" S CRHDFROM=$P(CRHDFRM,U,1),CRHDFRM=$O(^TMP("CRHDACA",$J,$P(CRHDFRM,U,2)),-CRHDDIR)
. F S CRHDFRM=$O(^TMP("CRHDACA",$J,CRHDFRM),CRHDDIR) Q:CRHDFRM="" D Q:CRHDI2=CRHDCNT
. . S CRHDIEN=CRHDFROM,CRHDFROM=0 F S CRHDIEN=$O(^TMP("CRHDACA",$J,CRHDFRM,CRHDIEN)) Q:'CRHDIEN D Q:CRHDI2=CRHDCNT
. . . S CRHDORID=""
. . . S CRHDORID=$G(^DPT(CRHDIEN,0)) ; Get zero node name.
. . . ; S CRHDX1=$G(^DPT(CRHDIEN,.1))_" "_$G(^DPT(CRHDIEN,.101))
. . . S CRHDI2=CRHDI2+1 S Y(CRHDI2)=CRHDIEN_U_CRHDFRM_U_U_U_U_$P(CRHDORID,U) ;_"^"_CRHDX ; _"^"_CRHDX1 ;" ("_X_")"
Q
ISINPT(CRHDDFN) ;is patient an inpatient
Q:'CRHDDFN ""
Q +$G(^DPT(+CRHDDFN,.105))
;
PERLIST(DUZ) ;
K CRHDPATL
D PERSLST^CRHDPL(.CRHDPATL,DUZ) ;get personal lists
Q
DEFPATL() ;
K CRHDPATL
D DEFPAT^CRHDPL(.CRHDPATL,DUZ) ;get default patient list
Q
TEAM(CRHDTM) ;
K CRHDPATL
D TEAM^CRHDPL(.CRHDPATL,.CRHDTM,0) ;get patient list
Q
SPECPTS(CRHDSPEC) ;
K CRHDPATL
D SPECPTS^CRHDPL(.CRHDPATL,CRHDSPEC) ;get specialty list
Q
WARD(CRHDWRD) ;
K CRHDPATL
D WARD^CRHDPL(.CRHDPATL,.CRHDWRD) ;get ward list
Q
PROV(CRHDPRV) ;
K CRHDPATL
D PROV^CRHDPL(.CRHDPATL,.CRHDPRV) ;get provider list
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD3 6327 printed Oct 16, 2024@18:38:24 Page 2
CRHD3 ; CAIRO/CLC - Modules to support CAIRO Hand-off Tool ;03-Apr-2008 11:22;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
GTEMPTXT(CRHDRTN,CRHDSTR) ;
+1 DO GETTEXT(.CRHDRTN,.CRHDSTR,1)
+2 QUIT
GETTEXT(CRHDRTN,CRHDSTR,DIWF) ;
+1 NEW CRHDFLD,CRHDUSER,CRHDDFN,CRHDVALS,CRHDTEAM,X,CRHDX1
+2 NEW CRHDFLDN,CRHDTRG,CRHDTM,CRHDTSP,CRHDPN,CRHDFG,CRHDX
+3 NEW CRHDLEN,CRHDCT,CRHDWLED,CRHDTMP,CRHDATTN,CRHDDIV,CRHDEX,CRHDZ0,DIWL,DIWR
+4 NEW CRHDEXPD,CRHDFG2,CRHDLEDI,CRHDLL,CRHDLSTT,CRHDMN2,CRHDROOT,CRHDNAM
+5 KILL CRHDRTN
+6 SET CRHDTRG="^CRHD(183.2)"
+7 SET CRHDFLD=$PIECE(CRHDSTR,"^",1)
+8 if CRHDFLD'=""
SET CRHDFLD=$$UP^XLFSTR(CRHDFLD)
+9 SET CRHDUSER=$PIECE(CRHDSTR,"^",2)
+10 SET CRHDDFN=$PIECE(CRHDSTR,"^",3)
+11 SET CRHDLEN=$PIECE(CRHDSTR,"^",4)
+12 IF 'CRHDLEN
SET CRHDLEN=256
+13 SET CRHDDIV=$PIECE(CRHDSTR,"^",5)
+14 SET DIWF=$SELECT(+$GET(DIWF):"NR",1:"R")
+15 IF CRHDDIV=""
SET CRHDDIV=+$$SITE^VASITE
+16 SET CRHDATTN=+$GET(^DPT(+CRHDDFN,.1041))
+17 if CRHDFLD=""
QUIT
+18 if 'CRHDUSER
QUIT
+19 if 'CRHDDFN
QUIT
+20 ;get expiration date for temp fields
+21 SET CRHDEX=$$GET^XPAR("DIV.`"_CRHDDIV,"CRHD TEMP FLD EXPIRE",1,"I")
+22 SET CRHDFLDN=$ORDER(@CRHDTRG@("B",CRHDFLD,0))
+23 if 'CRHDFLDN
QUIT
+24 SET CRHDFG=$ORDER(^CRHD(183.2,"C",+CRHDDFN,CRHDFLDN,0))
+25 if 'CRHDFG
QUIT
+26 ;check expiration date here
+27 SET CRHDZ0=$GET(@CRHDTRG@(CRHDFLDN,1,CRHDFG,0))
SET CRHDLEDI=$PIECE(CRHDZ0,"^",5)
SET CRHDWLED=$PIECE(CRHDZ0,"^",4)
+28 ;S CRHDEX=7
+29 ;if parameter not set default to 7 days
IF 'CRHDEX
SET CRHDEX=7
+30 IF CRHDEX&(CRHDLEDI)
SET CRHDEXPD=$$FMADD^XLFDT(CRHDLEDI,CRHDEX)
+31 IF $GET(CRHDEXPD)
IF $GET(CRHDEXPD)<DT
DO DELTMPTX^CRHD7(CRHDFLDN,CRHDFG)
QUIT
+32 ;
+33 SET CRHDROOT="^CRHD(183.2,"_CRHDFLDN_",1,"_CRHDFG_")"
+34 SET DIWL=1
SET DIWR=CRHDLEN
KILL ^UTILITY($JOB,"W"),CRHDTMP
+35 IF DIWF="R"
SET CRHDCT=1
DO B2
+36 IF DIWF="NR"
Begin DoDot:1
+37 MERGE CRHDTMP(CRHDFLDN)=@CRHDROOT@("TEXT")
End DoDot:1
+38 SET CRHDCT=2
SET CRHDX=0
+39 SET CRHDX=$ORDER(CRHDTMP(CRHDX))
if 'CRHDX
QUIT
SET CRHDX1=0
FOR
SET CRHDX1=$ORDER(CRHDTMP(CRHDX,CRHDX1))
if 'CRHDX1
QUIT
SET CRHDRTN(CRHDX1+1)=CRHDTMP(CRHDX,CRHDX1,0)
+40 SET CRHDCT=99999
SET CRHDCT=$ORDER(CRHDRTN(CRHDCT),-1)
+41 SET CRHDNAM=$$GET1^DIQ(200,+CRHDWLED,.01,"E")
+42 SET CRHDWLED=$$TITLE^XLFSTR($PIECE(CRHDNAM,",",1))_","_$EXTRACT($PIECE(CRHDNAM,",",2),1)
+43 SET CRHDRTN(1)=CRHDCT_"^"_$$FMTE^XLFDT(CRHDLEDI,2)_"^"_CRHDWLED
+44 QUIT
+45 IF DIWF="R"
Begin DoDot:1
+46 SET CRHDMN=0
+47 ;M TMP=^UTILITY($J,"W")
FOR
SET CRHDMN=$ORDER(@CRHDROOT@("TEXT",CRHDMN))
if 'CRHDMN
QUIT
SET CRHDX=@CRHDROOT@("TEXT",CRHDMN,0)
if CRHDX=""
SET CRHDX=" "
DO ^DIWP
+48 MERGE CRHDTMP=^UTILITY($JOB,"W")
DO ^DIWW
KILL ^UTILITY($JOB,"W")
End DoDot:1
+49 QUIT
B2 ;
+1 SET CRHDMN=0
+2 FOR
SET CRHDMN=$ORDER(@CRHDROOT@("TEXT",CRHDMN))
if 'CRHDMN
QUIT
SET CRHDX=@CRHDROOT@("TEXT",CRHDMN,0)
Begin DoDot:1
+3 SET CRHDFG2=0
+4 SET CRHDMN2=CRHDMN
FOR
SET CRHDMN2=$ORDER(@CRHDROOT@("TEXT",CRHDMN2))
if 'CRHDMN2!(CRHDFG2)
QUIT
Begin DoDot:2
+5 SET CRHDX1=@CRHDROOT@("TEXT",CRHDMN2,0)
+6 IF ($EXTRACT(CRHDX1,1,3)?1N1". ")!($EXTRACT(CRHDX1,1,3)?1N1") ")!($EXTRACT(CRHDX1,1,4)?2N1". ")!($EXTRACT(CRHDX1,1,4)?2N1") ")
IF CRHDX'=""
DO DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT)
SET CRHDFG2=1
SET CRHDMN=CRHDMN2-1
SET CRHDX1=""
QUIT
+7 IF '$TEST
Begin DoDot:3
+8 IF ($LENGTH(CRHDX)+$LENGTH(CRHDX1))>256
DO DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT)
SET CRHDLL=999
SET CRHDLL=$ORDER(CRHDTMP(1,CRHDLL),-1)
IF $LENGTH(CRHDTMP(1,CRHDLL,0))<CRHDLEN
SET CRHDX=CRHDTMP(1,CRHDLL,0)
KILL CRHDTMP(1,CRHDLL,0)
SET CRHDCT=CRHDCT-1
+9 if CRHDX=""
SET CRHDX=" "
SET CRHDX=CRHDX_CRHDX1
IF ($EXTRACT(CRHDX,$LENGTH(CRHDX)-2,$LENGTH(CRHDX))[".")!($EXTRACT(CRHDX,$LENGTH(CRHDX)-2,$LENGTH(CRHDX))["?")
DO DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT)
SET CRHDMN=CRHDMN2
SET CRHDFG2=1
SET CRHDX=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
DIWP(CRHDRN,CRHDSTR,CRHDL,CRHDN) ;
+1 NEW CRHDX,CRHDFG
+2 ;CRHDRN : Array to return data
+3 ;CRHDSTR: String to manipulate
+4 ;CRHDL : Length to return
+5 ;CRHDN : Next number to use in array
+6 IF $LENGTH(CRHDSTR)<CRHDL
SET CRHDRN(1,CRHDN,0)=CRHDSTR
SET CRHDN=CRHDN+1
QUIT
+7 FOR
if '$LENGTH(CRHDSTR)
QUIT
Begin DoDot:1
+8 SET CRHDFG=0
+9 SET CRHDX=$EXTRACT(CRHDSTR,1,CRHDL)
+10 IF $LENGTH(CRHDX)<CRHDL
SET CRHDRN(1,CRHDN,0)=CRHDX
SET CRHDSTR=""
SET CRHDN=CRHDN+1
QUIT
+11 FOR
if CRHDFG
QUIT
if $EXTRACT(CRHDX,$LENGTH(CRHDX))=" "!($EXTRACT(CRHDSTR,$LENGTH(CRHDX)+1)=" ")
SET CRHDFG=1
if 'CRHDFG
SET CRHDX=$EXTRACT(CRHDX,1,$LENGTH(CRHDX)-1)
+12 SET CRHDRN(1,CRHDN,0)=CRHDX
SET CRHDSTR=$EXTRACT(CRHDSTR,$LENGTH(CRHDX)+1,$LENGTH(CRHDSTR))
SET CRHDN=CRHDN+1
End DoDot:1
+13 QUIT
PRIV(CRHDUSR,CRHDFN,CRHDMN) ;returns 1 if note is private, viewable only to the author; 0 anyone on the authors team or treating specialty or attending can view
+1 NEW CRHDPRIV
+2 SET CRHDPRIV=0
+3 IF CRHDUSR'=$PIECE($GET(@CRHDTRG@(CRHDFN,1,CRHDMN,0)),"^",2)
Begin DoDot:1
+4 IF +$PIECE(@CRHDTRG@(CRHDFN,1,CRHDMN,0),"^",6)
SET CRHDPRIV=1
End DoDot:1
+5 QUIT CRHDPRIV
GETPTLST(CRHDPATL,CRHDTML) ;
+1 NEW CRHDSTG
+2 SET CRHDSTG="DFN^NAME^SSN^DOB^AGE^SEX"
+3 IF $GET(CRHDTML)'=""
Begin DoDot:1
+4 SET CRHDLSTT=$$UP^XLFSTR($PIECE(CRHDTML,"^",3))
+5 IF CRHDLSTT="P"!(CRHDTML["^TEAM")
DO TEAM(+CRHDTML)
+6 IF CRHDLSTT="TEAM"
DO TEAM(+CRHDTML)
+7 IF CRHDLSTT="SPECIALTY"
DO SPECPTS(+CRHDTML)
+8 IF CRHDLSTT="PATLIST"!(CRHDTML["PATLIST")
DO DEFPATL()
+9 IF CRHDLSTT="WARD"
DO WARD(+CRHDTML)
+10 IF CRHDLSTT="PROVIDER"!(CRHDTML["PROVIDER")
DO PROV(+CRHDTML)
End DoDot:1
+11 IF $GET(CRHDTML)=""
DO DEFPATL()
+12 QUIT
LISTINPT(Y,CRHDFRM,CRHDDIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
+1 NEW CRHDI2,CRHDIEN,CRHDCNT,CRHDFROM,CRHDORID,CRHDPM
+2 SET CRHDCNT=44
SET CRHDI2=0
SET CRHDFROM=0
+3 SET CRHDPM=0
+4 FOR
SET CRHDPM=$ORDER(^DPT("ACA",CRHDPM))
if 'CRHDPM
QUIT
SET CRHDIEN=0
FOR
SET CRHDIEN=$ORDER(^DPT("ACA",CRHDPM,CRHDIEN))
if 'CRHDIEN
QUIT
if $PIECE($GET(^DPT(+CRHDIEN,0)),"^",1)'=""
SET ^TMP("CRHDACA",$JOB,$PIECE(^DPT(+CRHDIEN,0),"^",1),CRHDIEN)=""
+5 IF $DATA(^TMP("CRHDACA",$JOB))
Begin DoDot:1
+6 IF $PIECE(CRHDFRM,U,2)'=""
SET CRHDFROM=$PIECE(CRHDFRM,U,1)
SET CRHDFRM=$ORDER(^TMP("CRHDACA",$JOB,$PIECE(CRHDFRM,U,2)),-CRHDDIR)
+7 FOR
SET CRHDFRM=$ORDER(^TMP("CRHDACA",$JOB,CRHDFRM),CRHDDIR)
if CRHDFRM=""
QUIT
Begin DoDot:2
+8 SET CRHDIEN=CRHDFROM
SET CRHDFROM=0
FOR
SET CRHDIEN=$ORDER(^TMP("CRHDACA",$JOB,CRHDFRM,CRHDIEN))
if 'CRHDIEN
QUIT
Begin DoDot:3
+9 SET CRHDORID=""
+10 ; Get zero node name.
SET CRHDORID=$GET(^DPT(CRHDIEN,0))
+11 ; S CRHDX1=$G(^DPT(CRHDIEN,.1))_" "_$G(^DPT(CRHDIEN,.101))
+12 ;_"^"_CRHDX ; _"^"_CRHDX1 ;" ("_X_")"
SET CRHDI2=CRHDI2+1
SET Y(CRHDI2)=CRHDIEN_U_CRHDFRM_U_U_U_U_$PIECE(CRHDORID,U)
End DoDot:3
if CRHDI2=CRHDCNT
QUIT
End DoDot:2
if CRHDI2=CRHDCNT
QUIT
End DoDot:1
+13 QUIT
ISINPT(CRHDDFN) ;is patient an inpatient
+1 if 'CRHDDFN
QUIT ""
+2 QUIT +$GET(^DPT(+CRHDDFN,.105))
+3 ;
PERLIST(DUZ) ;
+1 KILL CRHDPATL
+2 ;get personal lists
DO PERSLST^CRHDPL(.CRHDPATL,DUZ)
+3 QUIT
DEFPATL() ;
+1 KILL CRHDPATL
+2 ;get default patient list
DO DEFPAT^CRHDPL(.CRHDPATL,DUZ)
+3 QUIT
TEAM(CRHDTM) ;
+1 KILL CRHDPATL
+2 ;get patient list
DO TEAM^CRHDPL(.CRHDPATL,.CRHDTM,0)
+3 QUIT
SPECPTS(CRHDSPEC) ;
+1 KILL CRHDPATL
+2 ;get specialty list
DO SPECPTS^CRHDPL(.CRHDPATL,CRHDSPEC)
+3 QUIT
WARD(CRHDWRD) ;
+1 KILL CRHDPATL
+2 ;get ward list
DO WARD^CRHDPL(.CRHDPATL,.CRHDWRD)
+3 QUIT
PROV(CRHDPRV) ;
+1 KILL CRHDPATL
+2 ;get provider list
DO PROV^CRHDPL(.CRHDPATL,.CRHDPRV)
+3 QUIT
