ORY281 ;SLC/JLC-Search through Radiology/Imaging Quick Orders ;11/07/07 09:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN1 ; -- tasked entry point
I $G(DUZ)="" W "Your DUZ is not defined.",! Q
N ZTDESC,ZTIO,ZTRTN,ZTSK,ZTSAVE,ORCDD,ORCES
S (ORCDD,ORCES)="",ZTSAVE("ORCDD")="",ZTSAVE("ORCES")=""
EN1A ;ask if user wants to clear date desired
S DIR(0)="FAO",DIR("A")="Clear Date Desired with a response of ""TODAY""? ",DIR("?")="Enter Y or N"
D ^DIR Q:X=""!(X="^") S ORCDD=$TR(X,"yn","YN") I ORCDD'="Y",ORCDD'="N" W " Enter Y or N" G EN1A
I ORCDD="N" G TASK
EN2A ;ask if user wants to exclude STAT quick orders
S DIR(0)="FAO",DIR("A")="Exclude quick orders with STAT urgency? ",DIR("?")="Enter Y or N"
D ^DIR G EN1A:X="" Q:X="^" S ORCES=$TR(X,"yn","YN") I ORCES'="Y",ORCES'="N" W " Enter Y or N" G EN2A
TASK S ZTRTN="EN^ORY281",ZTIO=""
S ZTDESC="Check of Radiology/Imaging Quick Orders"
D ^%ZTLOAD
W !!,"The check of Radiology/Imaging Quick Orders is",$S($D(ZTSK):"",1:" NOT")," queued",!
I $D(ZTSK) W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
Q
;
EN ; -- main entry point
S:$D(ZTQUEUED) ZTREQ="@"
N CREAT,EXPR,ORMAG,ORRAD,OROD,ORDR,ORDU,ORDUO,ORDUV,I,S1,S2,NS1,A,B,%,OR,XRAY,ABBREV,DA,DG,DG0,DIK,DIR,X
D NOW^%DTC S CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0) K ^XTMP("ORY281"),^TMP($J)
;PXRMD(801.41 reference - DBIA # 4097
N DIEN,AFIND,TEXT,TYPE
F TYPE="G","E" D
. S DIEN="" F S DIEN=$O(^PXRMD(801.41,"TYPE",TYPE,DIEN)) Q:DIEN'>0 D
.. S TEXT=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
.. I TEXT[101.41 S ^TMP($J,$P(TEXT,";"))=""
.. S AFIND="" F S AFIND=$O(^PXRMD(801.41,DIEN,3,"B",AFIND)) Q:AFIND="" D
... I AFIND'[101.41 Q
... S ^TMP($J,$P(AFIND,";"))=""
; 9.4 reference - DBIA # 2058
S ORMAG=$O(^DIC(9.4,"B","IMAGING","")),ORRAD=$O(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",""))
S OROD=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1","")),ORDR=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",""))
S ORDU=$O(^ORD(101.41,"B","OR GTX URGENCY","")),ORDUV=$O(^ORD(101.42,"B","STAT","")) I ORDUV="" S ORDUV="ORY281"
F I="ANGIO/NEURO/INTERVENTIONAL","CARDIOLOGY STUDIES (NUC MED)","CT SCAN","GENERAL RADIOLOGY","IMAGING" D A
F I="MAGNETIC RESONANCE IMAGING","MAMMOGRAPHY","NUCLEAR MEDICINE","ULTRASOUND","VASCULAR LAB" D A
S XRAY=$O(^ORD(100.98,"B","XRAY",0)),DA=0
F S DA=$O(^ORD(100.98,XRAY,1,DA)) Q:'DA S DG=$G(^(DA,0)) D
. S DG0=$G(^ORD(100.98,DG,0)),ABBREV=$P(DG0,"^",3)
. I $$ACTIVE^ORCDRA(ABBREV) S OR(DG)=""
S ORD=0
F S ORD=$O(^ORD(101.41,ORD)) Q:'ORD S A=$G(^(ORD,0)) I $P(A,"^",4)="Q" S B=$P(A,"^",7) D
. I $P(A,"^",5)]"",'$D(OR($P(A,"^",5))) Q
. I B'=ORMAG,B'=ORRAD Q
. S ORDUO=""
. S S1=0 F S S1=$O(^ORD(101.41,ORD,6,S1)) Q:'S1 S B=$G(^(S1,0)) I $P(B,"^",2)=OROD!($P(B,"^",2)=ORDR)!($P(B,"^",2)=ORDU) D
.. I $P(B,"^",2)=ORDU S ORDUO=$G(^ORD(101.41,ORD,6,S1,1)) Q
.. I $P(B,"^",2)=OROD D Q
... S S2=0 F S S2=$O(^ORD(101.41,ORD,6,S1,2,S2)) Q:'S2 I $G(^(S2,0))]"" S ^XTMP("ORY281",ORD,S1)=$P(A,"^")_"^"_$P(A,"^",3),^XTMP("ORY281",ORD,S1,S2)="T: "_$G(^ORD(101.41,ORD,6,S1,2,S2,0))
.. I $P(B,"^",2)=ORDR D
... S ^XTMP("ORY281",ORD,S1)=$P(A,"^")_"^"_$P(A,"^",3),^XTMP("ORY281",ORD,S1,"DATE")="D: "_$G(^ORD(101.41,ORD,6,S1,1))
... Q:ORCDD="N" S A=$G(^ORD(101.41,ORD,6,S1,1)) I A="T"!(A="TODAY") D
.... I ORDUO="" S NS1=S1 F S NS1=$O(^ORD(101.41,ORD,6,NS1)) Q:'NS1 S B=$G(^(NS1,0)) I $P(B,"^",2)=ORDU S ORDUO=$G(^ORD(101.41,ORD,6,NS1,1)) Q
.... I ORCES="Y" Q:ORDUO=ORDUV
.... S DA(1)=ORD,DA=S1,DIK="^ORD(101.41,"_DA(1)_",6," D ^DIK
I $D(^XTMP("ORY281")) S ^XTMP("ORY281",0)=EXPR_"^"_CREAT
D SEND
K ZTQUEUED,ZTREQ Q
SEND ;Send message
K ORMSG,XMY N OCNT,ORD,A,S1,XMDUZ,XMSUB,XMTEXT,H1,H2,H3
S XMDUZ="CPRS, SEARCH",XMSUB="RADIOLOGY/IMAGING QUICK ORDERS",XMTEXT="ORMSG(",XMY(DUZ)=""
S ORMSG(1,0)=" The check of Radiology/Imaging Quick Orders is complete."
S ORMSG(2,0)=" ",ORMSG(3,0)=" Here is the list of all quick orders that should be reviewed: ",ORMSG(4,0)=" "
S ORD=0,ORMSG(5,0)="Quick Order Name Disable Text Text or Start Date/Time Ancestors/Menus or Reminders"
S ORMSG(6,0)=" ",OCNT=6
F S ORD=$O(^XTMP("ORY281",ORD)) Q:ORD="" S S1=$O(^XTMP("ORY281",ORD,0)) Q:S1="" S A=^(S1) D
. S OCNT=OCNT+1,ORMSG(OCNT,0)=$E($P(A,"^")_$J(" ",38),1,37)_" "_$E($P(A,"^",2)_$J(" ",38),1,15)_" ",(H1,H2,H3)=""
. I $D(^TMP($J,ORD)) S H2="Used in Clinical Reminders Dialog"
. I $D(^ORD(101.41,"AD",ORD)) S H3="On a menu or in an order set"
. S S1=0 F S S1=$O(^XTMP("ORY281",ORD,S1)) Q:S1="" S A=^(S1) D
.. S S2=0 F S S2=$O(^XTMP("ORY281",ORD,S1,S2)) Q:S2="" S A=^(S2) I $TR(A," ")]"" D
... I H1 S OCNT=OCNT+1,ORMSG(OCNT,0)=$J(" ",56)
... S ORMSG(OCNT,0)=ORMSG(OCNT,0)_$E($P(A,"^")_$J(" ",39),1,38)_" ",H1=1
... I H2]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2 S H2="" Q
... I H3]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3 S H3=""
. I H2]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2
. I H3]"" S:$L(ORMSG(OCNT,0))>97 OCNT=OCNT+1,ORMSG(OCNT,0)=$J(" ",97) S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3
. S OCNT=OCNT+1,ORMSG(OCNT,0)=" "
D ^XMD
Q
A ;
S A=$O(^ORD(100.98,"B",I,"")) I A]"" S OR(A)=""
Q
ORY281 ;SLC/JLC-Search through Radiology/Imaging Quick Orders ;11/07/07 09:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN1 ; -- tasked entry point
+1 IF $GET(DUZ)=""
WRITE "Your DUZ is not defined.",!
QUIT
+2 NEW ZTDESC,ZTIO,ZTRTN,ZTSK,ZTSAVE,ORCDD,ORCES
+3 SET (ORCDD,ORCES)=""
SET ZTSAVE("ORCDD")=""
SET ZTSAVE("ORCES")=""
EN1A ;ask if user wants to clear date desired
+1 SET DIR(0)="FAO"
SET DIR("A")="Clear Date Desired with a response of ""TODAY""? "
SET DIR("?")="Enter Y or N"
+2 DO ^DIR
IF X=""!(X="^")
QUIT
SET ORCDD=$TRANSLATE(X,"yn","YN")
IF ORCDD'="Y"
IF ORCDD'="N"
WRITE " Enter Y or N"
GOTO EN1A
+3 IF ORCDD="N"
GOTO TASK
EN2A ;ask if user wants to exclude STAT quick orders
+1 SET DIR(0)="FAO"
SET DIR("A")="Exclude quick orders with STAT urgency? "
SET DIR("?")="Enter Y or N"
+2 DO ^DIR
IF X=""
GOTO EN1A
IF X="^"
QUIT
SET ORCES=$TRANSLATE(X,"yn","YN")
IF ORCES'="Y"
IF ORCES'="N"
WRITE " Enter Y or N"
GOTO EN2A
TASK SET ZTRTN="EN^ORY281"
SET ZTIO=""
+1 SET ZTDESC="Check of Radiology/Imaging Quick Orders"
+2 DO ^%ZTLOAD
+3 WRITE !!,"The check of Radiology/Imaging Quick Orders is",$SELECT($DATA(ZTSK):"",1:" NOT")," queued",!
+4 IF $DATA(ZTSK)
WRITE " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
+5 QUIT
+6 ;
EN ; -- main entry point
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW CREAT,EXPR,ORMAG,ORRAD,OROD,ORDR,ORDU,ORDUO,ORDUV,I,S1,S2,NS1,A,B,%,OR,XRAY,ABBREV,DA,DG,DG0,DIK,DIR,X
+3 DO NOW^%DTC
SET CREAT=$EXTRACT(%,1,7)
SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
KILL ^XTMP("ORY281"),^TMP($JOB)
+4 ;PXRMD(801.41 reference - DBIA # 4097
+5 NEW DIEN,AFIND,TEXT,TYPE
+6 FOR TYPE="G","E"
Begin DoDot:1
+7 SET DIEN=""
FOR
SET DIEN=$ORDER(^PXRMD(801.41,"TYPE",TYPE,DIEN))
IF DIEN'>0
QUIT
Begin DoDot:2
+8 SET TEXT=$PIECE($GET(^PXRMD(801.41,DIEN,1)),U,5)
+9 IF TEXT[101.41
SET ^TMP($JOB,$PIECE(TEXT,";"))=""
+10 SET AFIND=""
FOR
SET AFIND=$ORDER(^PXRMD(801.41,DIEN,3,"B",AFIND))
IF AFIND=""
QUIT
Begin DoDot:3
+11 IF AFIND'[101.41
QUIT
+12 SET ^TMP($JOB,$PIECE(AFIND,";"))=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 ; 9.4 reference - DBIA # 2058
+14 SET ORMAG=$ORDER(^DIC(9.4,"B","IMAGING",""))
SET ORRAD=$ORDER(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",""))
+15 SET OROD=$ORDER(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",""))
SET ORDR=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",""))
+16 SET ORDU=$ORDER(^ORD(101.41,"B","OR GTX URGENCY",""))
SET ORDUV=$ORDER(^ORD(101.42,"B","STAT",""))
IF ORDUV=""
SET ORDUV="ORY281"
+17 FOR I="ANGIO/NEURO/INTERVENTIONAL","CARDIOLOGY STUDIES (NUC MED)","CT SCAN","GENERAL RADIOLOGY","IMAGING"
DO A
+18 FOR I="MAGNETIC RESONANCE IMAGING","MAMMOGRAPHY","NUCLEAR MEDICINE","ULTRASOUND","VASCULAR LAB"
DO A
+19 SET XRAY=$ORDER(^ORD(100.98,"B","XRAY",0))
SET DA=0
+20 FOR
SET DA=$ORDER(^ORD(100.98,XRAY,1,DA))
IF 'DA
QUIT
SET DG=$GET(^(DA,0))
Begin DoDot:1
+21 SET DG0=$GET(^ORD(100.98,DG,0))
SET ABBREV=$PIECE(DG0,"^",3)
+22 IF $$ACTIVE^ORCDRA(ABBREV)
SET OR(DG)=""
End DoDot:1
+23 SET ORD=0
+24 FOR
SET ORD=$ORDER(^ORD(101.41,ORD))
IF 'ORD
QUIT
SET A=$GET(^(ORD,0))
IF $PIECE(A,"^",4)="Q"
SET B=$PIECE(A,"^",7)
Begin DoDot:1
+25 IF $PIECE(A,"^",5)]""
IF '$DATA(OR($PIECE(A,"^",5)))
QUIT
+26 IF B'=ORMAG
IF B'=ORRAD
QUIT
+27 SET ORDUO=""
+28 SET S1=0
FOR
SET S1=$ORDER(^ORD(101.41,ORD,6,S1))
IF 'S1
QUIT
SET B=$GET(^(S1,0))
IF $PIECE(B,"^",2)=OROD!($PIECE(B,"^",2)=ORDR)!($PIECE(B,"^",2)=ORDU)
Begin DoDot:2
+29 IF $PIECE(B,"^",2)=ORDU
SET ORDUO=$GET(^ORD(101.41,ORD,6,S1,1))
QUIT
+30 IF $PIECE(B,"^",2)=OROD
Begin DoDot:3
+31 SET S2=0
FOR
SET S2=$ORDER(^ORD(101.41,ORD,6,S1,2,S2))
IF 'S2
QUIT
IF $GET(^(S2,0))]""
SET ^XTMP("ORY281",ORD,S1)=$PIECE(A,"^")_"^"_$PIECE(A,"^",3)
SET ^XTMP("ORY281",ORD,S1,S2)="T: "_$GET(^ORD(101.41,ORD,6,S1,2,S2,0))
End DoDot:3
QUIT
+32 IF $PIECE(B,"^",2)=ORDR
Begin DoDot:3
+33 SET ^XTMP("ORY281",ORD,S1)=$PIECE(A,"^")_"^"_$PIECE(A,"^",3)
SET ^XTMP("ORY281",ORD,S1,"DATE")="D: "_$GET(^ORD(101.41,ORD,6,S1,1))
+34 IF ORCDD="N"
QUIT
SET A=$GET(^ORD(101.41,ORD,6,S1,1))
IF A="T"!(A="TODAY")
Begin DoDot:4
+35 IF ORDUO=""
SET NS1=S1
FOR
SET NS1=$ORDER(^ORD(101.41,ORD,6,NS1))
IF 'NS1
QUIT
SET B=$GET(^(NS1,0))
IF $PIECE(B,"^",2)=ORDU
SET ORDUO=$GET(^ORD(101.41,ORD,6,NS1,1))
QUIT
+36 IF ORCES="Y"
IF ORDUO=ORDUV
QUIT
+37 SET DA(1)=ORD
SET DA=S1
SET DIK="^ORD(101.41,"_DA(1)_",6,"
DO ^DIK
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 IF $DATA(^XTMP("ORY281"))
SET ^XTMP("ORY281",0)=EXPR_"^"_CREAT
+39 DO SEND
+40 KILL ZTQUEUED,ZTREQ
QUIT
SEND ;Send message
+1 KILL ORMSG,XMY
NEW OCNT,ORD,A,S1,XMDUZ,XMSUB,XMTEXT,H1,H2,H3
+2 SET XMDUZ="CPRS, SEARCH"
SET XMSUB="RADIOLOGY/IMAGING QUICK ORDERS"
SET XMTEXT="ORMSG("
SET XMY(DUZ)=""
+3 SET ORMSG(1,0)=" The check of Radiology/Imaging Quick Orders is complete."
+4 SET ORMSG(2,0)=" "
SET ORMSG(3,0)=" Here is the list of all quick orders that should be reviewed: "
SET ORMSG(4,0)=" "
+5 SET ORD=0
SET ORMSG(5,0)="Quick Order Name Disable Text Text or Start Date/Time Ancestors/Menus or Reminders"
+6 SET ORMSG(6,0)=" "
SET OCNT=6
+7 FOR
SET ORD=$ORDER(^XTMP("ORY281",ORD))
IF ORD=""
QUIT
SET S1=$ORDER(^XTMP("ORY281",ORD,0))
IF S1=""
QUIT
SET A=^(S1)
Begin DoDot:1
+8 SET OCNT=OCNT+1
SET ORMSG(OCNT,0)=$EXTRACT($PIECE(A,"^")_$JUSTIFY(" ",38),1,37)_" "_$EXTRACT($PIECE(A,"^",2)_$JUSTIFY(" ",38),1,15)_" "
SET (H1,H2,H3)=""
+9 IF $DATA(^TMP($JOB,ORD))
SET H2="Used in Clinical Reminders Dialog"
+10 IF $DATA(^ORD(101.41,"AD",ORD))
SET H3="On a menu or in an order set"
+11 SET S1=0
FOR
SET S1=$ORDER(^XTMP("ORY281",ORD,S1))
IF S1=""
QUIT
SET A=^(S1)
Begin DoDot:2
+12 SET S2=0
FOR
SET S2=$ORDER(^XTMP("ORY281",ORD,S1,S2))
IF S2=""
QUIT
SET A=^(S2)
IF $TRANSLATE(A," ")]""
Begin DoDot:3
+13 IF H1
SET OCNT=OCNT+1
SET ORMSG(OCNT,0)=$JUSTIFY(" ",56)
+14 SET ORMSG(OCNT,0)=ORMSG(OCNT,0)_$EXTRACT($PIECE(A,"^")_$JUSTIFY(" ",39),1,38)_" "
SET H1=1
+15 IF H2]""
SET ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2
SET H2=""
QUIT
+16 IF H3]""
SET ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3
SET H3=""
End DoDot:3
End DoDot:2
+17 IF H2]""
SET ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2
+18 IF H3]""
IF $LENGTH(ORMSG(OCNT,0))>97
SET OCNT=OCNT+1
SET ORMSG(OCNT,0)=$JUSTIFY(" ",97)
SET ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3
+19 SET OCNT=OCNT+1
SET ORMSG(OCNT,0)=" "
End DoDot:1
+20 DO ^XMD
+21 QUIT
A ;
+1 SET A=$ORDER(^ORD(100.98,"B",I,""))
IF A]""
SET OR(A)=""
+2 QUIT
