Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAHLRU1

RAHLRU1.m

Go to the documentation of this file.
  1. RAHLRU1 ;HISC/PB,GJC - utilities for HL7 messaging ;1/28/00 11:03
  1. ;;5.0;Radiology/Nuclear Medicine;**47,114**;Mar 16, 1998;Build 1
  1. ;
  1. ;IA 5023: builds the PID ($$PID^MAGDHLS) & PV1 ($$PV1^MAGDHLS) segments
  1. ;Integration Agreements
  1. ;----------------------
  1. ;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); M11^HLFNC(10106)
  1. ;GENERATE^HLMA(2164); $$PID^MAGDHLS(5023); $$PV1^MAGDHLS(5023)
  1. ;$$DT^XLFDT(10103); $$LOW^XLFSTR(10104)
  1. ;
  1. ;IA: 10060 global of file ^VA(200
  1. ;
  1. PID(RADFN) ;compile the PID segment
  1. ;$$PID^MAGDHLS(XDFN,XYMSG)
  1. ; input: XDFN internal entry number of the patient on global ^DPT/^RADPT
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing PV1 elts
  1. ; function return 0 (success) always
  1. ;
  1. K RA0X S X=$$PID^MAGDHLS(RADFN,"RA0X")
  1. D MAG(.RA0X,.RAPID)
  1. D BLSEG("PID",.RAPID) K RA0X
  1. Q
  1. ;
  1. PV1(RADFN) ;compile the PV1 segment determine if the patient is
  1. ;an inpatient or outpatient by looking at the exam record
  1. ;$$PV1^MAGDHLS(XDFN,XEVN,XEVNDT,XYMSG)
  1. ; input: XDFN internal entry number of the patient on global ^DPT/^RADPT
  1. ; XEVN event type of this message
  1. ; XEVNDT event date/time (FileMan format)
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing PV1 elts
  1. ; function return 0 (success) always
  1. K RA0X S X=$$PV1^MAGDHLS(RADFN,"O01",RAZDTE,"RA0X")
  1. D MAG(.RA0X,.RAPV1)
  1. K:RAPV1(3)="O"&($G(RAPV1(20))=0) RAPV1(20)
  1. ;
  1. ;After call to MAG API add PV1-15: Ambulatory Status of the patient
  1. ;MODE OF TRANSPORT - file: 75.1, field: 19, node: 0, piece: 19
  1. ;'a' FOR AMBULATORY; 'p' FOR PORTABLE;
  1. ;'s' FOR STRETCHER; 'w' FOR WHEEL CHAIR;
  1. ;
  1. ;'a' translates to 'A0', 's' & 'w' translate to 'A2'
  1. ;
  1. ;PREGNANT - first check field (70.03,32) if NULL check field (75.1,13)
  1. ; file: 70.03, field: 32, node: 0, piece: 32
  1. ; 'y' FOR 'Patient answered yes'
  1. ; 'n' FOR 'Patient answered no'
  1. ; 'u' FOR 'Patient is unable to answer or is unsure'
  1. ; file: 75.1, field: 13, node: 0, piece: 13
  1. ; 'y' FOR YES; 'n' FOR NO; 'u' FOR UNKNOWN;
  1. ;
  1. ;'y' in either field translates to 'B6'
  1. ;
  1. ;PV1(15) might repeat; $E(HLECH,2) is the repeat character
  1. ;PV1(15) represented by RAPV1(16)
  1. S RAZPREG=$P($G(RAZXAM),U,32) I RAZPREG="" S RAZPREG=$P($G(RAZORD),U,13)
  1. S RAZMODE=$P($G(RAZORD),U,19)
  1. S RAPV1(16)=$S(RAZMODE="a":"A0",RAZMODE="s":"A2",RAZMODE="w":"A2",1:"")
  1. I RAPV1(16)]"",RAZPREG="y" D
  1. .S RAPV1(16)=RAPV1(16)_$E(HLECH,2)_"B6"
  1. .Q
  1. E I RAPV1(16)="",RAZPREG="y" S RAPV1(16)="B6"
  1. ;
  1. D BLSEG("PV1",.RAPV1) K RA0X
  1. Q
  1. ;
  1. REPEAT(X,N) ;return a string of HL7 encoding characters; ideal when a field
  1. ;is comprised of many components
  1. ;input: X=character repeated; for example, the component delimiter
  1. ; N=string length of the character
  1. ;rturn: S=string in question
  1. N S S $P(S,X,(N+1))=""
  1. Q S
  1. ;
  1. MAG(XX,RAD) ;Build the HL7 segment from the array passed back from the
  1. ;Imaging IA (#5023). HLCS, HLSCS, & HLREP defined in INIT^RAHLR
  1. N I,I1,I2,I3,II
  1. ;I = HL7 Field #
  1. ;I1 = Repetition sequence 1,2,3...
  1. ;I2 = Component
  1. ;I3 = Subcomponent
  1. ;HLCS = Component separator
  1. ;HLSCS = SubComponent separator.
  1. ;HLREP = Repetition separator
  1. S I=0 F S I=$O(XX(1,I)) Q:'I S I1=0 K II D
  1. .F S I1=$O(XX(1,I,I1)) Q:'$L(I1) S I2=0 D S $P(RAD(I+1),HLREP,I1)=$G(II(I1))
  1. ..F S I2=$O(XX(1,I,I1,I2)) Q:'$L(I2) S I3=0 D S $P(II(I1),HLCS,I2)=$G(II(I1,I2))
  1. ...F S I3=$O(XX(1,I,I1,I2,I3)) Q:'I3 S $P(II(I1,I2),HLSCS,I3)=$G(XX(1,I,I1,I2,I3))
  1. S I=0 F S I=$O(RAD(I)) Q:'$L(I) K:'$L(RAD(I)) RAD(I)
  1. Q
  1. ;
  1. RTNSUB(A) ;return the current first level subscript for the A array
  1. ; default is : HLA array
  1. ; If array (HLA) is undefined, or only HLA("HLS") defined, return 0
  1. S:'$L($G(A)) A="HLA(""HLS"","
  1. S A=A_"$C(32))"
  1. Q +$O(@A,-1)
  1. ;
  1. BLSEG(SEG,X,ADR) ;
  1. ;input: SEG="PV1" or "ORC", etc...
  1. ; X=is the HL7 segment specific array subscripted by field #
  1. ; Ex: PV1(2) is the PATIENT CLASS
  1. ; ADR=ADDRESS where to put output if not defined set to HLA("HLS"
  1. ; but may be: ^TMP("HL7", is the same as root file in Fileman
  1. N DATA,I,J,JJ,REMAIN,Y,YY,YYSUB,XOLD,SS,A1,A2
  1. S:'$L($G(ADR)) ADR="HLA(""HLS"","
  1. S:ADR'["(" ADR=ADR_"("
  1. S A1=ADR_"Y)" ; Y = 1st subscript (ie HLA("HLS",Y))
  1. S A2=ADR_"Y,YY)" ;YY = 2nd subscript if split (ie HLA("HLS",Y,YY))
  1. ; if YY > 0, it means the segment has been split
  1. S Y=$$RTNSUB(ADR)+1,YY=0,JJ=0,SS=$E(HLECH,2)
  1. S @A1=SEG_HLFS,I=0 ;start with SEG, ie, OBR|
  1. F S I=$O(X(I)) Q:'I D ;loop thru incoming array, ie, RAOBR(n)
  1. .I $O(X(I,0)) D Q ;two subscripts/repeating field
  1. ..; This loop is for a second level subscript of the incoming array,
  1. ..; for example, Assistant Interpreter(s) -> RAOBR(34,1)="FIRST^STAFF",
  1. ..; RAOBR(34,2)="SECOND^STAFF", RAOBR(34,3)="THIRD^STAFF" etc
  1. ..S J=0 F S J=$O(X(I,J)) Q:'J D
  1. ...I YY D Q ;if already split do this loop
  1. ....S XOLD=$P($G(@A2),HLFS,I-YYSUB),$P(XOLD,SS,J-JJ)=X(I,J)
  1. ....S $P(@A2,HLFS,I-YYSUB)=XOLD ;add segment to output array
  1. ....D BLSEG2(.YY,.JJ,1) ;check if over 245, if so, split again
  1. ...;No split yet
  1. ...S XOLD=$P($G(@A1),HLFS,I),$P(XOLD,SS,J)=X(I,J)
  1. ...S $P(@A1,HLFS,I)=XOLD ;add segment to output array
  1. ...D BLSEG1 ;check if over 245, if so, split for first time
  1. ..Q
  1. ..;---------------------------------------------
  1. .E D ;single subscript only, non repeating field
  1. ..S JJ=0
  1. ..I YY D Q ;if already split do this loop
  1. ...S $P(@A2,HLFS,I-YYSUB)=X(I) ;add segment to output array
  1. ...D BLSEG2(.YY) ;check if over 245, if so, split again
  1. ...Q
  1. ..;No split yet
  1. ..S $P(@A1,HLFS,I)=X(I) ;add segment to output array
  1. ..D BLSEG1 ;check if over 245, if so, split for first time
  1. .Q
  1. Q
  1. BLSEG1 ;Split for first time
  1. Q:$L(@A1)<246 ;over 245 chars, split the string first time
  1. S REMAIN=$E(@A1,246,$L(@A1))
  1. S YY=1,@A2=$E(@A1,$L(SEG_HLFS)+1,245) ;YY/subscript = 1 for first split
  1. S YYSUB=$L(@A2,HLFS) ;YYSUB=number of "|" pieces
  1. S @A1=SEG_HLFS ;top level is segment only, ie "OBR|"
  1. S YY=2,@A2=REMAIN,JJ=1 ;YY/subscript = 2 for second half of split
  1. Q
  1. BLSEG2(YY,JJ,K) ;Split any subsequent times
  1. Q:$L(@A2)<246 ;over 245 chars, split the string again...
  1. S REMAIN=$E(@A2,246,$L(@A2))
  1. S @A2=$E(@A2,1,245)
  1. S YYSUB=YYSUB+$L(@A2,HLFS)-1 ;YYSUB=# of "|" pieces counter
  1. S YY=YY+1 ;YY/subscript incremented with each split
  1. S:$G(K) JJ=J-$L(REMAIN,SS) ;K,JJ for repeating field/double subscript
  1. S @A2=REMAIN
  1. Q
  1. ;
  1. PARSEG(ARR,PAR) ;Parse segment from ARR array to PAR array
  1. ;data passed in ARR(1) and ARR(1,n) if overflow.
  1. Q:'$D(HLFS)
  1. N SS,I,II,D,FLDN,FLDN1,JJ,D1 S II=0,J=0,D=""
  1. S SS=$E($G(HLECH),2) Q:'$L(SS)
  1. S DATA=$G(ARR(1))
  1. I $L(DATA) D
  1. .D PARPROC(DATA) S I=0
  1. .F S I=$O(ARR(1,I)) Q:'I D PARPROC(ARR(1,I))
  1. .Q
  1. Q
  1. ;
  1. PARPROC(DATA) ;process data...
  1. S FLDN=$L(DATA,HLFS) ;number of fields on this node
  1. F II=1:1:FLDN D
  1. .S D=$S(II=1:D,1:"")_$P(DATA,HLFS,II)
  1. .D GETPP(.D)
  1. S J=J+FLDN-1
  1. Q
  1. ;
  1. GETPP(D) ;get repeated fields...
  1. Q:'$L(D)
  1. I D'[SS S PAR(J+II)=D K D1 Q
  1. S FLDN1=$L(D,SS) F JJ=1:1:FLDN1 D
  1. .S D1=$P(D,SS,JJ) S:$L(D1) PAR(J+II,JJ)=D1
  1. Q
  1. ;
  1. VFIER(X1,X2,X3) ; validation of OBR-32 , OBR-33 or OBR-35
  1. ; X1 = value to be Validated/Returned (IEN)
  1. ; Note: X1 is passed in as: ID Number (IEN)^Family Name^Given Name
  1. ; (in this example "^" is the subcomponent separator)
  1. ; X2 = Status ('C'orrected, 'F'inal, or 'R'esults filed, not verified)
  1. ; X3 = text 'OBR-32' or 'OBR-33' or 'OBR-33x' or 'OBR 35'
  1. ; Return value: 1 = Validation OK
  1. ; 0^Error message to be returned to sender
  1. N C,DIERR,RARRAY,RAERROR,RALBL
  1. S RALBL=$S(X3="OBR-32":"staff","OBR-33":"resident",1:"transcriptionist")
  1. ;Note +X1 (we want only the IEN)
  1. D FIND^DIC(200,"",.01,"A",+X1,"","","","","RARRAY","RAERROR")
  1. ;if $D(RAERROR("DIERR")) the input value is invalid (control character)
  1. I $D(RAERROR("DIERR"))#2 Q "0^Invalid "_RALBL_" name"
  1. ;how many hits? = 0 lookup failed...
  1. I $P($G(RARRAY("DILIST",0)),U)=0 Q "0^Lookup failed; no "_RALBL_" name found"
  1. ;how many hits? = 1 just right...
  1. Q 1
  1. ;
  1. INDT(X1) ;check if MD has inactivation date.
  1. N RAINDT
  1. S RAINDT=$$GET1^DIQ(200,+X1,73,"I") I $G(RAINDT),RAINDT'>$$DT^XLFDT S RAERR="Physician is INACTIVE" Q "1^"_RAERR
  1. Q 0
  1. ;
  1. SR(X1) ;'S'taff or 'R'esident and inactive DATE
  1. ;input: ID Number (aka IEN)
  1. ;return: RASTRE: classification (staff, resident, clerk)
  1. ; : -1 w/error code if error
  1. I +X1=0 S RASTRE="-1^"_"Missing or invalid IEN" Q
  1. N DIERR,RARRAY,RAERROR,X,Y S X1=+X1_","
  1. D GETS^DIQ(200,X1,"72*:73","I","RARRAY","RAERROR")
  1. ;if error return error message...
  1. I $D(RAERROR("DIERR"))#2 S RASTRE="-1^"_"The entry does not exist" Q
  1. ;we know the function finds a record.
  1. ;first check: has the individual been inactivated?
  1. S Y=$G(^RARRAY(200,X1,73,"I")) I Y Q:Y'>DT "-1^user inactivated"
  1. ;what's the classification of the user?
  1. S X="",RASTRE=U
  1. F S X=$O(RARRAY(200.072,X)) Q:X="" S RASTRE=RASTRE_$G(RARRAY(200.072,X,.01,"I"))_U
  1. Q
  1. ;
  1. SPECSRC(RAOIFN) ;Specimen Source OBR-15
  1. ;Input: the IEN of the order record from the RAD/NUC MED ORDERS (#75.1)
  1. ;return: Specimen Source string (PROCEDURE MODIFIERS (left & right only))
  1. N RASPSRC S RASS=0
  1. F S RASS=$O(^RAO(75.1,RAOIFN,"M",RASS)) Q:'RASS D
  1. .S RAZPMOD=+$G(^RAO(75.1,RAOIFN,"M",RASS,0)) ;RAZPMOD=ptr to file 71.2
  1. .;convert the procedure modifier to lower case
  1. .S RASPSRC(0)=$$LOW^XLFSTR($P($G(^RAMIS(71.2,RAZPMOD,0)),U))
  1. .S:RASPSRC(0)="left"!(RASPSRC(0)="right") RASPSRC=$G(RASPSRC)_RASPSRC(0)_" "
  1. .Q
  1. I $L($G(RASPSRC)) S RASPSRC=$E(RASPSRC,1,($L(RASPSRC)-1))
  1. K RASS,RAZPMOD
  1. Q $G(RASPSRC)
  1. ;
  1. SETUP ; Setup basic examination information
  1. S:RASET RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1. S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0)
  1. S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1)
  1. S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9)
  1. S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT)
  1. S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN)
  1. Q
  1. ;
  1. USESSAN() ; Return the value of the parameter used as the switch
  1. ; to turn on use of the Site Specific Accession Numbers
  1. N RADIVIEN S RADIVIEN="" S RADIVIEN=$O(^RA(79,0)) I RADIVIEN="" Q 0
  1. I $P($G(^RA(79,RADIVIEN,.1)),"^",31)="Y" Q 1
  1. Q 0
  1. ;
  1. SSANVAL(RADFN,RADTI,RACNI) ; Return the value of the Site Specific Acc Number
  1. Q $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",31)
  1. ;
  1. DATEPRT(RADTE) ; Return the printable format of the internal date value
  1. Q $E(RADTE,4,5)_"/"_$E(RADTE,6,7)_"/"_$E(RADTE,2,3)