source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPXRM.m@ 619

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1RAPXRM ;HOIFO/SWM - API for Clinical Reminders ;10/1/03 09:33
2 ;;5.0;Radiology/Nuclear Medicine;**33,56**;Mar 16, 1998;Build 3
3 ; IA #3731 documents entry point EN1
4 ; IA #4113 grants use of rtn PXRMSXRM
5 ; IA #4114 grants use of direct Set and Kill, use of ^PXRMINDX(70
6 ;Supported IA #2056 GET1^DIQ
7 ;Supported IA #2052 GET1^DID
8 ;Supported IA #10141 BMES^XPDUTL, MES^XPDUTL
9 ;Supported IA #10103 NOW^XLFDT
10EN1(RADAS,RARM) ;retrieve data from Clin. Rem.'s new style index "ACR"
11 ; Input:
12 ; RADAS = last subscript of (required), for example:
13 ; ^PXRMINDX(70,"IP",43,1,2,2920720.1049,"2;DT;7079279.895;P;3;0")
14 ; ^PXRMINDX(70,"PI",9,3,45,2921204.155,"9;DT;7078795.8449;P;1;0")
15 ; RARM = array name passed by reference (required)
16 ; Output:
17 ; RARM("aaa") = external value, eg.:
18 ; RARM("EXAM D/T") = Exam Date and time in yyymmdd.hhmm format
19 ; RARM("EXAM STATUS") = Exam Status name
20 ; RARM("PROCEDURE") = Procedure name
21 ; RARM("INTERPRETING PHYSICIAN") = Primary Staff; else Primary Resident
22 ; If exam node doesn't exist, then RARM is undefined
23 ; RARM("RPT STATUS") = Report status name
24 ;
25 K RARM ; clear output var
26 ; validate RADAS string
27 Q:$P(RADAS,";",2)'="DT" Q:$P(RADAS,";",4)'="P" Q:$P(RADAS,";",6)'="0"
28 N RA0,RADFN,RADTI,RACNI,X,I,J,RARPT
29 S RADFN=$P(RADAS,";"),RADTI=$P(RADAS,";",3),RACNI=$P(RADAS,";",5)
30 S RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
31 Q:RA0=""
32 S RARM("EXAM D/T")=9999999.9999-RADTI
33 S RARM("EXAM STATUS")=$P($G(^RA(72,+$P(RA0,U,3),0)),U)
34 S RARM("PROCEDURE")=$P($G(^RAMIS(71,+$P(RA0,U,2),0)),U)
35 S X=$S($P(RA0,U,15):+$P(RA0,U,15),$P(RA0,U,12):+$P(RA0,U,12),1:"")
36 S:X'="" X=$$GET1^DIQ(200,X,.01)
37 S RARM("INTERPRETING PHYSICIAN")=X
38 ;
39 ; RARM("PDX")=Primary DX text
40 ; this node won't exist if there's no data for Prim DX
41 ; RARM("SDX",n)=Secondary DX text at ^RADPT(-,"DT",-,"P",-,"DX",n,0)
42 ; the n may have gaps if a Secondary DX was deleted
43 ;
44 S RARPT=$P(RA0,U,17) S RARM("RPT STATUS")=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A())
45 S:$P(RA0,U,13)'="" RARM("PDX")=$P($G(^RA(78.3,+$P(RA0,U,13),0)),U)
46 S I=0
47 F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",I)) Q:'I I $D(^(I,0)) S J=+$G(^(0)) I J S RARM("SDX",I)=$P($G(^RA(78.3,J,0)),U)
48 Q
49 ;===============================================================
50 ; RAD section copied from former location RAD^PXRMSXRO
51RAD ;Build the index for RAD/NUC MED PATIENT.
52 N D0,D1,D2,DA,DAS,DFN,END,ENTRIES,GLOBAL,IND,NE,NERROR,PROC
53 N START,TEMP,TENP,TEXT
54 ;Don't leave any old stuff around.
55 K ^PXRMINDX(70)
56 S GLOBAL=$$GET1^DID(70,"","","GLOBAL NAME")
57 S ENTRIES=$P(^RADPT(0),U,4)
58 S TENP=ENTRIES/10
59 S TENP=+$P(TENP,".",1)
60 I TENP<1 S TENP=1
61 D BMES^XPDUTL("Building index for RAD DATA")
62 S TEXT="There are "_ENTRIES_" entries to process."
63 D MES^XPDUTL(TEXT)
64 S START=$H
65 S (D0,IND,NE,NERROR)=0
66 F S D0=+$O(^RADPT(D0)) Q:D0=0 D
67 . S IND=IND+1
68 . I IND#TENP=0 D
69 .. S TEXT="Processing entry "_IND
70 .. D MES^XPDUTL(TEXT)
71 . I IND#10000=0 W "."
72 . S DFN=$P($G(^RADPT(D0,0)),U,1)
73 . I DFN="" D Q
74 .. S ETEXT=D0_" no patient"
75 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
76 . S D1=0
77 . F S D1=+$O(^RADPT(D0,"DT",D1)) Q:D1=0 D
78 .. S DATE=$P($G(^RADPT(D0,"DT",D1,0)),U,1)
79 .. S DA=D0_";DT;"_D1
80 .. I DATE="" D Q
81 ... S ETEXT=DA_" no date"
82 ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
83 .. S D2=0
84 .. F S D2=+$O(^RADPT(D0,"DT",D1,"P",D2)) Q:D2=0 D
85 ... S TEMP=$G(^RADPT(D0,"DT",D1,"P",D2,0))
86 ... S DAS=DA_";P;"_D2_";0"
87 ... S PROC=$P(TEMP,U,2)
88 ... I PROC="" D Q
89 .... S ETEXT=DAS_" no procedure"
90 .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
91 ... S ^PXRMINDX(70,"IP",PROC,DFN,DATE,DAS)=""
92 ... S ^PXRMINDX(70,"PI",DFN,PROC,DATE,DAS)=""
93 ... S NE=NE+1
94 S END=$H
95 S TEXT=NE_" RAD/NUC MED PATIENT results indexed."
96 D MES^XPDUTL(TEXT)
97 D DETIME^PXRMSXRM(START,END)
98 ;If there were errors send a message.
99 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
100 ;Send a MailMan message with the results.
101 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
102 S ^PXRMINDX(70,"GLOBAL NAME")=$$GET1^DID(70,"","","GLOBAL NAME")
103 S ^PXRMINDX(70,"BUILT BY")=DUZ
104 S ^PXRMINDX(70,"DATE BUILT")=$$NOW^XLFDT
105 Q
106 ;
107 ;===============================================================
108KRAD(X,DA) ;Delete index for RAD/NUC MED PATIENT file.
109 N DAS,DATE
110 S DATE=9999999.9999-DA(1)
111 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
112 K ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)
113 K ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)
114 Q
115 ;
116 ;===============================================================
117SRAD(X,DA) ;Set index for RAD/NUC MED PATIENT file.
118 ;DA(2)=DFN, DA(1)=EXAM DATE (inverse date), DA=Examinations Entry
119 ;X(1)=PROCEDURE
120 N DAS,DATE
121 S DATE=9999999.9999-DA(1)
122 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
123 S ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)=""
124 S ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)=""
125 Q
126 ;
Note: See TracBrowser for help on using the repository browser.