Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDRA32

ORWDRA32.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. DEF(LST,PATID,EVTDIV,IMGTYP) ; Get dialog data for radiology
  1. N ILST,I,ORX S ILST=0
  1. S LST($$NXT)="~ShortList" D SHORT
  1. S IMGTYP=$$IMTYPE(IMGTYP)
  1. S LST($$NXT)="~Common Procedures" D COMMPRO
  1. S LST($$NXT)="~Modifiers" D MODIFYR
  1. S LST($$NXT)="~Urgencies" D URGENCY
  1. S LST($$NXT)="~Transport" D TRNSPRT
  1. S LST($$NXT)="~Category" D CATEGRY
  1. S LST($$NXT)="~Submit to" D SUBMIT
  1. S LST($$NXT)="~Last 7 Days" D LAST7
  1. Q
  1. MODIFYR ; Get the modifiers (should be by imaging type)
  1. S I=$O(^RA(79.2,"C",IMGTYP,0)) Q:'I
  1. 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)
  1. Q
  1. SHORT ; from DEF, get short list of imaging quick orders
  1. N I,TMP
  1. D GETQLST^ORWDXQ(.TMP,IMGTYP,"Q")
  1. S I=0 F S I=$O(TMP(I)) Q:'I D
  1. . S LST($$NXT)="i"_TMP(I)
  1. Q
  1. COMMPRO ; Get the common procedures
  1. N ORX
  1. S ORX=""
  1. F S ORX=$O(^ORD(101.43,"COMMON",IMGTYP,ORX)) Q:ORX="" D
  1. . S I=$O(^ORD(101.43,"COMMON",IMGTYP,ORX,0))
  1. . I $$REQDET,$P($G(^ORD(101.43,I,"RA")),U,2)="B" Q
  1. . S LST($$NXT)="i"_I_U_ORX_U_U_$$REQAPPR(I)
  1. Q
  1. URGENCY ; Get the allowable urgencies and default
  1. N A
  1. S ORX="",I=0 N ORUIEN
  1. F S ORX=$O(^ORD(101.42,"S.RA",ORX)) Q:ORX="" S ORUIEN=0 D
  1. . F S ORUIEN=$O(^ORD(101.42,"S.RA",ORX,ORUIEN)) Q:'ORUIEN D
  1. . . I '$$RADURG(ORUIEN) Q
  1. . . S I=$O(^ORD(101.42,"S.RA",ORX,0))
  1. . . S LST($$NXT)="i"_I_U_ORX
  1. Q
  1. TRNSPRT ; Get the modes of transport
  1. F ORX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR" D
  1. . S LST($$NXT)="i"_ORX
  1. ; figure default on windows side
  1. Q
  1. CATEGRY ; Get the categories of exam
  1. F ORX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH" D
  1. . S LST($$NXT)="i"_ORX
  1. ; figure default on windows side
  1. Q
  1. SUBMIT ; Get the locations to which the request may be submitted
  1. N TMPLST,ASK,ORX
  1. D EN4^RAO7PC1(IMGTYP,"TMPLST")
  1. S I=0 F S I=$O(TMPLST(I)) Q:'I S LST($$NXT)="i"_TMPLST(I)
  1. I $D(TMPLST) S I=$O(TMPLST(0)),ORX=$P(TMPLST(I),U,1,2),LST($$NXT)="d"_ORX
  1. S LST($$NXT)="~Ask Submit"
  1. I $G(EVTDIV) S ORX=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA SUBMIT PROMPT",1,"Q")
  1. E S ORX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
  1. ;S DUZ(2)=TMPDIV
  1. S ASK=$S($L(ORX):ORX,1:1)
  1. S LST($$NXT)="d"_ASK_U_$S(ASK=1:"YES",ASK=0:"NO",1:"YES")
  1. Q
  1. LAST7 ; Get exams for the last 7 days
  1. K ^TMP($J,"RAE7") D EN2^RAO7PC1(PATID)
  1. S I=0 F S I=$O(^TMP($J,"RAE7",PATID,I)) Q:'I D
  1. . S LST($$NXT)="i"_I_U_^TMP($J,"RAE7",PATID,I)
  1. K ^TMP($J,"RAE7")
  1. Q
  1. PROCMSG(ORY,IEN) ; return order message for a procedure
  1. N I
  1. S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S ORY(I)=^(I,0)
  1. Q
  1. NXT() ; Increment index of LST
  1. S ILST=ILST+1
  1. Q ILST
  1. RADCOUNT() ;Number of procedures in a long list
  1. Q 80
  1. RADLONG(Y,IMGTYP) ; Returns true if the procedures list should be a long list
  1. N XREF,CNT,IDX,IEN,MAX,REQ,ORX
  1. S XREF="S."_$$IMTYPE(IMGTYP),CNT=0,Y=0,IDX="",MAX=$$RADCOUNT,REQ=$$REQDET
  1. F Q:CNT>MAX S IDX=$O(^ORD(101.43,XREF,IDX)) Q:IDX="" D
  1. . S IEN=0 F S IEN=$O(^ORD(101.43,XREF,IDX,IEN)) Q:'IEN D
  1. . . I REQ,$P($G(^ORD(101.43,IEN,"RA")),U,2)="B" Q
  1. . . S ORX=^ORD(101.43,XREF,IDX,IEN)
  1. . . I +$P(ORX,U,3),$P(ORX,U,3)<DT Q
  1. . . S CNT=CNT+1
  1. I CNT>MAX S Y=1
  1. Q
  1. RAORDITM(Y,FROM,DIR,IMGTYP) ; Return a subset of orderable items
  1. ; .Return Array, Starting Text, Direction, Cross Reference (S.xxx)
  1. N I,IEN,CNT,ORX,DTXT,REQDET,REQAPPR,XREF,REQ
  1. S XREF="S."_$$IMTYPE(IMGTYP),I=0,CNT=$$RADCOUNT,REQ=$$REQDET
  1. F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D
  1. . S IEN=0 F S IEN=$O(^ORD(101.43,XREF,FROM,IEN)) Q:'IEN D
  1. . . I REQ,$P($G(^ORD(101.43,IEN,"RA")),U,2)="B" Q
  1. . . S ORX=^ORD(101.43,XREF,FROM,IEN)
  1. . . I +$P(ORX,U,3),$P(ORX,U,3)<DT Q
  1. . . S I=I+1
  1. . . I 'ORX S Y(I)=IEN_U_$P(ORX,U,2)_U_$P(ORX,U,2)_U_$$REQAPPR(IEN)
  1. . . E S Y(I)=IEN_U_$P(ORX,U,2)_" <"_$P(ORX,U,4)_">"_U_$P(ORX,U,4)_U_$$REQAPPR(IEN)
  1. Q
  1. REQDET() ; Are "broad" procedures allowed for this division?
  1. N RESULT
  1. I $G(EVTDIV) S RESULT=$$GET^XPAR(+$G(EVTDIV)_";DIC(4,^SYS^PKG","RA REQUIRE DETAILED",1,"Q")
  1. E S RESULT=$$GET^XPAR("ALL","RA REQUIRE DETAILED",1,"Q")
  1. Q RESULT
  1. ;
  1. REQAPPR(IEN) ; does procedure require radiologist approval?
  1. N RAIEN
  1. S RAIEN=$P($P($G(^ORD(101.43,IEN,0)),U,2),";",1)
  1. I +RAIEN=0 Q ""
  1. Q $P($G(^RAMIS(71,RAIEN,0)),U,11)
  1. ;
  1. ISOLATN(Y,DFN) ;Is patient on isolation procedures?
  1. N ORVP
  1. S ORVP=DFN_";DPT("
  1. S Y=$$IP^ORMBLD
  1. Q
  1. APPROVAL(Y,DUMMY) ; RETURNS LIST OF RADIOLOGISTS WHO MAY APPROVE A
  1. ; PROCEDURE WHEN REQUIRED
  1. N ORX,I
  1. S I="" F S I=$O(^VA(200,"ARC","S",I)) Q:I="" D
  1. . ;I $P($G(^VA(200,I,"PS")),U,4),$P(^VA(200,I,"PS"),U,4)'>DT Q
  1. . I '$$ACTIVE^XUSER(I) Q
  1. . I $P($G(^VA(200,I,"RA")),U,3),$P(^VA(200,I,"RA"),U,3)'>DT Q
  1. . S ORX=$P($G(^VA(200,I,0)),U)
  1. . S Y(I)=I_U_ORX
  1. Q
  1. IMTYPE(DGRP) ; return the mnemonic for the imaging type
  1. Q $P(^ORD(100.98,DGRP,0),U,3)
  1. IMTYPSEL(Y,DUMMY) ;return list of active imaging types
  1. N ORX,I,IEN,DGRP,MNEM,NAME
  1. S ORX=""
  1. F I=1:1 S ORX=$O(^RA(79.2,"C",ORX)) Q:ORX="" D
  1. . I '$D(^ORD(101.43,"S."_ORX)) Q
  1. . S IEN=$O(^RA(79.2,"C",ORX,0))
  1. . S NAME=$P(^RA(79.2,IEN,0),U,1)
  1. . S MNEM=$P(^RA(79.2,IEN,0),U,3)
  1. . S DGRP=$O(^ORD(100.98,"B",MNEM,0))
  1. . S Y(I)=IEN_U_NAME_U_MNEM_U_DGRP
  1. Q
  1. RADSRC(Y,SRCTYPE) ; return list of available contract/sharing/research sources
  1. S ORX=0
  1. F I=1:1 S ORX=$O(^DIC(34,ORX)) Q:+ORX=0 D
  1. . Q:($P(^DIC(34,ORX,0),U,2)'=SRCTYPE)
  1. . I $D(^DIC(34,ORX,"I")),(^DIC(34,ORX,"I")<$$NOW^XLFDT) Q
  1. . S Y(I)=ORX_U_$P(^DIC(34,ORX,0),U,1)
  1. Q
  1. LOCTYPE(Y,ORLOC) ; Returns type of location (C,W)
  1. S Y=-1
  1. Q:$G(ORLOC)=""
  1. S Y=$P($G(^SC(+$G(ORLOC),0)),U,3)
  1. Q
  1. RADURG(URGIEN) ;
  1. I '$D(URGIEN) Q 0
  1. S A=$G(^ORD(101.42,URGIEN,0)) I "^A^S^R^"'[("^"_$P(A,"^",2)_"^") Q 0
  1. Q 1