- 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 Feb 19, 2025@00:02:20 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