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