- 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 Mar 13, 2025@21:40:10 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
