RAHLQ1 ;HISC/CAH AISC/SAW-Compiles HL7 'ORF' Message Type ;10/7/97 16:02
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
; Set the ^TMP("RARPT-QBAK",$J,RARECNT,... global to the following:
; ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=Patient ID & checksum
; "PID5" Patient name
; "PID7" Patient DOB
; "PID8" sex of the patient
; "PID19" Patient SSN (if any)
; "OBR4A" inverse date/time exam "-" case ien (radti-racni)
; "OBR4B" date/time exam (radte)
; "OBR16A" ien requesting physician
; "OBR16B" name of requesting physician
; "OBR20" name of ward location or principal clinic
; "LAN-A" LANIER ONLY --> $p(racn0,"^",2)
; "LAN-B" LANIER ONLY --> $p(^ramis(71,+$p(racn0,"^",2),0),"^")
; "OBX5" radisp_$p(^ramis(71,+$p(racn0,"^",2),0),"^")
; radisp_"Unknown" if no procedure
; where radisp is + or . for printset
; "OBX5-MOD" string of modifiers
; "OBX-HIST-NONE" "None Entered" if no clinical history
; "OBX5-ALLE" string of allergies
;
; "RADFN" RADFN
; "VADM(1)" VADM(1)
; "VADM(3)" VADM(3)
; "RAPRV" RAPRV
; "RADTE0" RADTE0
;
; RACN0 = Examinations 0 node (70.03 sub-file)
EN1 S RADTE0=$S($D(^RADPT(RADFN,"DT",RADTI,0)):+^(0),1:"")
S RADTE=$S(RADTE0:$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,1:+RACN0)
;
;Compile 'PID' Segment
S ^TMP("RARPT-QBAK",$J,RARECNT,"RADFN")=RADFN
S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(1)")=VADM(1)
S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(3)")=VADM(3)
S ^TMP("RARPT-QBAK",$J,RARECNT,"PID8")=$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U")
S:$P(VADM(2),"^")]"" ^TMP("RARPT-QBAK",$J,RARECNT,"PID19")=$P(VADM(2),"^")
;
;Compile 'OBR' Segment
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4A")=RADTI_"-"_RACNI
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4B")=RADTE
S RAPRV=$P($G(^VA(200,+$P(RACN0,"^",14),0)),"^")
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR16A")=$S(RAPRV]"":+$P(RACN0,"^",14),1:"")
S ^TMP("RARPT-QBAK",$J,RARECNT,"RAPRV")=RAPRV
S ^TMP("RARPT-QBAK",$J,RARECNT,"RADTE0")=RADTE0
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")
;
;Compile 'OBX' Segment for Procedure
S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-A")=$P(RACN0,"^",2)
S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-B")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:"")
;
; set flags if print set and/or lowest case of print set
N RACN,RAPRTSET,RAMEMLOW,RADISP
S RACN=+RACN0,RAPRTSET=0,RAMEMLOW=0,RADISP=" "
D EN1^RAUTL20
I RAPRTSET S RADISP="." S:RAMEMLOW RADISP="+"
;For Lanier units, comment out next line
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):RADISP_$P(^(0),"^"),1:"Unknown")
;
;Compile 'OBX' Segment for Modifiers
D MODS^RAUTL2
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-MOD")=Y
;
;Compile 'OBX' Segment for Clinical History
I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX-HIST-NONE")="None Entered"
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
; save ^UTILITY($J,"W") for bridge routine
;
;Compile 'OBX' Segment for Allergies
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_", "
I $L(X) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-ALLE")=X
K DIWF,DIWL,DIWR,GMRAL,I,PI,RAI,RAPRV,RADTE,RADTE0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLQ1 3638 printed Dec 13, 2024@02:35:26 Page 2
RAHLQ1 ;HISC/CAH AISC/SAW-Compiles HL7 'ORF' Message Type ;10/7/97 16:02
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ; Set the ^TMP("RARPT-QBAK",$J,RARECNT,... global to the following:
+3 ; ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=Patient ID & checksum
+4 ; "PID5" Patient name
+5 ; "PID7" Patient DOB
+6 ; "PID8" sex of the patient
+7 ; "PID19" Patient SSN (if any)
+8 ; "OBR4A" inverse date/time exam "-" case ien (radti-racni)
+9 ; "OBR4B" date/time exam (radte)
+10 ; "OBR16A" ien requesting physician
+11 ; "OBR16B" name of requesting physician
+12 ; "OBR20" name of ward location or principal clinic
+13 ; "LAN-A" LANIER ONLY --> $p(racn0,"^",2)
+14 ; "LAN-B" LANIER ONLY --> $p(^ramis(71,+$p(racn0,"^",2),0),"^")
+15 ; "OBX5" radisp_$p(^ramis(71,+$p(racn0,"^",2),0),"^")
+16 ; radisp_"Unknown" if no procedure
+17 ; where radisp is + or . for printset
+18 ; "OBX5-MOD" string of modifiers
+19 ; "OBX-HIST-NONE" "None Entered" if no clinical history
+20 ; "OBX5-ALLE" string of allergies
+21 ;
+22 ; "RADFN" RADFN
+23 ; "VADM(1)" VADM(1)
+24 ; "VADM(3)" VADM(3)
+25 ; "RAPRV" RAPRV
+26 ; "RADTE0" RADTE0
+27 ;
+28 ; RACN0 = Examinations 0 node (70.03 sub-file)
EN1 SET RADTE0=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,0)):+^(0),1:"")
+1 SET RADTE=$SELECT(RADTE0:$EXTRACT(RADTE0,4,7)_$EXTRACT(RADTE0,2,3)_"-"_+RACN0,1:+RACN0)
+2 ;
+3 ;Compile 'PID' Segment
+4 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"RADFN")=RADFN
+5 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"VADM(1)")=VADM(1)
+6 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"VADM(3)")=VADM(3)
+7 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"PID8")=$SELECT(VADM(5)]"":$SELECT("MF"[$PIECE(VADM(5),"^"):$PIECE(VADM(5),"^"),1:"O"),1:"U")
+8 if $PIECE(VADM(2),"^")]""
SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"PID19")=$PIECE(VADM(2),"^")
+9 ;
+10 ;Compile 'OBR' Segment
+11 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR4A")=RADTI_"-"_RACNI
+12 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR4B")=RADTE
+13 SET RAPRV=$PIECE($GET(^VA(200,+$PIECE(RACN0,"^",14),0)),"^")
+14 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR16A")=$SELECT(RAPRV]"":+$PIECE(RACN0,"^",14),1:"")
+15 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"RAPRV")=RAPRV
+16 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"RADTE0")=RADTE0
+17 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR20")=$SELECT($DATA(^DIC(42,+$PIECE(RACN0,"^",6),0)):$PIECE(^(0),"^"),$DATA(^SC(+$PIECE(RACN0,"^",8),0)):$PIECE(^(0),"^"),1:"Unknown")
+18 ;
+19 ;Compile 'OBX' Segment for Procedure
+20 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"LAN-A")=$PIECE(RACN0,"^",2)
+21 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"LAN-B")=$SELECT($DATA(^RAMIS(71,+$PIECE(RACN0,"^",2),0)):$PIECE(^(0),"^"),1:"")
+22 ;
+23 ; set flags if print set and/or lowest case of print set
+24 NEW RACN,RAPRTSET,RAMEMLOW,RADISP
+25 SET RACN=+RACN0
SET RAPRTSET=0
SET RAMEMLOW=0
SET RADISP=" "
+26 DO EN1^RAUTL20
+27 IF RAPRTSET
SET RADISP="."
if RAMEMLOW
SET RADISP="+"
+28 ;For Lanier units, comment out next line
+29 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5")=$SELECT($DATA(^RAMIS(71,+$PIECE(RACN0,"^",2),0)):RADISP_$PIECE(^(0),"^"),1:"Unknown")
+30 ;
+31 ;Compile 'OBX' Segment for Modifiers
+32 DO MODS^RAUTL2
+33 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5-MOD")=Y
+34 ;
+35 ;Compile 'OBX' Segment for Clinical History
+36 IF '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0))
SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX-HIST-NONE")="None Entered"
+37 KILL ^UTILITY($JOB,"W")
SET DIWF=""
SET DIWR=80
SET DIWL=1
FOR RAI=0:0
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI))
if 'RAI
QUIT
IF $DATA(^(RAI,0))
SET X=^(0)
DO ^DIWP
+38 ; save ^UTILITY($J,"W") for bridge routine
+39 ;
+40 ;Compile 'OBX' Segment for Allergies
+41 SET DFN=RADFN
DO ALLERGY^RADEM
SET X=""
IF $DATA(GMRAL)
SET I=0
FOR
SET I=$ORDER(PI(I))
if I'>0
QUIT
SET X0=PI(I)
IF X0]""
if ($LENGTH(X)+$LENGTH(X0))>200
QUIT
SET X=X_X0_", "
+42 IF $LENGTH(X)
SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5-ALLE")=X
+43 KILL DIWF,DIWL,DIWR,GMRAL,I,PI,RAI,RAPRV,RADTE,RADTE0
+44 QUIT
