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