ORWDRA32 ; SLC/KCM/REV/JDL - Radiology calls to support windows [6/28/02] ;Oct 19, 2020@08:05:39
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,116,141,215,280,377,498**;Dec 17, 1997;Build 38
;
DEF(LST,PATID,EVTDIV,IMGTYP) ; Get dialog data for radiology
N ILST,I,ORX S ILST=0
S LST($$NXT)="~ShortList" D SHORT
S IMGTYP=$$IMTYPE(IMGTYP)
S LST($$NXT)="~Common Procedures" D COMMPRO
S LST($$NXT)="~Modifiers" D MODIFYR
S LST($$NXT)="~Urgencies" D URGENCY
S LST($$NXT)="~Transport" D TRNSPRT
S LST($$NXT)="~Category" D CATEGRY
S LST($$NXT)="~Submit to" D SUBMIT
S LST($$NXT)="~Last 7 Days" D LAST7
Q
MODIFYR ; Get the modifiers (should be by imaging type)
S I=$O(^RA(79.2,"C",IMGTYP,0)) Q:'I
S ORX=0 F S ORX=$O(^RAMIS(71.2,"AB",I,ORX)) Q:'ORX S LST($$NXT)="i"_ORX_U_$P(^RAMIS(71.2,ORX,0),U)
Q
SHORT ; from DEF, get short list of imaging quick orders
N I,TMP
D GETQLST^ORWDXQ(.TMP,IMGTYP,"Q")
S I=0 F S I=$O(TMP(I)) Q:'I D
. S LST($$NXT)="i"_TMP(I)
Q
COMMPRO ; Get the common procedures
N ORX
S ORX=""
F S ORX=$O(^ORD(101.43,"COMMON",IMGTYP,ORX)) Q:ORX="" D
. S I=$O(^ORD(101.43,"COMMON",IMGTYP,ORX,0))
. I $$REQDET,$P($G(^ORD(101.43,I,"RA")),U,2)="B" Q
. S LST($$NXT)="i"_I_U_ORX_U_U_$$REQAPPR(I)
Q
URGENCY ; Get the allowable urgencies and default
N A
S ORX="",I=0 N ORUIEN
F S ORX=$O(^ORD(101.42,"S.RA",ORX)) Q:ORX="" S ORUIEN=0 D
. F S ORUIEN=$O(^ORD(101.42,"S.RA",ORX,ORUIEN)) Q:'ORUIEN D
. . I '$$RADURG(ORUIEN) Q
. . S I=$O(^ORD(101.42,"S.RA",ORX,0))
. . S LST($$NXT)="i"_I_U_ORX
Q
TRNSPRT ; Get the modes of transport
F ORX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR" D
. S LST($$NXT)="i"_ORX
; figure default on windows side
Q
CATEGRY ; Get the categories of exam
F ORX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH" D
. S LST($$NXT)="i"_ORX
; figure default on windows side
Q
SUBMIT ; Get the locations to which the request may be submitted
N TMPLST,ASK,ORX
D EN4^RAO7PC1(IMGTYP,"TMPLST")
S I=0 F S I=$O(TMPLST(I)) Q:'I S LST($$NXT)="i"_TMPLST(I)
I $D(TMPLST) S I=$O(TMPLST(0)),ORX=$P(TMPLST(I),U,1,2),LST($$NXT)="d"_ORX
S LST($$NXT)="~Ask Submit"
I $G(EVTDIV) S ORX=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA SUBMIT PROMPT",1,"Q")
E S ORX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
;S DUZ(2)=TMPDIV
S ASK=$S($L(ORX):ORX,1:1)
S LST($$NXT)="d"_ASK_U_$S(ASK=1:"YES",ASK=0:"NO",1:"YES")
Q
LAST7 ; Get exams for the last 7 days
K ^TMP($J,"RAE7") D EN2^RAO7PC1(PATID)
S I=0 F S I=$O(^TMP($J,"RAE7",PATID,I)) Q:'I D
. S LST($$NXT)="i"_I_U_^TMP($J,"RAE7",PATID,I)
K ^TMP($J,"RAE7")
Q
PROCMSG(ORY,IEN) ; return order message for a procedure
N I
S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S ORY(I)=^(I,0)
Q
NXT() ; Increment index of LST
S ILST=ILST+1
Q ILST
RADCOUNT() ;Number of procedures in a long list
Q 80
RADLONG(Y,IMGTYP) ; Returns true if the procedures list should be a long list
N XREF,CNT,IDX,IEN,MAX,REQ,ORX
S XREF="S."_$$IMTYPE(IMGTYP),CNT=0,Y=0,IDX="",MAX=$$RADCOUNT,REQ=$$REQDET
F Q:CNT>MAX S IDX=$O(^ORD(101.43,XREF,IDX)) Q:IDX="" D
. S IEN=0 F S IEN=$O(^ORD(101.43,XREF,IDX,IEN)) Q:'IEN D
. . I REQ,$P($G(^ORD(101.43,IEN,"RA")),U,2)="B" Q
. . S ORX=^ORD(101.43,XREF,IDX,IEN)
. . I +$P(ORX,U,3),$P(ORX,U,3)<DT Q
. . S CNT=CNT+1
I CNT>MAX S Y=1
Q
RAORDITM(Y,FROM,DIR,IMGTYP) ; Return a subset of orderable items
; .Return Array, Starting Text, Direction, Cross Reference (S.xxx)
N I,IEN,CNT,ORX,DTXT,REQDET,REQAPPR,XREF,REQ
S XREF="S."_$$IMTYPE(IMGTYP),I=0,CNT=$$RADCOUNT,REQ=$$REQDET
F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D
. S IEN=0 F S IEN=$O(^ORD(101.43,XREF,FROM,IEN)) Q:'IEN D
. . I REQ,$P($G(^ORD(101.43,IEN,"RA")),U,2)="B" Q
. . S ORX=^ORD(101.43,XREF,FROM,IEN)
. . I +$P(ORX,U,3),$P(ORX,U,3)<DT Q
. . S I=I+1
. . I 'ORX S Y(I)=IEN_U_$P(ORX,U,2)_U_$P(ORX,U,2)_U_$$REQAPPR(IEN)
. . E S Y(I)=IEN_U_$P(ORX,U,2)_" <"_$P(ORX,U,4)_">"_U_$P(ORX,U,4)_U_$$REQAPPR(IEN)
Q
REQDET() ; Are "broad" procedures allowed for this division?
N RESULT
I $G(EVTDIV) S RESULT=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA REQUIRE DETAILED",1,"Q")
E S RESULT=$$GET^XPAR("ALL","RA REQUIRE DETAILED",1,"Q")
Q RESULT
;
REQAPPR(IEN) ; does procedure require radiologist approval?
N RAIEN
S RAIEN=$P($P($G(^ORD(101.43,IEN,0)),U,2),";",1)
I +RAIEN=0 Q ""
Q $P($G(^RAMIS(71,RAIEN,0)),U,11)
;
ISOLATN(Y,DFN) ;Is patient on isolation procedures?
N ORVP
S ORVP=DFN_";DPT("
S Y=$$IP^ORMBLD
Q
APPROVAL(Y,DUMMY) ; RETURNS LIST OF RADIOLOGISTS WHO MAY APPROVE A
; PROCEDURE WHEN REQUIRED
N ORX,I
S I="" F S I=$O(^VA(200,"ARC","S",I)) Q:I="" D
. ;I $P($G(^VA(200,I,"PS")),U,4),$P(^VA(200,I,"PS"),U,4)'>DT Q
. I '$$ACTIVE^XUSER(I) Q
. I $P($G(^VA(200,I,"RA")),U,3),$P(^VA(200,I,"RA"),U,3)'>DT Q
. S ORX=$P($G(^VA(200,I,0)),U)
. S Y(I)=I_U_ORX
Q
IMTYPE(DGRP) ; return the mnemonic for the imaging type
Q $P(^ORD(100.98,DGRP,0),U,3)
IMTYPSEL(Y,DUMMY) ;return list of active imaging types
N ORX,I,IEN,DGRP,MNEM,NAME
S ORX=""
F I=1:1 S ORX=$O(^RA(79.2,"C",ORX)) Q:ORX="" D
. I '$D(^ORD(101.43,"S."_ORX)) Q
. S IEN=$O(^RA(79.2,"C",ORX,0))
. S NAME=$P(^RA(79.2,IEN,0),U,1)
. S MNEM=$P(^RA(79.2,IEN,0),U,3)
. S DGRP=$O(^ORD(100.98,"B",MNEM,0))
. S Y(I)=IEN_U_NAME_U_MNEM_U_DGRP
Q
RADSRC(Y,SRCTYPE) ; return list of available contract/sharing/research sources
S ORX=0
F I=1:1 S ORX=$O(^DIC(34,ORX)) Q:+ORX=0 D
. Q:($P(^DIC(34,ORX,0),U,2)'=SRCTYPE)
. I $D(^DIC(34,ORX,"I")),(^DIC(34,ORX,"I")<$$NOW^XLFDT) Q
. S Y(I)=ORX_U_$P(^DIC(34,ORX,0),U,1)
Q
LOCTYPE(Y,ORLOC) ; Returns type of location (C,W)
S Y=-1
Q:$G(ORLOC)=""
S Y=$P($G(^SC(+$G(ORLOC),0)),U,3)
Q
RADURG(URGIEN) ;
I '$D(URGIEN) Q 0
S A=$G(^ORD(101.42,URGIEN,0)) I "^A^S^R^"'[("^"_$P(A,"^",2)_"^") Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDRA32 5951 printed Jun 11, 2024@22:14:17 Page 2
ORWDRA32 ; SLC/KCM/REV/JDL - Radiology calls to support windows [6/28/02] ;Oct 19, 2020@08:05:39
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,116,141,215,280,377,498**;Dec 17, 1997;Build 38
+2 ;
DEF(LST,PATID,EVTDIV,IMGTYP) ; Get dialog data for radiology
+1 NEW ILST,I,ORX
SET ILST=0
+2 SET LST($$NXT)="~ShortList"
DO SHORT
+3 SET IMGTYP=$$IMTYPE(IMGTYP)
+4 SET LST($$NXT)="~Common Procedures"
DO COMMPRO
+5 SET LST($$NXT)="~Modifiers"
DO MODIFYR
+6 SET LST($$NXT)="~Urgencies"
DO URGENCY
+7 SET LST($$NXT)="~Transport"
DO TRNSPRT
+8 SET LST($$NXT)="~Category"
DO CATEGRY
+9 SET LST($$NXT)="~Submit to"
DO SUBMIT
+10 SET LST($$NXT)="~Last 7 Days"
DO LAST7
+11 QUIT
MODIFYR ; Get the modifiers (should be by imaging type)
+1 SET I=$ORDER(^RA(79.2,"C",IMGTYP,0))
if 'I
QUIT
+2 SET ORX=0
FOR
SET ORX=$ORDER(^RAMIS(71.2,"AB",I,ORX))
if 'ORX
QUIT
SET LST($$NXT)="i"_ORX_U_$P(^RAMIS(71.2,ORX,0),U)
+3 QUIT
SHORT ; from DEF, get short list of imaging quick orders
+1 NEW I,TMP
+2 DO GETQLST^ORWDXQ(.TMP,IMGTYP,"Q")
+3 SET I=0
FOR
SET I=$ORDER(TMP(I))
if 'I
QUIT
Begin DoDot:1
+4 SET LST($$NXT)="i"_TMP(I)
End DoDot:1
+5 QUIT
COMMPRO ; Get the common procedures
+1 NEW ORX
+2 SET ORX=""
+3 FOR
SET ORX=$ORDER(^ORD(101.43,"COMMON",IMGTYP,ORX))
if ORX=""
QUIT
Begin DoDot:1
+4 SET I=$ORDER(^ORD(101.43,"COMMON",IMGTYP,ORX,0))
+5 IF $$REQDET
IF $PIECE($GET(^ORD(101.43,I,"RA")),U,2)="B"
QUIT
+6 SET LST($$NXT)="i"_I_U_ORX_U_U_$$REQAPPR(I)
End DoDot:1
+7 QUIT
URGENCY ; Get the allowable urgencies and default
+1 NEW A
+2 SET ORX=""
SET I=0
NEW ORUIEN
+3 FOR
SET ORX=$ORDER(^ORD(101.42,"S.RA",ORX))
if ORX=""
QUIT
SET ORUIEN=0
Begin DoDot:1
+4 FOR
SET ORUIEN=$ORDER(^ORD(101.42,"S.RA",ORX,ORUIEN))
if 'ORUIEN
QUIT
Begin DoDot:2
+5 IF '$$RADURG(ORUIEN)
QUIT
+6 SET I=$ORDER(^ORD(101.42,"S.RA",ORX,0))
+7 SET LST($$NXT)="i"_I_U_ORX
End DoDot:2
End DoDot:1
+8 QUIT
TRNSPRT ; Get the modes of transport
+1 FOR ORX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR"
Begin DoDot:1
+2 SET LST($$NXT)="i"_ORX
End DoDot:1
+3 ; figure default on windows side
+4 QUIT
CATEGRY ; Get the categories of exam
+1 FOR ORX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH"
Begin DoDot:1
+2 SET LST($$NXT)="i"_ORX
End DoDot:1
+3 ; figure default on windows side
+4 QUIT
SUBMIT ; Get the locations to which the request may be submitted
+1 NEW TMPLST,ASK,ORX
+2 DO EN4^RAO7PC1(IMGTYP,"TMPLST")
+3 SET I=0
FOR
SET I=$ORDER(TMPLST(I))
if 'I
QUIT
SET LST($$NXT)="i"_TMPLST(I)
+4 IF $DATA(TMPLST)
SET I=$ORDER(TMPLST(0))
SET ORX=$PIECE(TMPLST(I),U,1,2)
SET LST($$NXT)="d"_ORX
+5 SET LST($$NXT)="~Ask Submit"
+6 IF $GET(EVTDIV)
SET ORX=$$GET^XPAR(+$GET(EVTDIV)_";DIC(4,^SYS^PKG","RA SUBMIT PROMPT",1,"Q")
+7 IF '$TEST
SET ORX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
+8 ;S DUZ(2)=TMPDIV
+9 SET ASK=$SELECT($LENGTH(ORX):ORX,1:1)
+10 SET LST($$NXT)="d"_ASK_U_$S(ASK=1:"YES",ASK=0:"NO",1:"YES")
+11 QUIT
LAST7 ; Get exams for the last 7 days
+1 KILL ^TMP($JOB,"RAE7")
DO EN2^RAO7PC1(PATID)
+2 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"RAE7",PATID,I))
if 'I
QUIT
Begin DoDot:1
+3 SET LST($$NXT)="i"_I_U_^TMP($JOB,"RAE7",PATID,I)
End DoDot:1
+4 KILL ^TMP($JOB,"RAE7")
+5 QUIT
PROCMSG(ORY,IEN) ; return order message for a procedure
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,IEN,8,I))
if I'>0
QUIT
SET ORY(I)=^(I,0)
+3 QUIT
NXT() ; Increment index of LST
+1 SET ILST=ILST+1
+2 QUIT ILST
RADCOUNT() ;Number of procedures in a long list
+1 QUIT 80
RADLONG(Y,IMGTYP) ; Returns true if the procedures list should be a long list
+1 NEW XREF,CNT,IDX,IEN,MAX,REQ,ORX
+2 SET XREF="S."_$$IMTYPE(IMGTYP)
SET CNT=0
SET Y=0
SET IDX=""
SET MAX=$$RADCOUNT
SET REQ=$$REQDET
+3 FOR
if CNT>MAX
QUIT
SET IDX=$ORDER(^ORD(101.43,XREF,IDX))
if IDX=""
QUIT
Begin DoDot:1
+4 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(101.43,XREF,IDX,IEN))
if 'IEN
QUIT
Begin DoDot:2
+5 IF REQ
IF $PIECE($GET(^ORD(101.43,IEN,"RA")),U,2)="B"
QUIT
+6 SET ORX=^ORD(101.43,XREF,IDX,IEN)
+7 IF +$PIECE(ORX,U,3)
IF $PIECE(ORX,U,3)<DT
QUIT
+8 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+9 IF CNT>MAX
SET Y=1
+10 QUIT
RAORDITM(Y,FROM,DIR,IMGTYP) ; Return a subset of orderable items
+1 ; .Return Array, Starting Text, Direction, Cross Reference (S.xxx)
+2 NEW I,IEN,CNT,ORX,DTXT,REQDET,REQAPPR,XREF,REQ
+3 SET XREF="S."_$$IMTYPE(IMGTYP)
SET I=0
SET CNT=$$RADCOUNT
SET REQ=$$REQDET
+4 FOR
if I'<CNT
QUIT
SET FROM=$ORDER(^ORD(101.43,XREF,FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(101.43,XREF,FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+6 IF REQ
IF $PIECE($GET(^ORD(101.43,IEN,"RA")),U,2)="B"
QUIT
+7 SET ORX=^ORD(101.43,XREF,FROM,IEN)
+8 IF +$PIECE(ORX,U,3)
IF $PIECE(ORX,U,3)<DT
QUIT
+9 SET I=I+1
+10 IF 'ORX
SET Y(I)=IEN_U_$PIECE(ORX,U,2)_U_$PIECE(ORX,U,2)_U_$$REQAPPR(IEN)
+11 IF '$TEST
SET Y(I)=IEN_U_$PIECE(ORX,U,2)_" <"_$PIECE(ORX,U,4)_">"_U_$PIECE(ORX,U,4)_U_$$REQAPPR(IEN)
End DoDot:2
End DoDot:1
+12 QUIT
REQDET() ; Are "broad" procedures allowed for this division?
+1 NEW RESULT
+2 IF $GET(EVTDIV)
SET RESULT=$$GET^XPAR(+$GET(EVTDIV)_";DIC(4,^SYS^PKG","RA REQUIRE DETAILED",1,"Q")
+3 IF '$TEST
SET RESULT=$$GET^XPAR("ALL","RA REQUIRE DETAILED",1,"Q")
+4 QUIT RESULT
+5 ;
REQAPPR(IEN) ; does procedure require radiologist approval?
+1 NEW RAIEN
+2 SET RAIEN=$PIECE($PIECE($GET(^ORD(101.43,IEN,0)),U,2),";",1)
+3 IF +RAIEN=0
QUIT ""
+4 QUIT $PIECE($GET(^RAMIS(71,RAIEN,0)),U,11)
+5 ;
ISOLATN(Y,DFN) ;Is patient on isolation procedures?
+1 NEW ORVP
+2 SET ORVP=DFN_";DPT("
+3 SET Y=$$IP^ORMBLD
+4 QUIT
APPROVAL(Y,DUMMY) ; RETURNS LIST OF RADIOLOGISTS WHO MAY APPROVE A
+1 ; PROCEDURE WHEN REQUIRED
+2 NEW ORX,I
+3 SET I=""
FOR
SET I=$ORDER(^VA(200,"ARC","S",I))
if I=""
QUIT
Begin DoDot:1
+4 ;I $P($G(^VA(200,I,"PS")),U,4),$P(^VA(200,I,"PS"),U,4)'>DT Q
+5 IF '$$ACTIVE^XUSER(I)
QUIT
+6 IF $PIECE($GET(^VA(200,I,"RA")),U,3)
IF $PIECE(^VA(200,I,"RA"),U,3)'>DT
QUIT
+7 SET ORX=$PIECE($GET(^VA(200,I,0)),U)
+8 SET Y(I)=I_U_ORX
End DoDot:1
+9 QUIT
IMTYPE(DGRP) ; return the mnemonic for the imaging type
+1 QUIT $PIECE(^ORD(100.98,DGRP,0),U,3)
IMTYPSEL(Y,DUMMY) ;return list of active imaging types
+1 NEW ORX,I,IEN,DGRP,MNEM,NAME
+2 SET ORX=""
+3 FOR I=1:1
SET ORX=$ORDER(^RA(79.2,"C",ORX))
if ORX=""
QUIT
Begin DoDot:1
+4 IF '$DATA(^ORD(101.43,"S."_ORX))
QUIT
+5 SET IEN=$ORDER(^RA(79.2,"C",ORX,0))
+6 SET NAME=$PIECE(^RA(79.2,IEN,0),U,1)
+7 SET MNEM=$PIECE(^RA(79.2,IEN,0),U,3)
+8 SET DGRP=$ORDER(^ORD(100.98,"B",MNEM,0))
+9 SET Y(I)=IEN_U_NAME_U_MNEM_U_DGRP
End DoDot:1
+10 QUIT
RADSRC(Y,SRCTYPE) ; return list of available contract/sharing/research sources
+1 SET ORX=0
+2 FOR I=1:1
SET ORX=$ORDER(^DIC(34,ORX))
if +ORX=0
QUIT
Begin DoDot:1
+3 if ($PIECE(^DIC(34,ORX,0),U,2)'=SRCTYPE)
QUIT
+4 IF $DATA(^DIC(34,ORX,"I"))
IF (^DIC(34,ORX,"I")<$$NOW^XLFDT)
QUIT
+5 SET Y(I)=ORX_U_$PIECE(^DIC(34,ORX,0),U,1)
End DoDot:1
+6 QUIT
LOCTYPE(Y,ORLOC) ; Returns type of location (C,W)
+1 SET Y=-1
+2 if $GET(ORLOC)=""
QUIT
+3 SET Y=$PIECE($GET(^SC(+$GET(ORLOC),0)),U,3)
+4 QUIT
RADURG(URGIEN) ;
+1 IF '$DATA(URGIEN)
QUIT 0
+2 SET A=$GET(^ORD(101.42,URGIEN,0))
IF "^A^S^R^"'[("^"_$PIECE(A,"^",2)_"^")
QUIT 0
+3 QUIT 1
