- 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)