source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY281.m@ 789

Last change on this file since 789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1ORY281 ;SLC/JLC-Search through Radiology/Imaging Quick Orders ;11/07/07 09:21
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN1 ; -- tasked entry point
6 I $G(DUZ)="" W "Your DUZ is not defined.",! Q
7 N ZTDESC,ZTIO,ZTRTN,ZTSK,ZTSAVE,ORCDD,ORCES
8 S (ORCDD,ORCES)="",ZTSAVE("ORCDD")="",ZTSAVE("ORCES")=""
9EN1A ;ask if user wants to clear date desired
10 S DIR(0)="FAO",DIR("A")="Clear Date Desired with a response of ""TODAY""? ",DIR("?")="Enter Y or N"
11 D ^DIR Q:X=""!(X="^") S ORCDD=$TR(X,"yn","YN") I ORCDD'="Y",ORCDD'="N" W " Enter Y or N" G EN1A
12 I ORCDD="N" G TASK
13EN2A ;ask if user wants to exclude STAT quick orders
14 S DIR(0)="FAO",DIR("A")="Exclude quick orders with STAT urgency? ",DIR("?")="Enter Y or N"
15 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
16TASK S ZTRTN="EN^ORY281",ZTIO=""
17 S ZTDESC="Check of Radiology/Imaging Quick Orders"
18 D ^%ZTLOAD
19 W !!,"The check of Radiology/Imaging Quick Orders is",$S($D(ZTSK):"",1:" NOT")," queued",!
20 I $D(ZTSK) W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
21 Q
22 ;
23EN ; -- main entry point
24 S:$D(ZTQUEUED) ZTREQ="@"
25 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
26 D NOW^%DTC S CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0) K ^XTMP("ORY281"),^TMP($J)
27 ;PXRMD(801.41 reference - DBIA # 4097
28 N DIEN,AFIND,TEXT,TYPE
29 F TYPE="G","E" D
30 . S DIEN="" F S DIEN=$O(^PXRMD(801.41,"TYPE",TYPE,DIEN)) Q:DIEN'>0 D
31 .. S TEXT=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
32 .. I TEXT[101.41 S ^TMP($J,$P(TEXT,";"))=""
33 .. S AFIND="" F S AFIND=$O(^PXRMD(801.41,DIEN,3,"B",AFIND)) Q:AFIND="" D
34 ... I AFIND'[101.41 Q
35 ... S ^TMP($J,$P(AFIND,";"))=""
36 ; 9.4 reference - DBIA # 2058
37 S ORMAG=$O(^DIC(9.4,"B","IMAGING","")),ORRAD=$O(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",""))
38 S OROD=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1","")),ORDR=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",""))
39 S ORDU=$O(^ORD(101.41,"B","OR GTX URGENCY","")),ORDUV=$O(^ORD(101.42,"B","STAT","")) I ORDUV="" S ORDUV="ORY281"
40 F I="ANGIO/NEURO/INTERVENTIONAL","CARDIOLOGY STUDIES (NUC MED)","CT SCAN","GENERAL RADIOLOGY","IMAGING" D A
41 F I="MAGNETIC RESONANCE IMAGING","MAMMOGRAPHY","NUCLEAR MEDICINE","ULTRASOUND","VASCULAR LAB" D A
42 S XRAY=$O(^ORD(100.98,"B","XRAY",0)),DA=0
43 F S DA=$O(^ORD(100.98,XRAY,1,DA)) Q:'DA S DG=$G(^(DA,0)) D
44 . S DG0=$G(^ORD(100.98,DG,0)),ABBREV=$P(DG0,"^",3)
45 . I $$ACTIVE^ORCDRA(ABBREV) S OR(DG)=""
46 S ORD=0
47 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
48 . I $P(A,"^",5)]"",'$D(OR($P(A,"^",5))) Q
49 . I B'=ORMAG,B'=ORRAD Q
50 . S ORDUO=""
51 . 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
52 .. I $P(B,"^",2)=ORDU S ORDUO=$G(^ORD(101.41,ORD,6,S1,1)) Q
53 .. I $P(B,"^",2)=OROD D Q
54 ... 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))
55 .. I $P(B,"^",2)=ORDR D
56 ... S ^XTMP("ORY281",ORD,S1)=$P(A,"^")_"^"_$P(A,"^",3),^XTMP("ORY281",ORD,S1,"DATE")="D: "_$G(^ORD(101.41,ORD,6,S1,1))
57 ... Q:ORCDD="N" S A=$G(^ORD(101.41,ORD,6,S1,1)) I A="T"!(A="TODAY") D
58 .... 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
59 .... I ORCES="Y" Q:ORDUO=ORDUV
60 .... S DA(1)=ORD,DA=S1,DIK="^ORD(101.41,"_DA(1)_",6," D ^DIK
61 I $D(^XTMP("ORY281")) S ^XTMP("ORY281",0)=EXPR_"^"_CREAT
62 D SEND
63 K ZTQUEUED,ZTREQ Q
64SEND ;Send message
65 K ORMSG,XMY N OCNT,ORD,A,S1,XMDUZ,XMSUB,XMTEXT,H1,H2,H3
66 S XMDUZ="CPRS, SEARCH",XMSUB="RADIOLOGY/IMAGING QUICK ORDERS",XMTEXT="ORMSG(",XMY(DUZ)=""
67 S ORMSG(1,0)=" The check of Radiology/Imaging Quick Orders is complete."
68 S ORMSG(2,0)=" ",ORMSG(3,0)=" Here is the list of all quick orders that should be reviewed: ",ORMSG(4,0)=" "
69 S ORD=0,ORMSG(5,0)="Quick Order Name Disable Text Text or Start Date/Time Ancestors/Menus or Reminders"
70 S ORMSG(6,0)=" ",OCNT=6
71 F S ORD=$O(^XTMP("ORY281",ORD)) Q:ORD="" S S1=$O(^XTMP("ORY281",ORD,0)) Q:S1="" S A=^(S1) D
72 . 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)=""
73 . I $D(^TMP($J,ORD)) S H2="Used in Clinical Reminders Dialog"
74 . I $D(^ORD(101.41,"AD",ORD)) S H3="On a menu or in an order set"
75 . S S1=0 F S S1=$O(^XTMP("ORY281",ORD,S1)) Q:S1="" S A=^(S1) D
76 .. S S2=0 F S S2=$O(^XTMP("ORY281",ORD,S1,S2)) Q:S2="" S A=^(S2) I $TR(A," ")]"" D
77 ... I H1 S OCNT=OCNT+1,ORMSG(OCNT,0)=$J(" ",56)
78 ... S ORMSG(OCNT,0)=ORMSG(OCNT,0)_$E($P(A,"^")_$J(" ",39),1,38)_" ",H1=1
79 ... I H2]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2 S H2="" Q
80 ... I H3]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3 S H3=""
81 . I H2]"" S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H2
82 . I H3]"" S:$L(ORMSG(OCNT,0))>97 OCNT=OCNT+1,ORMSG(OCNT,0)=$J(" ",97) S ORMSG(OCNT,0)=ORMSG(OCNT,0)_H3
83 . S OCNT=OCNT+1,ORMSG(OCNT,0)=" "
84 D ^XMD
85 Q
86A ;
87 S A=$O(^ORD(100.98,"B",I,"")) I A]"" S OR(A)=""
88 Q
Note: See TracBrowser for help on using the repository browser.