source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLQ1.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1RAHLQ1 ;HISC/CAH AISC/SAW-Compiles HL7 'ORF' Message Type ;10/7/97 16:02
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3 ; Set the ^TMP("RARPT-QBAK",$J,RARECNT,... global to the following:
4 ; ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=Patient ID & checksum
5 ; "PID5" Patient name
6 ; "PID7" Patient DOB
7 ; "PID8" sex of the patient
8 ; "PID19" Patient SSN (if any)
9 ; "OBR4A" inverse date/time exam "-" case ien (radti-racni)
10 ; "OBR4B" date/time exam (radte)
11 ; "OBR16A" ien requesting physician
12 ; "OBR16B" name of requesting physician
13 ; "OBR20" name of ward location or principal clinic
14 ; "LAN-A" LANIER ONLY --> $p(racn0,"^",2)
15 ; "LAN-B" LANIER ONLY --> $p(^ramis(71,+$p(racn0,"^",2),0),"^")
16 ; "OBX5" radisp_$p(^ramis(71,+$p(racn0,"^",2),0),"^")
17 ; radisp_"Unknown" if no procedure
18 ; where radisp is + or . for printset
19 ; "OBX5-MOD" string of modifiers
20 ; "OBX-HIST-NONE" "None Entered" if no clinical history
21 ; "OBX5-ALLE" string of allergies
22 ;
23 ; "RADFN" RADFN
24 ; "VADM(1)" VADM(1)
25 ; "VADM(3)" VADM(3)
26 ; "RAPRV" RAPRV
27 ; "RADTE0" RADTE0
28 ;
29 ; RACN0 = Examinations 0 node (70.03 sub-file)
30EN1 S RADTE0=$S($D(^RADPT(RADFN,"DT",RADTI,0)):+^(0),1:"")
31 S RADTE=$S(RADTE0:$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,1:+RACN0)
32 ;
33 ;Compile 'PID' Segment
34 S ^TMP("RARPT-QBAK",$J,RARECNT,"RADFN")=RADFN
35 S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(1)")=VADM(1)
36 S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(3)")=VADM(3)
37 S ^TMP("RARPT-QBAK",$J,RARECNT,"PID8")=$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U")
38 S:$P(VADM(2),"^")]"" ^TMP("RARPT-QBAK",$J,RARECNT,"PID19")=$P(VADM(2),"^")
39 ;
40 ;Compile 'OBR' Segment
41 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4A")=RADTI_"-"_RACNI
42 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4B")=RADTE
43 S RAPRV=$P($G(^VA(200,+$P(RACN0,"^",14),0)),"^")
44 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR16A")=$S(RAPRV]"":+$P(RACN0,"^",14),1:"")
45 S ^TMP("RARPT-QBAK",$J,RARECNT,"RAPRV")=RAPRV
46 S ^TMP("RARPT-QBAK",$J,RARECNT,"RADTE0")=RADTE0
47 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR20")=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown")
48 ;
49 ;Compile 'OBX' Segment for Procedure
50 S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-A")=$P(RACN0,"^",2)
51 S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-B")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:"")
52 ;
53 ; set flags if print set and/or lowest case of print set
54 N RACN,RAPRTSET,RAMEMLOW,RADISP
55 S RACN=+RACN0,RAPRTSET=0,RAMEMLOW=0,RADISP=" "
56 D EN1^RAUTL20
57 I RAPRTSET S RADISP="." S:RAMEMLOW RADISP="+"
58 ;For Lanier units, comment out next line
59 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):RADISP_$P(^(0),"^"),1:"Unknown")
60 ;
61 ;Compile 'OBX' Segment for Modifiers
62 D MODS^RAUTL2
63 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-MOD")=Y
64 ;
65 ;Compile 'OBX' Segment for Clinical History
66 I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX-HIST-NONE")="None Entered"
67 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP
68 ; save ^UTILITY($J,"W") for bridge routine
69 ;
70 ;Compile 'OBX' Segment for Allergies
71 S DFN=RADFN D ALLERGY^RADEM S X="" I $D(GMRAL) S I=0 F S I=$O(PI(I)) Q:I'>0 S X0=PI(I) I X0]"" Q:($L(X)+$L(X0))>200 S X=X_X0_", "
72 I $L(X) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-ALLE")=X
73 K DIWF,DIWL,DIWR,GMRAL,I,PI,RAI,RAPRV,RADTE,RADTE0
74 Q
Note: See TracBrowser for help on using the repository browser.