CRHDUT ; CAIRO/CLC - GET THE PATIENT DATA ELEMENTS FOR HANDOFF LIST ;5/13/08 05:19
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
ALG(CRHDRTN0,CRHDSTR) ; Allergies
N CRHDTNUM
S CRHDTRG="CRHDRTN0"
S DFN=+CRHDSTR
S CRHDNUM=$P(CRHDSTR,U,2)
S CRHDHDR=$P(CRHDSTR,U,3)
K @CRHDTRG,CRHDRTN
N CRHDX
S CRHDNUM=CRHDNUM+1,CRHDTNUM=CRHDNUM
S CRHDNUM=$G(CRHDNUM)+1
S:$G(CRHDHDR) @CRHDTRG@(CRHDNUM)="Allergies: "
D LIST^ORQQAL(.CRHDRTN,DFN)
S CRHDX=0
F S CRHDX=$O(CRHDRTN(CRHDX)) Q:'CRHDX D
.S @CRHDTRG@(CRHDNUM)=$G(@CRHDTRG@(CRHDNUM))_$$SPACE($G(@CRHDTRG@(CRHDNUM)),$S($G(CRHDHDR):12,1:1))_$P(CRHDRTN(CRHDX),"^",2)
. S CRHDNUM=CRHDNUM+1
S @CRHDTRG@(CRHDTNUM)=CRHDNUM-1
Q
ACTMED(CRHDRTN,CRHDSTR) ;Active Medications
;CRHDRTN: Target array
;CRHDCAT: I-Inpatient Meds
; O-Outpatient Meds
; B-Both
;CRHDIV: 0 - Do not include IV
; 1 - include IV
;CRHDNUM: next number in results array
;CRHDHDR: include section heading
;CRHDDET: details, 1-include the sig, 0-exclude sig
;CRHDLEN: length to return in chars. Defaults to 16 chars.
N CRHDUD,CRHDV,CRHDX2,CRHDC,CRHDMEDS,CRHDRN,DFN,CRHDCAT,CRHDI,CRHDN,CRHDP1,CRHDP2
N CRHDIV,CRHDNUM,CRHDHDR,CRHDDET,CRHDFG,CRHDLEN,CRHDTNUM,CRHDMCTR,CRHDTX
S DFN=+CRHDSTR
S CRHDCAT=$P(CRHDSTR,U,2)
I CRHDCAT="" S CRHDCAT="I"
S CRHDIV=$P(CRHDSTR,U,3)
S CRHDNUM=$P(CRHDSTR,U,4)
S CRHDHDR=$P(CRHDSTR,U,5)
S CRHDDET=$P(CRHDSTR,U,6)
S CRHDLEN=$P(CRHDSTR,U,7)
I 'CRHDLEN S CRHDLEN=16
S CRHDTRG="CRHDRTN"
K @CRHDTRG
S CRHDMCTR=0
S CRHDNUM=CRHDNUM+1,CRHDTNUM=CRHDNUM
S CRHDNUM=$G(CRHDNUM)+1
S:$G(CRHDHDR) @CRHDTRG@(CRHDNUM)="Meds: "
I CRHDCAT="O"!('CRHDDET) D NODETAM^CRHD2(.CRHDMEDS,DFN,CRHDCAT),NDOUT S @CRHDTRG@(CRHDTNUM)=CRHDNUM-1 Q
I CRHDDET S CRHDX=$$PSGI^CRHDAM(.CRHDMEDS,DFN) D DOUT
S @CRHDTRG@(CRHDTNUM)=CRHDNUM-1
Q
NDOUT ;no details output
S CRHDP2=" S CRHDN="""""_" F S CRHDN=$O(CRHDMEDS(CRHDI,CRHDN)) Q:'CRHDN D AOUTPUT"
I CRHDCAT="I" D
.S CRHDP1="F CRHDI=""U"""
.I CRHDIV S CRHDP1=CRHDP1_","_"""V"""
I CRHDCAT="O" D
.S CRHDP1="F CRHDI=""N"""_","_"""R"""
S CRHDP1=CRHDP1_CRHDP2
X CRHDP1
Q
AOUTPUT ;
S CRHDNUM=CRHDNUM+1
;I HDR S @TRG@(CRHDNUM)="Medications",NUM=NUM+1,HDR=0
;S @CRHDTRG@(CRHDNUM)=$E($G(CRHDMEDS(CRHDI,CRHDN)),1,CRHDLEN)
S CRHDMCTR=CRHDMCTR+1,@CRHDTRG@(CRHDNUM)=CRHDMCTR_"."_$E($G(CRHDMEDS(CRHDI,CRHDN)),1,CRHDLEN)
Q
DOUT ;
S (CRHDX2,CRHDFG,CRHDMCTR)=0
F S CRHDX2=$O(CRHDMEDS(CRHDX2)) Q:'CRHDX2!(CRHDFG) D
.S CRHDTX=""
.S CRHDC=$P(CRHDMEDS(CRHDX2),"^",2)
.Q:CRHDC=""
.I CRHDHDR S CRHDNUM=CRHDNUM+1,@CRHDTRG@(CRHDNUM)="Inpatient Meds: ",CRHDNUM=CRHDNUM+1,CRHDHDR=0
IV .I 'CRHDIV&(CRHDC["IV DOSE") S CRHDFG=1 Q
.I CRHDDET D
..I (CRHDC["=UNIT DOSE=")!(CRHDC["=IV DOSE=") S @CRHDTRG@(CRHDNUM)=$E(CRHDC,1,CRHDLEN)
..E S CRHDMCTR=CRHDMCTR+1,@CRHDTRG@(CRHDNUM)=CRHDMCTR_"."_$E(CRHDC,1,CRHDLEN)
.I 'CRHDDET S @CRHDTRG@(CRHDNUM)=$E(CRHDC,1,CRHDLEN)
.S CRHDNUM=CRHDNUM+1
Q
CONSULT(CRHDRTN,CRHDSTR) ;consults orders - call from cprs
;DFN,FILTERS,GROUPS,DTFROM,DTTHRU,EVENT
N CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE,CRHDGRP
N CRHDLEN,CHRDHDR,CRHDSTS,CRHDILST,DFN
S DFN=+CRHDSTR
S CRHDSTS=$P(CRHDSTR,U,2)
S CRHDNUM=$P(CRHDSTR,U,3)
S CRHDHDR=$P(CRHDSTR,U,4)
S CRHDLEN=$P(CRHDSTR,U,5)
I 'CRHDLEN S CRHDLEN=20
S CRHDTRG="CRHDRTN"
K @CRHDTRG
S CRHDGRP=$O(^ORD(100.98,"B","CONSULTS",0))
;D AGET^ORWORR(.CRHDY,DFN,"2^0",11,0,0,"")
D AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
M CRHDILST=@CRHDY
K CRHDILST(.1)
D DETORD("CRHDRTN",.CRHDLST,.CRHDILST,"",CRHDLEN)
Q
IMAGING(CRHDRTN,CRHDSTR) ;Radiology orders - call from cprs
;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
N CRHDY,CRHDILST,ORYD,CRHDLST,X,CRHDLEN
N D1,CRHDATE,DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDTRG,CRHDGRP
S DFN=+CRHDSTR
S CRHDSTS=$P(CRHDSTR,U,2)
S CRHDNUM=$P(CRHDSTR,U,3)
S CRHDHDR=$P(CRHDSTR,U,4)
S CRHDLEN=$P(CRHDSTR,U,5)
I 'CRHDLEN S CRHDLEN=20
S CRHDTRG="CRHDRTN"
K @CRHDTRG
S CRHDGRP=$O(^ORD(100.98,"B","IMAGING",0))
;D AGET^ORWORR(.CRHDY,DFN,"2^0",34,0,0,"")
D AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
M CRHDILST=@CRHDY
K CRHDILST(.1)
D DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
Q
LABS(CRHDRTN,CRHDSTR) ;LABS orders - call from cprs
;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
N CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE
N DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDLEN,CRHDTRG
S DFN=+CRHDSTR
S CRHDSTS=$P(CRHDSTR,U,2)
S CRHDNUM=$P(CRHDSTR,U,3)
S CRHDHDR=$P(CRHDSTR,U,4)
S CRHDLEN=$P(CRHDSTR,U,5)
I 'CRHDLEN S CRHDLEN=20
S CRHDTRG="CRHDRTN"
K @CRHDTRG
S CRHDGRP=$O(^ORD(100.98,"B","LABORATORY",0))
;D AGET^ORWORR(.CRHDY,DFN,"2^0",5,0,0,"")
D AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
M CRHDILST=@CRHDY
K CRHDILST(.1)
D DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
Q
PROC(CRHDRTN,CRHDSTR) ;,DFN,CRHDSTS,CRHDNUM,CRHDHDR) ;Procedures orders - call from cprs
;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
N CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE
N DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDGRP,CRHDLEN,CRHDTRG
S DFN=+CRHDSTR
S CRHDSTS=$P(CRHDSTR,U,2)
S CRHDNUM=$P(CRHDSTR,U,3)
S CRHDHDR=$P(CRHDSTR,U,4)
S CRHDLEN=$P(CRHDSTR,U,5)
I 'CRHDLEN S CRHDLEN=20
S CRHDTRG="CRHDRTN"
K @CRHDTRG
S CRHDGRP=$O(^ORD(100.98,"B","PROCEDURES",0))
;D AGET^ORWORR(.CRHDY,DFN,"2^0",43,0,0,"")
D AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
M CRHDILST=@CRHDY
K CRHDILST(.1)
D DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
Q
DETORD(CRHDTRG,CRHDRLST,CRHDILST,CRHDHEAD,CRHDLEN) ;
N ORYD,CRHDSTS,CRHDD1,CRHDATE,CRHDX
S ORYD=""
D GET4LST^ORWORR(.CRHDRLST,.CRHDILST)
S:$G(CRHDHDR) @CRHDTRG@(CRHDNUM,0)=CRHDHEAD_": "
S CRHDX=""
F S CRHDX=$O(CRHDLST(CRHDX)) Q:'CRHDX D
. S CRHDD1=$P(CRHDLST(CRHDX),"^",3)
. I $E(CRHDLST(CRHDX),1)="~" D
. .S CRHDD1=$P(CRHDLST(CRHDX),"^",3)
. .S CRHDSTS=$P(CRHDLST(CRHDX),"^",10)
. .S CRHDATE=$$FMTE^XLFDT(CRHDD1,2)
. .S @CRHDTRG@(CRHDNUM)=$G(@CRHDTRG@(CRHDNUM))_$$SPACE($G(@CRHDTRG@(CRHDNUM)),$S($G(CRHDHDR):16,1:1))_$P(CRHDATE,"@",1)
. I $E(CRHDLST(CRHDX),1)="t" D
. .S @CRHDTRG@(CRHDNUM)=$G(@CRHDTRG@(CRHDNUM))_$$SPACE($G(@CRHDTRG@(CRHDNUM)),$S($G(CRHDHDR):16,1:1))_" "_$E(CRHDLST(CRHDX),2,$L(CRHDLST(CRHDX)))_" ("_$P($G(^ORD(100.01,+CRHDSTS,0)),"^",1)_")"
. .S @CRHDTRG@(CRHDNUM)=$E(@CRHDTRG@(CRHDNUM),1,CRHDLEN),CRHDNUM=CRHDNUM+1
Q
PROB(CRHDRTNA,CRHDSTR) ;DFN,NUM,CRHDHDR) ;
;Target array ^TMP("CRHD_PROB_DATA",$J)
N CRHDRTN,X,DFN,CRHDNUM,CRHDHDR,CRHDTRG
S DFN=+CRHDSTR
S CRHDNUM=$P(CRHDSTR,U,2)
S CRHDHDR=$P(CRHDSTR,U,3)
S CRHDTRG="^TMP(""CRHD_PROB_DATA"",$J)"
K @CRHDTRG
S CRHDNUM=$G(CRHDNUM)+1
S:$G(CRHDHDR) @CRHDTRG@(CRHDNUM,0)="Problem List: "
D LIST^ORQQPL(.CRHDRTN,DFN,"A")
S CRHDX=0
F S CRHDX=$O(CRHDRTN(CRHDX)) Q:'CRHDX D
. S @CRHDTRG@(CRHDNUM)=$G(@CRHDTRG@(CRHDNUM))_$$SPACE($G(@CRHDTRG@(CRHDNUM)),$S($G(CRHDHDR):15,1:1))_$P(CRHDRTN(X),"^",2)
. S CRHDNUM=CRHDNUM+1
;S @CRHDTRG@(CRHDNUM)=""
Q
RECNTLAB(CRHDROOT,DFN,CRHDNUM,CRHDHDR) ;
;(CRHDY,DFN,CRHDATE1,DIR,FORMAT)
D INTERIMG^ORWLRR(.CRHDY,DFN,$$DT^XLFDT_".2359",1,"")
Q
SPACE(CRHDX1,CRHDX) ;
N CRHDY,CRHDY1
S CRHDY1="",CRHDY=CRHDX-$L(CRHDX1)
S $P(CRHDY1," ",CRHDY)=""
Q CRHDY1
PARAM(CRHDW,CRHDX) ;
Q $$GET^XPAR(CRHDW,CRHDX,1,"I")
;
PTSTS(DFN) ;Display current patient status
N CRHDGPMV,NOW,NOWI,X,Y,%,%H,%I,CRHDA,E,CRHDDGX,VAIP,VAX,VAZ,VAZ2
D NOW^%DTC S (VAX("DAT"),NOW)=%,NOWI=9999999.999999-%
D LAST^VADPT3
S CRHDGPMV(1)=$S($D(VAIP("E")):VAIP("E"),1:E) ;use ifn of last mvt from VADPT cal
S CRHDDGX=$G(^DGPM(+CRHDGPMV(1),0)),CRHDGPMV(2)=$P(CRHDDGX,"^",2),CRHDGPMV(4)=$P(CRHDDGX,"^",18)
S CRHDA=$S("^3^5^"[("^"_+CRHDGPMV(2)_"^"):0,1:+CRHDGPMV(2))
Q $S('CRHDA:"IN",1:"")_"ACTIVE "_$S("^4^5^"[("^"_+CRHDGPMV(2)_"^"):"LODGER",1:"INPATIENT")
DNRPARM(CRHDNRTT,DUZ,CRHDDIV) ;GET DNR TITLES
N CRHDPAR,CRHDSRV,CRHDTEAM
S CRHDTEAM=$$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")
S CRHDSRV=$$GET1^DIQ(200,DUZ_",",29,"E")
S CRHDPAR="USR.`"_DUZ
D GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
I ('CRHDNRTT)&($G(CRHDTEAM)>0) S CRHDPAR="OTL.`"_+CRHDTEAM D GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
I ('CRHDNRTT)&($G(CRHDSRV)'="") S CRHDPAR="SRV."_CRHDSRV D GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
I '+$G(CRHDDIV) S CRHDDIV=+$$SITE^VASITE
I 'CRHDNRTT S CRHDPAR="DIV.`"_+CRHDDIV D GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHDUT 8512 printed Oct 16, 2024@18:38:38 Page 2
CRHDUT ; CAIRO/CLC - GET THE PATIENT DATA ELEMENTS FOR HANDOFF LIST ;5/13/08 05:19
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
ALG(CRHDRTN0,CRHDSTR) ; Allergies
+1 NEW CRHDTNUM
+2 SET CRHDTRG="CRHDRTN0"
+3 SET DFN=+CRHDSTR
+4 SET CRHDNUM=$PIECE(CRHDSTR,U,2)
+5 SET CRHDHDR=$PIECE(CRHDSTR,U,3)
+6 KILL @CRHDTRG,CRHDRTN
+7 NEW CRHDX
+8 SET CRHDNUM=CRHDNUM+1
SET CRHDTNUM=CRHDNUM
+9 SET CRHDNUM=$GET(CRHDNUM)+1
+10 if $GET(CRHDHDR)
SET @CRHDTRG@(CRHDNUM)="Allergies: "
+11 DO LIST^ORQQAL(.CRHDRTN,DFN)
+12 SET CRHDX=0
+13 FOR
SET CRHDX=$ORDER(CRHDRTN(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+14 SET @CRHDTRG@(CRHDNUM)=$GET(@CRHDTRG@(CRHDNUM))_$$SPACE($GET(@CRHDTRG@(CRHDNUM)),$SELECT($GET(CRHDHDR):12,1:1))_$PIECE(CRHDRTN(CRHDX),"^",2)
+15 SET CRHDNUM=CRHDNUM+1
End DoDot:1
+16 SET @CRHDTRG@(CRHDTNUM)=CRHDNUM-1
+17 QUIT
ACTMED(CRHDRTN,CRHDSTR) ;Active Medications
+1 ;CRHDRTN: Target array
+2 ;CRHDCAT: I-Inpatient Meds
+3 ; O-Outpatient Meds
+4 ; B-Both
+5 ;CRHDIV: 0 - Do not include IV
+6 ; 1 - include IV
+7 ;CRHDNUM: next number in results array
+8 ;CRHDHDR: include section heading
+9 ;CRHDDET: details, 1-include the sig, 0-exclude sig
+10 ;CRHDLEN: length to return in chars. Defaults to 16 chars.
+11 NEW CRHDUD,CRHDV,CRHDX2,CRHDC,CRHDMEDS,CRHDRN,DFN,CRHDCAT,CRHDI,CRHDN,CRHDP1,CRHDP2
+12 NEW CRHDIV,CRHDNUM,CRHDHDR,CRHDDET,CRHDFG,CRHDLEN,CRHDTNUM,CRHDMCTR,CRHDTX
+13 SET DFN=+CRHDSTR
+14 SET CRHDCAT=$PIECE(CRHDSTR,U,2)
+15 IF CRHDCAT=""
SET CRHDCAT="I"
+16 SET CRHDIV=$PIECE(CRHDSTR,U,3)
+17 SET CRHDNUM=$PIECE(CRHDSTR,U,4)
+18 SET CRHDHDR=$PIECE(CRHDSTR,U,5)
+19 SET CRHDDET=$PIECE(CRHDSTR,U,6)
+20 SET CRHDLEN=$PIECE(CRHDSTR,U,7)
+21 IF 'CRHDLEN
SET CRHDLEN=16
+22 SET CRHDTRG="CRHDRTN"
+23 KILL @CRHDTRG
+24 SET CRHDMCTR=0
+25 SET CRHDNUM=CRHDNUM+1
SET CRHDTNUM=CRHDNUM
+26 SET CRHDNUM=$GET(CRHDNUM)+1
+27 if $GET(CRHDHDR)
SET @CRHDTRG@(CRHDNUM)="Meds: "
+28 IF CRHDCAT="O"!('CRHDDET)
DO NODETAM^CRHD2(.CRHDMEDS,DFN,CRHDCAT)
DO NDOUT
SET @CRHDTRG@(CRHDTNUM)=CRHDNUM-1
QUIT
+29 IF CRHDDET
SET CRHDX=$$PSGI^CRHDAM(.CRHDMEDS,DFN)
DO DOUT
+30 SET @CRHDTRG@(CRHDTNUM)=CRHDNUM-1
+31 QUIT
NDOUT ;no details output
+1 SET CRHDP2=" S CRHDN="""""_" F S CRHDN=$O(CRHDMEDS(CRHDI,CRHDN)) Q:'CRHDN D AOUTPUT"
+2 IF CRHDCAT="I"
Begin DoDot:1
+3 SET CRHDP1="F CRHDI=""U"""
+4 IF CRHDIV
SET CRHDP1=CRHDP1_","_"""V"""
End DoDot:1
+5 IF CRHDCAT="O"
Begin DoDot:1
+6 SET CRHDP1="F CRHDI=""N"""_","_"""R"""
End DoDot:1
+7 SET CRHDP1=CRHDP1_CRHDP2
+8 XECUTE CRHDP1
+9 QUIT
AOUTPUT ;
+1 SET CRHDNUM=CRHDNUM+1
+2 ;I HDR S @TRG@(CRHDNUM)="Medications",NUM=NUM+1,HDR=0
+3 ;S @CRHDTRG@(CRHDNUM)=$E($G(CRHDMEDS(CRHDI,CRHDN)),1,CRHDLEN)
+4 SET CRHDMCTR=CRHDMCTR+1
SET @CRHDTRG@(CRHDNUM)=CRHDMCTR_"."_$EXTRACT($GET(CRHDMEDS(CRHDI,CRHDN)),1,CRHDLEN)
+5 QUIT
DOUT ;
+1 SET (CRHDX2,CRHDFG,CRHDMCTR)=0
+2 FOR
SET CRHDX2=$ORDER(CRHDMEDS(CRHDX2))
if 'CRHDX2!(CRHDFG)
QUIT
Begin DoDot:1
+3 SET CRHDTX=""
+4 SET CRHDC=$PIECE(CRHDMEDS(CRHDX2),"^",2)
+5 if CRHDC=""
QUIT
+6 IF CRHDHDR
SET CRHDNUM=CRHDNUM+1
SET @CRHDTRG@(CRHDNUM)="Inpatient Meds: "
SET CRHDNUM=CRHDNUM+1
SET CRHDHDR=0
IV IF 'CRHDIV&(CRHDC["IV DOSE")
SET CRHDFG=1
QUIT
+1 IF CRHDDET
Begin DoDot:2
+2 IF (CRHDC["=UNIT DOSE=")!(CRHDC["=IV DOSE=")
SET @CRHDTRG@(CRHDNUM)=$EXTRACT(CRHDC,1,CRHDLEN)
+3 IF '$TEST
SET CRHDMCTR=CRHDMCTR+1
SET @CRHDTRG@(CRHDNUM)=CRHDMCTR_"."_$EXTRACT(CRHDC,1,CRHDLEN)
End DoDot:2
+4 IF 'CRHDDET
SET @CRHDTRG@(CRHDNUM)=$EXTRACT(CRHDC,1,CRHDLEN)
+5 SET CRHDNUM=CRHDNUM+1
End DoDot:1
+6 QUIT
CONSULT(CRHDRTN,CRHDSTR) ;consults orders - call from cprs
+1 ;DFN,FILTERS,GROUPS,DTFROM,DTTHRU,EVENT
+2 NEW CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE,CRHDGRP
+3 NEW CRHDLEN,CHRDHDR,CRHDSTS,CRHDILST,DFN
+4 SET DFN=+CRHDSTR
+5 SET CRHDSTS=$PIECE(CRHDSTR,U,2)
+6 SET CRHDNUM=$PIECE(CRHDSTR,U,3)
+7 SET CRHDHDR=$PIECE(CRHDSTR,U,4)
+8 SET CRHDLEN=$PIECE(CRHDSTR,U,5)
+9 IF 'CRHDLEN
SET CRHDLEN=20
+10 SET CRHDTRG="CRHDRTN"
+11 KILL @CRHDTRG
+12 SET CRHDGRP=$ORDER(^ORD(100.98,"B","CONSULTS",0))
+13 ;D AGET^ORWORR(.CRHDY,DFN,"2^0",11,0,0,"")
+14 DO AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
+15 MERGE CRHDILST=@CRHDY
+16 KILL CRHDILST(.1)
+17 DO DETORD("CRHDRTN",.CRHDLST,.CRHDILST,"",CRHDLEN)
+18 QUIT
IMAGING(CRHDRTN,CRHDSTR) ;Radiology orders - call from cprs
+1 ;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
+2 NEW CRHDY,CRHDILST,ORYD,CRHDLST,X,CRHDLEN
+3 NEW D1,CRHDATE,DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDTRG,CRHDGRP
+4 SET DFN=+CRHDSTR
+5 SET CRHDSTS=$PIECE(CRHDSTR,U,2)
+6 SET CRHDNUM=$PIECE(CRHDSTR,U,3)
+7 SET CRHDHDR=$PIECE(CRHDSTR,U,4)
+8 SET CRHDLEN=$PIECE(CRHDSTR,U,5)
+9 IF 'CRHDLEN
SET CRHDLEN=20
+10 SET CRHDTRG="CRHDRTN"
+11 KILL @CRHDTRG
+12 SET CRHDGRP=$ORDER(^ORD(100.98,"B","IMAGING",0))
+13 ;D AGET^ORWORR(.CRHDY,DFN,"2^0",34,0,0,"")
+14 DO AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
+15 MERGE CRHDILST=@CRHDY
+16 KILL CRHDILST(.1)
+17 DO DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
+18 QUIT
LABS(CRHDRTN,CRHDSTR) ;LABS orders - call from cprs
+1 ;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
+2 NEW CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE
+3 NEW DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDLEN,CRHDTRG
+4 SET DFN=+CRHDSTR
+5 SET CRHDSTS=$PIECE(CRHDSTR,U,2)
+6 SET CRHDNUM=$PIECE(CRHDSTR,U,3)
+7 SET CRHDHDR=$PIECE(CRHDSTR,U,4)
+8 SET CRHDLEN=$PIECE(CRHDSTR,U,5)
+9 IF 'CRHDLEN
SET CRHDLEN=20
+10 SET CRHDTRG="CRHDRTN"
+11 KILL @CRHDTRG
+12 SET CRHDGRP=$ORDER(^ORD(100.98,"B","LABORATORY",0))
+13 ;D AGET^ORWORR(.CRHDY,DFN,"2^0",5,0,0,"")
+14 DO AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
+15 MERGE CRHDILST=@CRHDY
+16 KILL CRHDILST(.1)
+17 DO DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
+18 QUIT
PROC(CRHDRTN,CRHDSTR) ;,DFN,CRHDSTS,CRHDNUM,CRHDHDR) ;Procedures orders - call from cprs
+1 ;DFN,FILTERS,CRHDGRPS,DTFROM,DTTHRU,EVENT
+2 NEW CRHDY,CRHDILST,ORYD,CRHDLST,X,D1,CRHDATE
+3 NEW DFN,CRHDSTS,CRHDNUM,CRHDHDR,CRHDGRP,CRHDLEN,CRHDTRG
+4 SET DFN=+CRHDSTR
+5 SET CRHDSTS=$PIECE(CRHDSTR,U,2)
+6 SET CRHDNUM=$PIECE(CRHDSTR,U,3)
+7 SET CRHDHDR=$PIECE(CRHDSTR,U,4)
+8 SET CRHDLEN=$PIECE(CRHDSTR,U,5)
+9 IF 'CRHDLEN
SET CRHDLEN=20
+10 SET CRHDTRG="CRHDRTN"
+11 KILL @CRHDTRG
+12 SET CRHDGRP=$ORDER(^ORD(100.98,"B","PROCEDURES",0))
+13 ;D AGET^ORWORR(.CRHDY,DFN,"2^0",43,0,0,"")
+14 DO AGET^ORWORR(.CRHDY,DFN,"2^0",CRHDGRP,0,0,"")
+15 MERGE CRHDILST=@CRHDY
+16 KILL CRHDILST(.1)
+17 DO DETORD(.CRHDTRG,.CRHDLST,.CRHDILST,"",CRHDLEN)
+18 QUIT
DETORD(CRHDTRG,CRHDRLST,CRHDILST,CRHDHEAD,CRHDLEN) ;
+1 NEW ORYD,CRHDSTS,CRHDD1,CRHDATE,CRHDX
+2 SET ORYD=""
+3 DO GET4LST^ORWORR(.CRHDRLST,.CRHDILST)
+4 if $GET(CRHDHDR)
SET @CRHDTRG@(CRHDNUM,0)=CRHDHEAD_": "
+5 SET CRHDX=""
+6 FOR
SET CRHDX=$ORDER(CRHDLST(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+7 SET CRHDD1=$PIECE(CRHDLST(CRHDX),"^",3)
+8 IF $EXTRACT(CRHDLST(CRHDX),1)="~"
Begin DoDot:2
+9 SET CRHDD1=$PIECE(CRHDLST(CRHDX),"^",3)
+10 SET CRHDSTS=$PIECE(CRHDLST(CRHDX),"^",10)
+11 SET CRHDATE=$$FMTE^XLFDT(CRHDD1,2)
+12 SET @CRHDTRG@(CRHDNUM)=$GET(@CRHDTRG@(CRHDNUM))_$$SPACE($GET(@CRHDTRG@(CRHDNUM)),$SELECT($GET(CRHDHDR):16,1:1))_$PIECE(CRHDATE,"@",1)
End DoDot:2
+13 IF $EXTRACT(CRHDLST(CRHDX),1)="t"
Begin DoDot:2
+14 SET @CRHDTRG@(CRHDNUM)=$GET(@CRHDTRG@(CRHDNUM))_$$SPACE($GET(@CRHDTRG@(CRHDNUM)),$SELECT($GET(CRHDHDR):16,1:1))_" "_$EXTRACT(CRHDLST(CRHDX),2,$LENGTH(CRHDLST(CRHDX)))_" ("_$PIECE($GET(^ORD(100.01,+CRHDSTS,0)),"^",1)_")"
+15 SET @CRHDTRG@(CRHDNUM)=$EXTRACT(@CRHDTRG@(CRHDNUM),1,CRHDLEN)
SET CRHDNUM=CRHDNUM+1
End DoDot:2
End DoDot:1
+16 QUIT
PROB(CRHDRTNA,CRHDSTR) ;DFN,NUM,CRHDHDR) ;
+1 ;Target array ^TMP("CRHD_PROB_DATA",$J)
+2 NEW CRHDRTN,X,DFN,CRHDNUM,CRHDHDR,CRHDTRG
+3 SET DFN=+CRHDSTR
+4 SET CRHDNUM=$PIECE(CRHDSTR,U,2)
+5 SET CRHDHDR=$PIECE(CRHDSTR,U,3)
+6 SET CRHDTRG="^TMP(""CRHD_PROB_DATA"",$J)"
+7 KILL @CRHDTRG
+8 SET CRHDNUM=$GET(CRHDNUM)+1
+9 if $GET(CRHDHDR)
SET @CRHDTRG@(CRHDNUM,0)="Problem List: "
+10 DO LIST^ORQQPL(.CRHDRTN,DFN,"A")
+11 SET CRHDX=0
+12 FOR
SET CRHDX=$ORDER(CRHDRTN(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:1
+13 SET @CRHDTRG@(CRHDNUM)=$GET(@CRHDTRG@(CRHDNUM))_$$SPACE($GET(@CRHDTRG@(CRHDNUM)),$SELECT($GET(CRHDHDR):15,1:1))_$PIECE(CRHDRTN(X),"^",2)
+14 SET CRHDNUM=CRHDNUM+1
End DoDot:1
+15 ;S @CRHDTRG@(CRHDNUM)=""
+16 QUIT
RECNTLAB(CRHDROOT,DFN,CRHDNUM,CRHDHDR) ;
+1 ;(CRHDY,DFN,CRHDATE1,DIR,FORMAT)
+2 DO INTERIMG^ORWLRR(.CRHDY,DFN,$$DT^XLFDT_".2359",1,"")
+3 QUIT
SPACE(CRHDX1,CRHDX) ;
+1 NEW CRHDY,CRHDY1
+2 SET CRHDY1=""
SET CRHDY=CRHDX-$LENGTH(CRHDX1)
+3 SET $PIECE(CRHDY1," ",CRHDY)=""
+4 QUIT CRHDY1
PARAM(CRHDW,CRHDX) ;
+1 QUIT $$GET^XPAR(CRHDW,CRHDX,1,"I")
+2 ;
PTSTS(DFN) ;Display current patient status
+1 NEW CRHDGPMV,NOW,NOWI,X,Y,%,%H,%I,CRHDA,E,CRHDDGX,VAIP,VAX,VAZ,VAZ2
+2 DO NOW^%DTC
SET (VAX("DAT"),NOW)=%
SET NOWI=9999999.999999-%
+3 DO LAST^VADPT3
+4 ;use ifn of last mvt from VADPT cal
SET CRHDGPMV(1)=$SELECT($DATA(VAIP("E")):VAIP("E"),1:E)
+5 SET CRHDDGX=$GET(^DGPM(+CRHDGPMV(1),0))
SET CRHDGPMV(2)=$PIECE(CRHDDGX,"^",2)
SET CRHDGPMV(4)=$PIECE(CRHDDGX,"^",18)
+6 SET CRHDA=$SELECT("^3^5^"[("^"_+CRHDGPMV(2)_"^"):0,1:+CRHDGPMV(2))
+7 QUIT $SELECT('CRHDA:"IN",1:"")_"ACTIVE "_$SELECT("^4^5^"[("^"_+CRHDGPMV(2)_"^"):"LODGER",1:"INPATIENT")
DNRPARM(CRHDNRTT,DUZ,CRHDDIV) ;GET DNR TITLES
+1 NEW CRHDPAR,CRHDSRV,CRHDTEAM
+2 SET CRHDTEAM=$$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")
+3 SET CRHDSRV=$$GET1^DIQ(200,DUZ_",",29,"E")
+4 SET CRHDPAR="USR.`"_DUZ
+5 DO GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
+6 IF ('CRHDNRTT)&($GET(CRHDTEAM)>0)
SET CRHDPAR="OTL.`"_+CRHDTEAM
DO GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
+7 IF ('CRHDNRTT)&($GET(CRHDSRV)'="")
SET CRHDPAR="SRV."_CRHDSRV
DO GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
+8 IF '+$GET(CRHDDIV)
SET CRHDDIV=+$$SITE^VASITE
+9 IF 'CRHDNRTT
SET CRHDPAR="DIV.`"_+CRHDDIV
DO GETLST^XPAR(.CRHDNRTT,CRHDPAR,"CRHD DNR ORDER TITLE")
+10 QUIT
