- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m
r613 r623 1 RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ;11/10/99 10:42 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80,84**;Mar 16, 1998;Build 13 3 ;Generates msg whenever a case is registered or cancelled or examined 4 ; registered cancelled examined 5 ; Order control : NW CA XO 6 ; Order status : IP CA CM 7 ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 8 ; 9 ;Integration Agreements 10 ;---------------------- 11 ;NOW^%DTC(10000); ^%ZTLOAD(10063); $$GET1^DIQ(2056); ^DIWP(10011) 12 ;$$HLDATE/$$HLNAME/$$M11^HLFNC(10106); INIT^HLFNC2(2161) 13 ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$EN^VAFHLPID(263) 14 ;$$FMTHL7^XLFDT(10103) 15 ; 16 ;IA: 10039 global read .01 field WARD LOCATION (#42) file ^DIC(42, 17 ;IA: 10040 global read .01 field HOSPITAL LOCATION (#44) file ^SC( 18 ; 19 S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" 20 S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" 21 S ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTIO="",ZTDTH=$H,ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="EN^RAHLR" D ^%ZTLOAD 22 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q 23 EN ; Called from the RA REG & RA CANCEL & RA EXAMINED protocols 24 ; Input Variables: 25 ; RADFN=file 2 IEN (DFN) 26 ; RADTI=file 70 Exam subrec IEN (reverse date/time of exam) 27 ; RACNI=file 70 Case subrecord IEN 28 ; RAEID=ien of the event driver protocol (defined in RAHLRPC) 29 ; Output Variables: 30 ; HLA("HLS") array containing HL7 msg 31 ; 32 N EID,HL,INT,HLQ,HLFS,HLECH,HLA,HLCS,HLSCS,HLREP,HLECH 33 N DFN,DIWF,DIWL,DIWR,GMRAL,PI,RACANC,RACN0,RACPT,RACPTNDE,RADTE,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAX0,VA,VADM,VAERR,X,X0,Y,X1,OBR36 34 ; 35 D INIT ; initialize some HL7 variables 36 ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met 37 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 38 Q:$O(HL(""))="" ;disabled server appl, or no server appl 39 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 40 I HL("VER")>2.3,($T(^RAHLR1))'="" D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q 41 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 42 S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" 43 ;Generate Message Text 44 S RAPROC=+$P(RACN0,U,2) I 'RAPROC Q ;If case entered via 'Enter Last Past Visit before DHCP option, and procedure 'OTHER' is inactive, RAPROC will be null and will cause bomb-out unless we quit here 45 S RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) 46 S (RADTE,OBR36)=9999999.9999-RADTI,RADTE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_+RACN0,RACANC=$S($D(^RA(72,"AA",RAPROCIT,0,+$P(RACN0,"^",3))):1,1:0) 47 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 48 ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited 49 ;I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="",'$G(RATELE) Q ;last chance to stop exm'd msg if it's already been sent RA*5*84 Is TELERAD ?? 50 ;Compile 'PID' Segment 51 K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 52 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 53 ; for an inexact date of birth. If inexact, pass null for DOB in 54 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 55 I HL("VER")']"2.2" D 56 .S HLA("HLS",1)="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_$$M11^HLFNC(RADFN)_HLFS_HLFS_$$HLNAME^HLFNC(VADM(1))_HLFS_HLFS_$$HLDATE^HLFNC(RAVADM(3))_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") 57 .S:$P(VADM(2),"^")]"" $P(HLA("HLS",1),HLFS,20)=$P(VADM(2),"^") 58 I HL("VER")]"2.2" S HLA("HLS",1)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") 59 K RAVADM 60 ;Compile 'ORC' Segment 61 S X0="" ;if exam-set or print-set, store parent name if order exists 62 I $P(RACN0,U,25) S X0=$P(RACN0,U,11),X0=$P($G(^RAO(75.1,+X0,0)),U,2),X0=$P($G(^RAMIS(71,+X0,0)),U),X0=$S(X0="":"ORIGINAL ORDER PURGED",1:X0),X0=$S($P(RACN0,U,25)=1:"EXAM",1:"PRINT")_"SET: "_X0 63 ; BNT - Added ORC4 Placer Group Number for Printset identification. 64 ; ORC4 is a combination of SSN with the order inverted date/time. 65 S RAORC4="" I $P($G(RACN0),U,25)=2 D 66 . S:$P(VADM(2),"^")]"" RAORC4=$P(VADM(2),"^") 67 . S RAORC4=$G(RAORC4)_RADTI 68 S HLA("HLS",2)="ORC"_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW")_HLFS_HLFS_HLFS_RAORC4_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"CM",1:"IP")_HLFS_HLFS_HLFS_X0_HLFS_HLDT1 69 K RAORC4 70 ;Compile 'OBR' Segment 71 S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$P(RACPTNDE,U,2)_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$P(RAPRCNDE,U)_$E(HLECH)_"99RAP" 72 ; Replace above with following when Imaging can cope with ESC chars 73 ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP" 74 I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 75 ;OBR-7 change: from HLDT1 to $$HLDATE^HLFNC(9999999.9999-RADTI) d/t of registration 76 ;Driver of change: CareStream Health PACS. Agfa requires a timestamp down to the second 77 ;POC @ Boston is Maureen Sullivan 78 S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_$$HLDATE^HLFNC(9999999.9999-RADTI) 79 S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS 80 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 81 S HLA("HLS",3)=HLA("HLS",3)_$S(RAPRV]"":+$P(RACN0,"^",14)_$E(HLECH)_$$HLNAME^HLFNC(RAPRV),1:"") 82 ; 83 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 84 ;Seg's fld 20 = pce 21 --> ien file #79.1~name of img loc~stn #~stn name 85 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 86 S $P(HLA("HLS",3),HLFS,21)=$P(RACN00,U,4)_$E(HLECH)_$P($G(^SC(RA20,0)),U)_$E(HLECH)_$P(RACN00,U,3)_$E(HLECH)_$P($G(^DIC(4,+$P(RACN00,U,3),0)),U) 87 S $P(HLA("HLS",3),HLFS,21)=$P(HLA("HLS",3),HLFS,21) 88 ; Replace above with following when Imaging can cope with ESC chars 89 ; S $P(HLA("HLS",3),HLFS,21)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,21)) 90 ;Seg's fld 21 = pce 22 --> abbrv I-type~Img type name 91 S RA20=$G(^RA(79.2,+$P(RACN00,U,2),0)) 92 S $P(HLA("HLS",3),HLFS,22)=$P(RA20,U,3)_$E(HLECH)_$P(RA20,U) 93 S $P(HLA("HLS",3),HLFS,22)=$P(HLA("HLS",3),HLFS,22) 94 ; Replace above with following when Imaging can cope with ESC chars 95 ; S $P(HLA("HLS",3),HLFS,22)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,22)) 96 ; 97 S $P(HLA("HLS",3),HLFS,23)=HLDT1,$P(HLA("HLS",3),HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") 98 ; 99 ; OBR-31.2 = Reason for Study P75 100 S $P(HLA("HLS",3),HLFS,32)=$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) 101 ; 102 ; OBR-36 = Exam Date/Time 103 S $P(HLA("HLS",3),HLFS,37)=$$FMTHL7^XLFDT(OBR36) 104 ; 105 I 'RACANC S X=$P($G(^RAO(75.1,+$P(RACN0,"^",11),0)),"^",6),$P(HLA("HLS",3),HLFS,28)=$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$TR(X,"129","SAR") 106 ; if long str, break so 2nd str begins with separator to avoid abend 107 I $L(HLA("HLS",3))>245 N RAPART,RA1 S RA1=HLA("HLS",3) F RAPART=5:1:15 S RAPART(1)=$P(RA1,HLFS,1,RAPART),RAPART(2)=$P(RA1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="") 108 I $D(RAPART) K:RAPART=15 RAPART ;if RAPART reaches 15, then something's wrong so kill RAPART to allow abend due "string too long" 109 I $D(RAPART) S HLA("HLS",3)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",3,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",3,2)=RAPART(2) K RAPART,RA1 110 OBXPRC ;Compile 'OBX' Segment for Procedure 111 S RAN=4 D OBXPRC^RAHLRU 112 OBXMOD ;Compile 'OBX' Segment for two types of Modifiers 113 S RAN=5 D OBXMOD^RAHLRU 114 OBXHIST ;Compile 'OBX' Segment for Clinical History 115 I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU G ALLER 116 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 117 F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 118 ALLER ;Compile 'OBX' Segment for Allergies 119 S DFN=RADFN D ALLERGY^RADEM S X="" I $D(GMRAL) S RAI=0 F S RAI=$O(PI(RAI)) Q:RAI'>0 S X0=PI(RAI) I X0]"" Q:($L(X)+$L(X0))>200 S X=X_X0_", " 120 I $L(X) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"_HLFS_HLFS_X D OBX11^RAHLRU 121 OBXTCM ;Compile 'OBX' Segment for Tech Comment 122 D OBXTCM^RAHLRU 123 EXIT ; set HL7 message type & return to protocol 124 K ^UTILITY($J,"W") 125 S HL("MTN")="ORM" 126 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 127 S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 128 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") 129 D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1") 130 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 131 Q 132 Q ;Entry Point to Process an ORR Message (Just a Quit Since No Processing is Required) 133 Q 134 INIT ; initialize HL7 variables 135 D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) 136 ;Note: HLDT1 is used for HL7 fields: ORC-9 & OBR-22 137 Q:'$G(RAEID) S EID=RAEID 138 S HL="HLS(""HLS"")",INT=1 139 D INIT^HLFNC2(EID,.HL,INT) 140 Q:'$D(HL("Q")) ;no server application defined 141 S HLQ=HL("Q") 142 S HLECH=HL("ECH") 143 S HLFS=HL("FS") 144 S HLCS=$E(HL("ECH")) 145 S HLSCS=$E(HL("ECH"),4) 146 S HLREP=$E(HL("ECH"),2) 147 Q 1 RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ;11/10/99 10:42 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80**;Mar 16, 1998;Build 19 3 ;Generates msg whenever a case is registered or cancelled or examined 4 ; registered cancelled examined 5 ; Order control : NW CA XO 6 ; Order status : IP CA CM 7 ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 8 S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" 9 S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" 10 S ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTIO="",ZTDTH=$H,ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="EN^RAHLR" D ^%ZTLOAD 11 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q 12 EN ; Called from the RA REG & RA CANCEL & RA EXAMINED protocols 13 ; Input Variables: 14 ; RADFN=file 2 IEN (DFN) 15 ; RADTI=file 70 Exam subrec IEN (reverse date/time of exam) 16 ; RACNI=file 70 Case subrecord IEN 17 ; RAEID=ien of the event driver protocol (defined in RAHLRPC) 18 ; Output Variables: 19 ; HLA("HLS") array containing HL7 msg 20 ; 21 N EID,HL,INT,HLQ,HLFS,HLECH,HLA,HLCS,HLSCS,HLREP,HLECH 22 N DFN,DIWF,DIWL,DIWR,GMRAL,PI,RACANC,RACN0,RACPT,RACPTNDE,RADTE,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAX0,VA,VADM,VAERR,X,X0,Y,X1,OBR36 23 ; 24 D INIT ; initialize some HL7 variables 25 ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met 26 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 27 Q:$O(HL(""))="" ;disabled server appl, or no server appl 28 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 29 ;I HL("VER")]2.3 D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q 30 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 31 S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" 32 ;Generate Message Text 33 S RAPROC=+$P(RACN0,U,2) I 'RAPROC Q ;If case entered via 'Enter Last Past Visit before DHCP option, and procedure 'OTHER' is inactive, RAPROC will be null and will cause bomb-out unless we quit here 34 S RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) 35 S (RADTE,OBR36)=9999999.9999-RADTI,RADTE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_+RACN0,RACANC=$S($D(^RA(72,"AA",RAPROCIT,0,+$P(RACN0,"^",3))):1,1:0) 36 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 37 ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited 38 I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="" Q ;last chance to stop exm'd msg if it's already been sent 39 ;Compile 'PID' Segment 40 K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 41 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 42 ; for an inexact date of birth. If inexact, pass null for DOB in 43 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 44 I HL("VER")']"2.2" D 45 .S HLA("HLS",1)="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_$$M11^HLFNC(RADFN)_HLFS_HLFS_$$HLNAME^HLFNC(VADM(1))_HLFS_HLFS_$$HLDATE^HLFNC(RAVADM(3))_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") 46 .S:$P(VADM(2),"^")]"" $P(HLA("HLS",1),HLFS,20)=$P(VADM(2),"^") 47 I HL("VER")]"2.2" S HLA("HLS",1)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") 48 K RAVADM 49 ;Compile 'ORC' Segment 50 S X0="" ;if exam-set or print-set, store parent name if order exists 51 I $P(RACN0,U,25) S X0=$P(RACN0,U,11),X0=$P($G(^RAO(75.1,+X0,0)),U,2),X0=$P($G(^RAMIS(71,+X0,0)),U),X0=$S(X0="":"ORIGINAL ORDER PURGED",1:X0),X0=$S($P(RACN0,U,25)=1:"EXAM",1:"PRINT")_"SET: "_X0 52 ; BNT - Added ORC4 Placer Group Number for Printset identification. 53 ; ORC4 is a combination of SSN with the order inverted date/time. 54 S RAORC4="" I $P($G(RACN0),U,25)=2 D 55 . S:$P(VADM(2),"^")]"" RAORC4=$P(VADM(2),"^") 56 . S RAORC4=$G(RAORC4)_RADTI 57 S HLA("HLS",2)="ORC"_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW")_HLFS_HLFS_HLFS_RAORC4_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"CM",1:"IP")_HLFS_HLFS_HLFS_X0_HLFS_HLDT1 58 K RAORC4 59 ;Compile 'OBR' Segment 60 S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$P(RACPTNDE,U,2)_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$P(RAPRCNDE,U)_$E(HLECH)_"99RAP" 61 ; Replace above with following when Imaging can cope with ESC chars 62 ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP" 63 I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 64 S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_HLDT1 65 S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS 66 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 67 S HLA("HLS",3)=HLA("HLS",3)_$S(RAPRV]"":+$P(RACN0,"^",14)_$E(HLECH)_$$HLNAME^HLFNC(RAPRV),1:"") 68 ; 69 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 70 ;Seg's fld 20 = pce 21 --> ien file #79.1~name of img loc~stn #~stn name 71 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 72 S $P(HLA("HLS",3),HLFS,21)=$P(RACN00,U,4)_$E(HLECH)_$P($G(^SC(RA20,0)),U)_$E(HLECH)_$P(RACN00,U,3)_$E(HLECH)_$P($G(^DIC(4,+$P(RACN00,U,3),0)),U) 73 S $P(HLA("HLS",3),HLFS,21)=$P(HLA("HLS",3),HLFS,21) 74 ; Replace above with following when Imaging can cope with ESC chars 75 ; S $P(HLA("HLS",3),HLFS,21)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,21)) 76 ;Seg's fld 21 = pce 22 --> abbrv I-type~Img type name 77 S RA20=$G(^RA(79.2,+$P(RACN00,U,2),0)) 78 S $P(HLA("HLS",3),HLFS,22)=$P(RA20,U,3)_$E(HLECH)_$P(RA20,U) 79 S $P(HLA("HLS",3),HLFS,22)=$P(HLA("HLS",3),HLFS,22) 80 ; Replace above with following when Imaging can cope with ESC chars 81 ; S $P(HLA("HLS",3),HLFS,22)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,22)) 82 ; 83 S $P(HLA("HLS",3),HLFS,23)=HLDT1,$P(HLA("HLS",3),HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") 84 ; 85 ; OBR-31.2 = Reason for Study P75 86 S $P(HLA("HLS",3),HLFS,32)=$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) 87 ; 88 ; OBR-36 = Exam Date/Time 89 S $P(HLA("HLS",3),HLFS,37)=$$FMTHL7^XLFDT(OBR36) 90 ; 91 I 'RACANC S X=$P($G(^RAO(75.1,+$P(RACN0,"^",11),0)),"^",6),$P(HLA("HLS",3),HLFS,28)=$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$TR(X,"129","SAR") 92 ; if long str, break so 2nd str begins with separator to avoid abend 93 I $L(HLA("HLS",3))>245 N RAPART,RA1 S RA1=HLA("HLS",3) F RAPART=5:1:15 S RAPART(1)=$P(RA1,HLFS,1,RAPART),RAPART(2)=$P(RA1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="") 94 I $D(RAPART) K:RAPART=15 RAPART ;if RAPART reaches 15, then something's wrong so kill RAPART to allow abend due "string too long" 95 I $D(RAPART) S HLA("HLS",3)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",3,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",3,2)=RAPART(2) K RAPART,RA1 96 OBXPRC ;Compile 'OBX' Segment for Procedure 97 S RAN=4 D OBXPRC^RAHLRU 98 OBXMOD ;Compile 'OBX' Segment for two types of Modifiers 99 S RAN=5 D OBXMOD^RAHLRU 100 OBXHIST ;Compile 'OBX' Segment for Clinical History 101 I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU G ALLER 102 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 103 F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 104 ALLER ;Compile 'OBX' Segment for Allergies 105 S DFN=RADFN D ALLERGY^RADEM S X="" I $D(GMRAL) S RAI=0 F S RAI=$O(PI(RAI)) Q:RAI'>0 S X0=PI(RAI) I X0]"" Q:($L(X)+$L(X0))>200 S X=X_X0_", " 106 I $L(X) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"_HLFS_HLFS_X D OBX11^RAHLRU 107 OBXTCM ;Compile 'OBX' Segment for Tech Comment 108 D OBXTCM^RAHLRU 109 EXIT ; set HL7 message type & return to protocol 110 K ^UTILITY($J,"W") 111 S HL("MTN")="ORM" 112 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 113 S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 114 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP) 115 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 116 Q 117 Q ;Entry Point to Process an ORR Message (Just a Quit Since No Processing is Required) 118 Q 119 INIT ; initialize HL7 variables 120 D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) 121 Q:'$G(RAEID) S EID=RAEID 122 S HL="HLS(""HLS"")",INT=1 123 D INIT^HLFNC2(EID,.HL,INT) 124 Q:'$D(HL("Q")) ;no server application defined 125 S HLQ=HL("Q"),HLFS=HL("FS") 126 S HLECH=HL("ECH") 127 S HLFS=HL("FS") 128 S HLCS=$E(HL("ECH")) 129 S HLSCS=$E(HL("ECH"),4) 130 S HLREP=$E(HL("ECH"),2) 131 Q
Note:
See TracChangeset
for help on using the changeset viewer.
