ORWDCN32 ; SLC/KCM/REV - Consults calls [ 12/16/97 12:47 PM ] ;02/23/15 06:35
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,306,350**;Dec 17, 1997;Build 77
;
DEF(LST,WHY) ; load consult info
N ILST,NAM,IEN,X
S ILST=0
S LST($$NXT)="~ShortList" D SHORT
I WHY="C" D
. S LST($$NXT)="~Inpt Cslt Urgencies" D INCURG
I WHY="P" D
. S LST($$NXT)="~Inpt Proc Urgencies" D INPURG
S LST($$NXT)="~Outpt Urgencies" D OUTURG
S LST($$NXT)="~Inpt Place" D INPLACE
S LST($$NXT)="~Outpt Place" D OUTPLACE
S LST($$NXT)="~Clin Ind Date" D CID
Q
CID ; get default value for Clinically Indicated Date
N DTDFLT,ENTITY
S ENTITY="DIV^SYS^PKG"
S DTDFLT=$$GET^XPAR(ENTITY,"ORCDGMRC CLIN IND DATE DEFAULT",1,"Q") ;ICR 2263
S LST($$NXT)="d^"_DTDFLT
Q
SHORT ;return list of Consults or Procedures quick orders
N I,TMP
Q:"CP"'[WHY
S I=$O(^ORD(100.98,"B",$S(WHY="C":"CSLT",WHY="P":"PROC"),0))
D GETQLST^ORWDXQ(.TMP,I,"Q")
S I=0 F S I=$O(TMP(I)) Q:'I D
. S LST($$NXT)="i"_TMP(I)
Q
OUTPLACE ; load list of places
N X
F X="C^CONSULTANT'S CHOICE^C","E^EMERGENCY ROOM^E" D
. S LST($$NXT)="i"_X
S LST($$NXT)="d"_"C^CONSULTANT'S CHOICE^C"
Q
INPLACE ; load list of places for outpatient
N X
F X="B^BEDSIDE^B","C^CONSULTANT'S CHOICE^C" D
. S LST($$NXT)="i"_X
S LST($$NXT)="d"_"B^BEDSIDE^B"
Q
INCURG ; get list of urgencies for inpatient consults
N IEN,GMRCURG,GMRCPRO,X
S GMRCURG="",GMRCPRO=""
F S GMRCURG=$O(^ORD(101.42,"S.GMRCT",GMRCURG)) Q:GMRCURG="" D
. S GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
. S LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCT",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
S IEN=$O(^ORD(101.42,"B","ROUTINE",0)),GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
S LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
Q
INPURG ; get list of urgencies for inpatient procedures
N IEN,GMRCURG,GMRCPRO,X
S GMRCURG="",GMRCPRO=""
F S GMRCURG=$O(^ORD(101.42,"S.GMRCR",GMRCURG)) Q:GMRCURG="" D
. S GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
. S LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCR",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
S IEN=$O(^ORD(101.42,"B","ROUTINE",0)),GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
S LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
Q
OUTURG ; get list of urgencies for outpatient consults/procedures
N IEN,GMRCURG,GMRCPRO,X
S GMRCURG="",GMRCPRO=""
F S GMRCURG=$O(^ORD(101.42,"S.GMRCO",GMRCURG)) Q:GMRCURG="" D
. S GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
. S LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCO",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
S IEN=$O(^ORD(101.42,"B","ROUTINE",0)),GMRCPRO=$O(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
S LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
Q
NXT() ; increments ILST
S ILST=ILST+1
Q ILST
LOOK200(VAL,X) ; Lookup a person in 200
S VAL=$$FIND1^DIC(200,"","",X) ;ICR 2051
Q
ORDRMSG(Y,ORDITM) ;returns order message for this consult/procedure orderable
N I
S I=0 F S I=$O(^ORD(101.43,ORDITM,8,I)) Q:I'>0 S Y(I)=^(I,0)
Q
GETPROTO(Y,ORIEN) ;Get Protocol file IEN from OR IEN
S Y=$P($G(^ORD(101.43,ORIEN,0)),U,2)
Q
GETOINUM(Y,ORNUM) ;Get Orderable Item IEN from Protocol IEN
S Y=$O(^ORD(101.43,"ID",ORNUM,0))
Q
GETPRONM(Y,ORNAME) ;Get Protocol IEN given name
S Y=$O(^ORD(101,"B",ORNAME,0))_";99PRO"
Q
PROC(Y,FROM,DIR) ; Return a subset of orderable procedures
; .Return Array, Starting Text, Direction
; ^ORD(101.43,"S.PROC",UpperCase,DA)=Mne^MixedCase^InactvDt^.01IfMne
; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
N I,IEN,CNT,X,DTXT,ORID,ORSVCCNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^ORD(101.43,"S.PROC",FROM),DIR) Q:FROM="" D
. S IEN=0 F S IEN=$O(^ORD(101.43,"S.PROC",FROM,IEN)) Q:'IEN D
. . S X=^ORD(101.43,"S.PROC",FROM,IEN)
. . I +$P(X,U,3),$P(X,U,3)<$$NOW^XLFDT Q ;ICR 10103
. . S ORID=$P($G(^ORD(101.43,IEN,0)),U,2)
. . ;I $P($G(^ORD(101,ORIEN,0)),U,3)'="" Q ; Removed for v14
. . D GETSVC^GMRCPR0(.ORSVCCNT,ORID) Q:+ORSVCCNT=0 ;ICR 2982
. . S I=I+1
. . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)_U_ORID
. . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)_U_ORID
Q
NEWDLG(Y,ORTYPE,ORLOC) ; Return order dialog info for New Consult OR PROCEDURE
N DGRP,ID,IEN,TXT,TYP,X,X0,X5,ENT
S ENT="ALL"
I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC
I ORTYPE="C" S X=$$GET^XPAR(ENT,"ORWDX NEW CONSULT",1,"I") ;ICR 2263
E S X=$$GET^XPAR(ENT,"ORWDX NEW PROCEDURE",1,"I")
S IEN=+X,X0=$G(^ORD(101.41,IEN,0)),X5=$G(^(5))
S TYP=$P(X0,U,4),DGRP=+$P(X0,U,5),ID=+$P(X5,U,5),TXT=$P(X5,U,4)
S Y=IEN_";"_ID_";"_DGRP_";"_TYP_U_TXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDCN32 4608 printed Oct 16, 2024@18:36:02 Page 2
ORWDCN32 ; SLC/KCM/REV - Consults calls [ 12/16/97 12:47 PM ] ;02/23/15 06:35
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,306,350**;Dec 17, 1997;Build 77
+2 ;
DEF(LST,WHY) ; load consult info
+1 NEW ILST,NAM,IEN,X
+2 SET ILST=0
+3 SET LST($$NXT)="~ShortList"
DO SHORT
+4 IF WHY="C"
Begin DoDot:1
+5 SET LST($$NXT)="~Inpt Cslt Urgencies"
DO INCURG
End DoDot:1
+6 IF WHY="P"
Begin DoDot:1
+7 SET LST($$NXT)="~Inpt Proc Urgencies"
DO INPURG
End DoDot:1
+8 SET LST($$NXT)="~Outpt Urgencies"
DO OUTURG
+9 SET LST($$NXT)="~Inpt Place"
DO INPLACE
+10 SET LST($$NXT)="~Outpt Place"
DO OUTPLACE
+11 SET LST($$NXT)="~Clin Ind Date"
DO CID
+12 QUIT
CID ; get default value for Clinically Indicated Date
+1 NEW DTDFLT,ENTITY
+2 SET ENTITY="DIV^SYS^PKG"
+3 ;ICR 2263
SET DTDFLT=$$GET^XPAR(ENTITY,"ORCDGMRC CLIN IND DATE DEFAULT",1,"Q")
+4 SET LST($$NXT)="d^"_DTDFLT
+5 QUIT
SHORT ;return list of Consults or Procedures quick orders
+1 NEW I,TMP
+2 if "CP"'[WHY
QUIT
+3 SET I=$ORDER(^ORD(100.98,"B",$SELECT(WHY="C":"CSLT",WHY="P":"PROC"),0))
+4 DO GETQLST^ORWDXQ(.TMP,I,"Q")
+5 SET I=0
FOR
SET I=$ORDER(TMP(I))
if 'I
QUIT
Begin DoDot:1
+6 SET LST($$NXT)="i"_TMP(I)
End DoDot:1
+7 QUIT
OUTPLACE ; load list of places
+1 NEW X
+2 FOR X="C^CONSULTANT'S CHOICE^C","E^EMERGENCY ROOM^E"
Begin DoDot:1
+3 SET LST($$NXT)="i"_X
End DoDot:1
+4 SET LST($$NXT)="d"_"C^CONSULTANT'S CHOICE^C"
+5 QUIT
INPLACE ; load list of places for outpatient
+1 NEW X
+2 FOR X="B^BEDSIDE^B","C^CONSULTANT'S CHOICE^C"
Begin DoDot:1
+3 SET LST($$NXT)="i"_X
End DoDot:1
+4 SET LST($$NXT)="d"_"B^BEDSIDE^B"
+5 QUIT
INCURG ; get list of urgencies for inpatient consults
+1 NEW IEN,GMRCURG,GMRCPRO,X
+2 SET GMRCURG=""
SET GMRCPRO=""
+3 FOR
SET GMRCURG=$ORDER(^ORD(101.42,"S.GMRCT",GMRCURG))
if GMRCURG=""
QUIT
Begin DoDot:1
+4 SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
+5 SET LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCT",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
End DoDot:1
+6 SET IEN=$ORDER(^ORD(101.42,"B","ROUTINE",0))
SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
+7 SET LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
+8 QUIT
INPURG ; get list of urgencies for inpatient procedures
+1 NEW IEN,GMRCURG,GMRCPRO,X
+2 SET GMRCURG=""
SET GMRCPRO=""
+3 FOR
SET GMRCURG=$ORDER(^ORD(101.42,"S.GMRCR",GMRCURG))
if GMRCURG=""
QUIT
Begin DoDot:1
+4 SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
+5 SET LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCR",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
End DoDot:1
+6 SET IEN=$ORDER(^ORD(101.42,"B","ROUTINE",0))
SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
+7 SET LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
+8 QUIT
OUTURG ; get list of urgencies for outpatient consults/procedures
+1 NEW IEN,GMRCURG,GMRCPRO,X
+2 SET GMRCURG=""
SET GMRCPRO=""
+3 FOR
SET GMRCURG=$ORDER(^ORD(101.42,"S.GMRCO",GMRCURG))
if GMRCURG=""
QUIT
Begin DoDot:1
+4 SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - "_GMRCURG,0))
+5 SET LST($$NXT)="i"_$O(^ORD(101.42,"S.GMRCO",GMRCURG,0))_U_GMRCURG_U_GMRCPRO
End DoDot:1
+6 SET IEN=$ORDER(^ORD(101.42,"B","ROUTINE",0))
SET GMRCPRO=$ORDER(^ORD(101,"B","GMRCURGENCY - ROUTINE",0))
+7 SET LST($$NXT)="d"_IEN_U_"ROUTINE"_U_GMRCPRO
+8 QUIT
NXT() ; increments ILST
+1 SET ILST=ILST+1
+2 QUIT ILST
LOOK200(VAL,X) ; Lookup a person in 200
+1 ;ICR 2051
SET VAL=$$FIND1^DIC(200,"","",X)
+2 QUIT
ORDRMSG(Y,ORDITM) ;returns order message for this consult/procedure orderable
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,ORDITM,8,I))
if I'>0
QUIT
SET Y(I)=^(I,0)
+3 QUIT
GETPROTO(Y,ORIEN) ;Get Protocol file IEN from OR IEN
+1 SET Y=$PIECE($GET(^ORD(101.43,ORIEN,0)),U,2)
+2 QUIT
GETOINUM(Y,ORNUM) ;Get Orderable Item IEN from Protocol IEN
+1 SET Y=$ORDER(^ORD(101.43,"ID",ORNUM,0))
+2 QUIT
GETPRONM(Y,ORNAME) ;Get Protocol IEN given name
+1 SET Y=$ORDER(^ORD(101,"B",ORNAME,0))_";99PRO"
+2 QUIT
PROC(Y,FROM,DIR) ; Return a subset of orderable procedures
+1 ; .Return Array, Starting Text, Direction
+2 ; ^ORD(101.43,"S.PROC",UpperCase,DA)=Mne^MixedCase^InactvDt^.01IfMne
+3 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
+4 NEW I,IEN,CNT,X,DTXT,ORID,ORSVCCNT
SET I=0
SET CNT=44
+5 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^ORD(101.43,"S.PROC",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(101.43,"S.PROC",FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+7 SET X=^ORD(101.43,"S.PROC",FROM,IEN)
+8 ;ICR 10103
IF +$PIECE(X,U,3)
IF $PIECE(X,U,3)<$$NOW^XLFDT
QUIT
+9 SET ORID=$PIECE($GET(^ORD(101.43,IEN,0)),U,2)
+10 ;I $P($G(^ORD(101,ORIEN,0)),U,3)'="" Q ; Removed for v14
+11 ;ICR 2982
DO GETSVC^GMRCPR0(.ORSVCCNT,ORID)
if +ORSVCCNT=0
QUIT
+12 SET I=I+1
+13 IF 'X
SET Y(I)=IEN_U_$PIECE(X,U,2)_U_$PIECE(X,U,2)_U_ORID
+14 IF '$TEST
SET Y(I)=IEN_U_$PIECE(X,U,2)_$CHAR(9)_"<"_$PIECE(X,U,4)_">"_U_$PIECE(X,U,4)_U_ORID
End DoDot:2
End DoDot:1
+15 QUIT
NEWDLG(Y,ORTYPE,ORLOC) ; Return order dialog info for New Consult OR PROCEDURE
+1 NEW DGRP,ID,IEN,TXT,TYP,X,X0,X5,ENT
+2 SET ENT="ALL"
+3 IF $GET(ORLOC)
SET ORLOC=+ORLOC_";SC("
SET ENT=ENT_"^"_ORLOC
+4 ;ICR 2263
IF ORTYPE="C"
SET X=$$GET^XPAR(ENT,"ORWDX NEW CONSULT",1,"I")
+5 IF '$TEST
SET X=$$GET^XPAR(ENT,"ORWDX NEW PROCEDURE",1,"I")
+6 SET IEN=+X
SET X0=$GET(^ORD(101.41,IEN,0))
SET X5=$GET(^(5))
+7 SET TYP=$PIECE(X0,U,4)
SET DGRP=+$PIECE(X0,U,5)
SET ID=+$PIECE(X5,U,5)
SET TXT=$PIECE(X5,U,4)
+8 SET Y=IEN_";"_ID_";"_DGRP_";"_TYP_U_TXT
+9 QUIT
